diff --git a/.licensing.json b/.licensing.json index 1f01cc8a..62cd6ddd 100644 --- a/.licensing.json +++ b/.licensing.json @@ -9,7 +9,6 @@ "examples/**", "doxygen/**", "**/*m4", - "**/CMakeLists.txt", "config.guess", "config.sub", "configure", diff --git a/Makefile.in b/Makefile.in index e06d5a23..231fc9f9 100644 --- a/Makefile.in +++ b/Makefile.in @@ -58,6 +58,8 @@ BLAS_LIBS = @BLAS_LIBS@ # ZLIB_CFLAGS = @ZLIB_CFLAGS@ ZLIB_LIBS = @ZLIB_LIBS@ +PNG_CFLAGS = @PNG_CFLAGS@ +PNG_LIBS = @PNG_LIBS@ # # FFTW3 settings # @@ -101,6 +103,8 @@ depends: $(MAKE_MOD_DEP) BLAS_LIBS="$(BLAS_LIBS)" \ ZLIB_CFLAGS="$(ZLIB_CFLAGS)" \ ZLIB_LIBS="$(ZLIB_LIBS)" \ + PNG_CFLAGS="$(PNG_CFLAGS)" \ + PNG_LIBS="$(PNG_LIBS)" \ FFTW3_CFLAGS="$(FFTW3_CFLAGS)" \ FFTW3_LIBS="$(FFTW3_LIBS)" \ HDF5_FFLAGS="$(HDF5_FFLAGS)" \ @@ -138,6 +142,8 @@ makemake: $(MAKE_MOD_DEP) BLAS_LIBS="$(BLAS_LIBS)" \ ZLIB_CFLAGS="$(ZLIB_CFLAGS)" \ ZLIB_LIBS="$(ZLIB_LIBS)" \ + PNG_CFLAGS="$(PNG_CFLAGS)" \ + PNG_LIBS="$(PNG_LIBS)" \ FFTW3_CFLAGS="$(FFTW3_CFLAGS)" \ FFTW3_LIBS="$(FFTW3_LIBS)" \ HDF5_FFLAGS="$(HDF5_FFLAGS)" \ diff --git a/configure b/configure index da1f5100..b07fe20c 100755 --- a/configure +++ b/configure @@ -4070,6 +4070,15 @@ esac fi +# Check whether --with-libpng was given. +if test ${with_libpng+y} +then : + withval=$with_libpng; USE_libpng='yes' +else $as_nop + USE_libpng='no' +fi + + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: with-fftw3... \"${USE_fftw3}\"" >&5 printf "%s\n" "with-fftw3... \"${USE_fftw3}\"" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enable-libpng...\"${USE_libpng}\"" >&5 diff --git a/doc/CALYPSO.pdf b/doc/CALYPSO.pdf index 68af68c7..38213003 100644 Binary files a/doc/CALYPSO.pdf and b/doc/CALYPSO.pdf differ diff --git a/doc/CALYPSO.tex b/doc/CALYPSO.tex index c8bda5f6..1e06b98e 100644 --- a/doc/CALYPSO.tex +++ b/doc/CALYPSO.tex @@ -47,6 +47,7 @@ \section*{Preface} % \newpage \input{tex_src/programs_CALYPSO.tex} +\input{tex_src/viz_CALYPSO.tex} \newpage \begin{thebibliography}{10} diff --git a/doc/tex_src/viz_CALYPSO.tex b/doc/tex_src/viz_CALYPSO.tex new file mode 100644 index 00000000..dea47d33 --- /dev/null +++ b/doc/tex_src/viz_CALYPSO.tex @@ -0,0 +1,532 @@ +\subsection{Volume rendering data (Parallel volume rendering module)} + +Calypso includes parallel volume rendering (PVR) module for scalar field visualization. The PVR module generates volume rendering data during time integration without writing large size volume data. + +To output volume rendering data, increment of the volume rendering needs to be defined at \verb|i_step_sectioning_ctl| in \verb|time_step_ctl| block. Parameters foe each rendering are defined in array block \verb|volume_rendering| in \verb|visual_control|. Each \verb|volume_rendering| block can be stored in an external file, and the external file can be defined as \verb|file volume_rendering [File_Name]|. + +\paragraph{Control data} +The control parameters for PVR is the following: +\\ +% +Block \verb|volume_rendering| (Top level for volume rendering) +\\ +\label{href_i:volume_rendering} +\begin{itemize} + \item \hyperref[href_t:updated_sign] + {\tt updated\_sign [SIGNAL]} + \item \hyperref[href_t:pvr_file_prefix] + {\tt pvr\_file\_prefix [File\_Prefix]} + \item \hyperref[href_t:pvr_output_format] + {\tt pvr\_output\_format [File\_Format]} + \item \hyperref[href_t:monitoring_mode] + {\tt monitoring\_mode [ON/OFF]} +% + \item \hyperref[href_t:stereo_imaging] + {\tt stereo\_imaging [ON/OFF]} + \item \hyperref[href_t:anaglyph_switch] + {\tt anaglyph\_switch [ON/OFF]} + \item \hyperref[href_t:quilt_3d_imaging] + {\tt quilt\_3d\_imaging [ON/OFF]} +% + \item \hyperref[href_t:output_field] + {\tt output\_field [Field\_Name]} + \item \hyperref[href_t:output_component] + {\tt output\_component [Component\_Name]} +% + \item File or Block \verb|view_transform_ctl| + \label{href_i:view_transform_ctl} + \begin{itemize} + \item Block \verb|image_size_ctl| + \label{href_i:image_size_ctl} + \begin{itemize} + \item \hyperref[href_t:x_pixel_ctl] + {\tt x\_pixel\_ctl [\# of PIXELS]} + \item \hyperref[href_t:y_pixel_ctl] + {\tt y\_pixel\_ctl [\# of PIXELS]} + \end{itemize} +% + \item Array \hyperref[href_t:modelview_matrix_ctl] + {\tt modelview\_matrix\_ctl [X/Y/X/W] [X/Y/Z/W] [VALUE]} + \item Array \hyperref[href_t:look_at_point_ctl] + {\tt look\_at\_point\_ctl [X/Y/Z] [VALUE]} + \item Array \hyperref[href_t:eye_position_ctl] + {\tt eye\_position\_ctl [X/Y/Z] [VALUE]} + \item Array \hyperref[href_t:up_direction_ctl] + {\tt up\_direction\_ctl [X/Y/Z] [VALUE]} + \item Array \hyperref[href_t:view_rotation_vec_ctl] + {\tt view\_rotation\_vec\_ctl [X/Y/Z] [VALUE]} + \item \hyperref[href_t:view_rotation_deg_ctl] + {\tt view\_rotation\_deg\_ctl [DEGREE]} + \item \hyperref[href_t:scale_factor_ctl] + {\tt scale\_factor\_ctl [SCALE]} + \item Array \hyperref[href_t:scale_factor_vec_ctl] + {\tt scale\_factor\_vec\_ctl [X/Y/Z] [SCALE]} + \item Array \hyperref[href_t:eye_position_in_viewer_ctl] + {\tt eye\_position\_in\_viewer\_ctl [X/Y/Z] [VALUE]} +% +% \item \hyperref[href_t:projection_type_ctl] +% {\tt projection\_type\_ctl [TYPE]} +% + \item Block \verb|projection_matrix_ctl| + \label{href_i:projection_matrix_ctl} + \begin{itemize} + \item \hyperref[href_t:perspective_angle_ctl] + {\tt perspective\_angle\_ctl [DEGREE]} + \item \hyperref[href_t:perspective_xy_ratio_ctl] + {\tt perspective\_xy\_ratio\_ctl [ASPECT]} + \item \hyperref[href_t:perspective_near_ctl] + {\tt perspective\_near\_ctl [NEAR\_DISTANCE]} + \item \hyperref[href_t:perspective_far_ctl] + {\tt perspective\_far\_ctl [FAR\_DISTANCE]} +% +% \item \hyperref[href_t:horizontal_range_ctl] +% {\tt horizontal\_range\_ctl [LEFT] [RIGHT[} +% \item \hyperref[href_t:vertical_range_ctl] +% {\tt vertical\_range\_ctl [BOTTOM] [TOP]} + \end{itemize} +% + \item Block \verb|stereo_view_parameter_ctl| + \label{href_i:stereo_view_parameter_ctl} + \begin{itemize} + \item \hyperref[href_t:focal_distance_ctl] + {\tt focal\_distance\_ctl [DISTANCE]} + \item \hyperref[href_t:eye_separation_ctl] + {\tt eye\_separation\_ctl [SEPARATION]} + \item \hyperref[href_t:eye_separation_angle] + {\tt eye\_separation\_angle [DEGREE]} + \item \hyperref[href_t:eye_separation_step_by_angle] + {\tt eye\_separation\_step\_by\_angle [ON/OFF]} + \end{itemize} +% + \end{itemize} +% + \item Block \verb|plot_area_ctl| + \label{href_i:plot_area_ctl} + \begin{itemize} + \item \hyperref[href_t:chosen_ele_grp_ctl] + {\tt chosen\_ele\_grp\_ctl [AREA\_NAME]} + \item \hyperref[href_t:surface_enhanse_ctl] + {\tt surface\_enhanse\_ctl [SURFACE\_NAME] [TYPE] [OPACITY]} + \end{itemize} +% + \item File or Block \verb|pvr_color_ctl| + \label{href_i:pvr_color_ctl} + \begin{itemize} + \item Block \verb|colormap_ctl| + \item Block \verb|colorbar_ctl| + \end{itemize} +% + \item Block \verb|colormap_ctl| + \label{href_i:colormap_ctl} + \begin{itemize} + \item \hyperref[href_t:colormap_mode_ctl] + {\tt colormap\_mode\_ctl [MODE]} + \item \hyperref[href_t:background_color_ctl] + {\tt background\_color\_ctl [MODE]} +% +% \item \hyperref[href_t:LIC_color_field] +% {\tt LIC\_color\_field [Field\_Name]} +% \item \hyperref[href_t:LIC_color_componenet] +% {\tt LIC\_color\_componenet [Component\_Name]} +% \item \hyperref[href_t:LIC_transparent_field] +% {\tt LIC\_transparent\_field [Field\_Name]} +% \item \hyperref[href_t:LIC_transparent_componenet] +% {\tt LIC\_transparent\_componenet [Component\_Name]} +% + \item \hyperref[href_t:data_mapping_ctl] + {\tt data\_mapping\_ctl [TYPE]} + \item \hyperref[href_t:range_min_ctl] + {\tt range\_min\_ctl []MIN\_VALUE} + \item \hyperref[href_t:range_max_ctl] + {\tt range\_max\_ctl [MAX\_VALUE]} + \item \hyperref[href_t:color_table_ctl] + Array {\tt color\_table\_ctl [VALUE] [COLOR\_VAL]} + \item \hyperref[href_t:opacity_style_ctl] + {\tt opacity\_style\_ctl [TYPE]} + \item \hyperref[href_t:constant_opacity_ctl] + {\tt constant\_opacity\_ctl [OPACITY]} + \item \hyperref[href_t:linear_opacity_ctl] + Array {\tt linear\_opacity\_ctl [VALUE] [OPACITY]} + \end{itemize} +% + \item Block \verb|colorbar_ctl| + \label{href_i:colorbar_ctl} + \begin{itemize} + \item \hyperref[href_t:colorbar_switch_ctl] + {\tt colorbar\_switch\_ctl [ON/OFF]} + \item \hyperref[href_t:colorbar_scale_ctl] + {\tt colorbar\_scale\_ctl [ON/OFF]} + \item \hyperref[href_t:font_size_ctl] + {\tt font\_size\_ctl [SIZE]} + \item \hyperref[href_t:num_grid_ctl] + {\tt num\_grid\_ctl [\# of grid]} + \item \hyperref[href_t:zeromarker_switch] + {\tt zeromarker\_switch [ON/OFF]} + \item \hyperref[href_t:colorbar_range] + {\tt colorbar\_range [MIN] [MAX]} + \item \hyperref[href_t:axis_label_switch] + {\tt axis\_label\_switch [ON/OFF]} + \item \hyperref[href_t:time_label_switch] + {\tt time\_label\_switch [ON/OFF]} + \item \hyperref[href_t:map_grid_switch] + {\tt map\_grid\_switch [ON/OFF]} + \end{itemize} +% + \item File or Block \verb|lighting_ctl [File_Name]| + \label{href_i:lighting_ctl} + \begin{itemize} + \item \hyperref[href_t:ambient_coef_ctl] + {\tt ambient\_coef\_ctl [VALUE]} + \item \hyperref[href_t:diffuse_coef_ctl] + {\tt diffuse\_coef\_ctl [VALUE]} + \item \hyperref[href_t:specular_coef_ctl] + {\tt specular\_coef\_ctl [VALUE]} + \item \hyperref[href_t:position_of_lights] + Array {\tt position\_of\_lights [X] [Y] [Z]} + \item \hyperref[href_t:sph_position_of_lights] + Array {\tt sph\_position\_of\_lights [R] [THETA] [PHI]} + \end{itemize} +% + \item Array Block \verb|section_ctl| + \label{href_i:section_ctl} + \begin{itemize} + \item File or Block \hyperref[href_t:surface_define] + {\tt surface\_define [File\_Name]} + \item \hyperref[href_t:opacity_ctl] + {\tt opacity\_ctl [VALUE]} + \item \hyperref[href_t:zeroline_switch_ctl] + {\tt zeroline\_switch\_ctl [ON/OFF]} + \end{itemize} +% + \item Array Block \verb|isosurface_ctl| + \label{href_i:isosurface_ctl} + \begin{itemize} + \item \hyperref[href_t:isosurf_value] + {\tt isosurf\_value [VALUE]} + \item \hyperref[href_t:opacity_ctl] + {\tt opacity\_ctl [VALUE]} + \item \hyperref[href_t:surface_direction] + {\tt surface\_direction [DIRECTION]} + \end{itemize} +% + \item Block \verb|quilt_image_ctl| + \label{href_i:quilt_image_ctl} + \begin{itemize} + \item \hyperref[href_t:num_column_row_ctl] + {\tt num\_column\_row\_ctl [\# of column] [\# of row]} + \item \hyperref[href_t:num_row_column_ctl] + {\tt num\_row\_column\_ctl [\# of row] [\# of column]} + \item Array Block \verb|view_transform_ctl| + \label{href_i:quilt_view_transform_ctl} + \end{itemize} +% + \item Block \verb|snapshot_movie_ctl| + \label{href_i:snapshot_movie_ctl} + \begin{itemize} + \item \hyperref[href_t:movie_mode_ctl] + {\tt movie\_mode\_ctl [Mode]} + \item \hyperref[href_t:num_frames_ctl] + {\tt num\_frames\_ctl [\# of Flame]} + \item \hyperref[href_t:rotation_axis_ctl] + {\tt rotation\_axis\_ctl [X/Y/Z]} + \item \hyperref[href_t:angle_range] + {\tt angle\_range [START] [END]} + \item \hyperref[href_t:apature_range] + {\tt apature\_range [START] [END]} + \item \hyperref[href_t:LIC_kernel_peak_range] + {\tt LIC\_kernel\_peak\_range [START] [END]} +% + \item File or Block \verb|start_view_control [File_Name]| + \label{href_i:start_view_control} + \item File or Block \verb|end_view_control [File_Name]| + \label{href_i:end_view_control} + \item Array File or Block \verb|view_transform_ctl [File_Name] | + \label{href_i:movie_view_transform_ctl} + \end{itemize} +\end{itemize} + + +\subsection{Map projection data (Parallel volume rendering module)} +Map projection module generate visualization image using map projection through surfacing module. Currently, contour plots for scalar fields can only be generated, and Aitoff projection is only supported in this module. + +To output map projection data, increment of the map projection needs to be defined at \verb|i_step_map_projection_ctl| in \verb|time_step_ctl| block. Parameters foe each rendering are defined in array block \verb|map_rendering_ctl| in \verb|visual_control|. Same the other visualizatiom modules, each \verb|map_rendering_ctl| block can be stored in an external file, and the external file can be defined as \\ + \verb|file map_rendering_ctl [File_Name]|. +% +\paragraph{Control data} +The control parameters for map projection module is the following: +\\ +% +Block \verb|map_rendering_ctl| (Top level for map prodection) +\\ +\label{href_i:map_rendering_ctl} +\begin{itemize} + \item \hyperref[href_t:map_image_prefix] + {\tt map\_image\_prefix [File\_Prefix]} + \item \hyperref[href_t:map_image_format] + {\tt map\_image\_format [File\_Format]} +% + \item \hyperref[href_t:output_field] + {\tt output\_field [Field\_Name]} + \item \hyperref[href_t:output_component] + {\tt output\_component [Component\_Name]} + \item \hyperref[href_t:isoline_field] + {\tt isoline\_field [Field\_Name]} + \item \hyperref[href_t:isoline_component] + {\tt isoline\_component [Component\_Name]} +% + \item Block \verb|section_ctl| + \label{href_i:map_section_ctl} + \begin{itemize} + \item File or Block \verb|surface_define| + \label{href_i:map_surface_define} +% + \item \hyperref[href_t:zeroline_switch_ctl] + {\tt zeroline\_switch\_ctl [ON/OFF]} + \item \hyperref[href_t:isoline_color_mode] + {\tt isoline\_color\_mode [MODE]} + \item \hyperref[href_t:isoline_number_ctl] + {\tt isoline\_number\_ctl [\# of LINES]} + \item \hyperref[href_t:isoline_range_ctl] + {\tt isoline\_range\_ctl [MIN\_VALUE] [MAX\_VALUE]} + \item \hyperref[href_t:isoline_width_ctl] + {\tt isoline\_width\_ctl [WIDTH]} + \item \hyperref[href_t:grid_width_ctl] + {\tt grid\_width\_ctl [WIDTH]} + \item \hyperref[href_t:tangent_cylinder_switch_ctl] + {\tt tangent\_cylinder\_switch\_ctl [ON/OFF]} + \item \hyperref[href_t:inner_radius_ctl] + {\tt inner\_radius\_ctl [RADIUS]} + \item \hyperref[href_t:outer_radius_ctl] + {\tt outer\_radius\_ctl [RADIUS]} + \end{itemize} +% + \item File or Block \verb|map_projection_ctl| + \label{href_i:map_projection_ctl} + \begin{itemize} + \item Block \verb|image_size_ctl| + \label{href_i:image_size_ctl} + \begin{itemize} + \item \hyperref[href_t:x_pixel_ctl] + {\tt x\_pixel\_ctl [\# of PIXELS]} + \item \hyperref[href_t:y_pixel_ctl] + {\tt y\_pixel\_ctl [\# of PIXELS]} + \end{itemize} +% +% \item Array \hyperref[href_t:modelview_matrix_ctl] +% {\tt modelview\_matrix\_ctl [X/Y/X/W] [X/Y/Z/W] [VALUE]} +% \item Array \hyperref[href_t:look_at_point_ctl] +% {\tt look\_at\_point\_ctl [X/Y/Z] [VALUE]} +% \item Array \hyperref[href_t:eye_position_ctl] +% {\tt eye\_position\_ctl [X/Y/Z] [VALUE]} +% \item Array \hyperref[href_t:up_direction_ctl] +% {\tt up\_direction\_ctl [X/Y/Z] [VALUE]} +% \item Array \hyperref[href_t:view_rotation_vec_ctl] +% {\tt view\_rotation\_vec\_ctl [X/Y/Z] [VALUE]} +% \item \hyperref[href_t:view_rotation_deg_ctl] +% {\tt view\_rotation\_deg\_ctl [DEGREE]} +% \item \hyperref[href_t:scale_factor_ctl] +% {\tt scale\_factor\_ctl [SCALE]} +% \item Array \hyperref[href_t:scale_factor_vec_ctl] +% {\tt scale\_factor\_vec\_ctl [X/Y/Z] [SCALE]} +% \item Array \hyperref[href_t:eye_position_in_viewer_ctl] +% {\tt eye\_position\_in\_viewer\_ctl [X/Y/Z] [VALUE]} +% + \item \hyperref[href_t:projection_type_ctl] + {\tt projection\_type\_ctl [TYPE]} +% + \item Block \verb|projection_matrix_ctl| + \label{href_i:projection_matrix_ctl} + \begin{itemize} +% \item \hyperref[href_t:perspective_angle_ctl] +% {\tt perspective\_angle\_ctl [DEGREE]} +% \item \hyperref[href_t:perspective_xy_ratio_ctl] +% {\tt perspective\_xy\_ratio\_ctl [ASPECT]} +% \item \hyperref[href_t:perspective_near_ctl] +% {\tt perspective\_near\_ctl [NEAR\_DISTANCE]} +% \item \hyperref[href_t:perspective_far_ctl] +% {\tt perspective\_far\_ctl [FAR\_DISTANCE]} +% + \item \hyperref[href_t:horizontal_range_ctl] + {\tt horizontal\_range\_ctl [LEFT] [RIGHT[} + \item \hyperref[href_t:vertical_range_ctl] + {\tt vertical\_range\_ctl [BOTTOM] [TOP]} + \end{itemize} + \end{itemize} +% + \item File \verb|map_color_ctl| + \label{href_i:map_color_ctl} + \begin{itemize} + \item Block \verb|colormap_ctl| + \item Block \verb|colorbar_ctl| + \end{itemize} +% + \item Block \verb|colormap_ctl| + \label{href_i:colormap_ctl} + \begin{itemize} + \item \hyperref[href_t:colormap_mode_ctl] + {\tt colormap\_mode\_ctl [MODE]} + \item \hyperref[href_t:background_color_ctl] + {\tt background\_color\_ctl [MODE]} +% + \item \hyperref[href_t:data_mapping_ctl] + {\tt data\_mapping\_ctl [TYPE]} + \item \hyperref[href_t:range_min_ctl] + {\tt range\_min\_ctl []MIN\_VALUE} + \item \hyperref[href_t:range_max_ctl] + {\tt range\_max\_ctl [MAX\_VALUE]} + \item \hyperref[href_t:color_table_ctl] + Array {\tt color\_table\_ctl [VALUE] [COLOR\_VAL]} + \end{itemize} +% + \item Block \verb|colorbar_ctl| + \label{href_i:colorbar_ctl} + \begin{itemize} + \item \hyperref[href_t:colorbar_switch_ctl] + {\tt colorbar\_switch\_ctl [ON/OFF]} + \item \hyperref[href_t:colorbar_scale_ctl] + {\tt colorbar\_scale\_ctl [ON/OFF]} + \item \hyperref[href_t:font_size_ctl] + {\tt font\_size\_ctl [SIZE]} + \item \hyperref[href_t:num_grid_ctl] + {\tt num\_grid\_ctl [\# of grid]} + \item \hyperref[href_t:zeromarker_switch] + {\tt zeromarker\_switch [ON/OFF]} + \item \hyperref[href_t:colorbar_range] + {\tt colorbar\_range [MIN] [MAX]} + \item \hyperref[href_t:time_label_switch] + {\tt time\_label\_switch [ON/OFF]} + \item \hyperref[href_t:map_grid_switch] + {\tt map\_grid\_switch [ON/OFF]} + \end{itemize} +\end{itemize} + + + +\subsubsection{\tt volume\_rendering} +\label{href_t:volume_rendering} +% +\paragraph{\tt updated\_sign} +\label{href_t:updated_sign} +\verb|[SIGNAL]| \\ +The program will read again PVR parameter files and updates PVR parameters if the text \verb|[SIGNAL]| is changed. +% +\paragraph{\tt pvr\_file\_prefix} +\label{href_t:pvr_file_prefix} +\verb|[File_Prefix]| \\ +File prefix of the output image file \verb|[File_Prefix]| is defined by text. +% +\paragraph{\tt pvr\_output\_format} +\label{href_t:pvr_output_format} +\verb|[File_Format]| \\ +File format of the output image file \verb|[File_Format]| is defined by text. The following format can be defined. +\begin{description} +\item{\tt BMP: } Bitmap format +\item{\tt PNG: } PNG format (zlib or libpng is required to build) +\item{\tt QUILT: } BMP Quilt format for holograms +\item{\tt QUILT\_GZ: } Compressed BMP Quilt format for holograms +\end{description} +% +\paragraph{\tt monitoring\_mode} +\label{href_t:monitoring_mode} +\verb|[ON/OFF]| \\ +When the monitoring mode is turned on, the program outputs two same image files. One file is named with step number, and another file is named without step number. Consequently, the image file without step number is overwritten every PVR data output. During the simulation, we can check the latest image. +% +\paragraph{\tt stereo\_imaging} +\label{href_t:stereo_imaging} +\verb|[ON/OFF]| \\ +When stereo imaging switch is turned on, Stereo image is generated. In stereo imaing mode, the following \hyperref[href_t:anaglyph_switch]{\tt anaglyph\_switch} or \hyperref[href_t:quilt_3d_imaging]{\tt quilt\_3d\_imaging} needs to be turned on. +% +\paragraph{\tt anaglyph\_switch} +\label{href_t:anaglyph_switch} +\verb|[ON/OFF]| \\ +When anaglyph switch is turned on, stereo anaglyph image is generated. To look anaglyph, red and blue glass is required. +% +\paragraph{\tt quilt\_3d\_imaging} +\label{href_t:quilt_3d_imaging} +\verb|[ON/OFF]| \\ +When anaglyph switch is turned on, stereo image for looking glass is generated. This switch is also turned on if stereo image with side-by-side is generated. +% +\paragraph{\tt output\_field} +\label{href_t:output_field} +\verb|[Field_Name]| \\ +Field name \verb|[Field_Name]| for rendering is defined by text. +% +\paragraph{\tt output\_component} +\label{href_t:output_component} +\verb|[Component_Name]| \\ +Component name \verb|[Component_Name]| for rendering is defined by text. +% +\subsubsection{\tt view\_transform\_ctl} +\label{href_t:view_transform_ctl} +Parameters for view point and direction are defined in this block. This block can be saved into an external file. (Go to \hyperref[href_i:view_transform_ctl] {\tt view\_transform\_ctl}) + +\subsubsection*{\tt image\_size\_ctl} +\label{href_t:image_size_ctl} +Image size (number of pixels) are defined in this block. (Go to \hyperref[href_i:image_size_ctl] {\tt image\_size\_ctl}) +% +\paragraph{\tt x\_pixel\_ctl} +\label{href_t:x_pixel_ctl} +\verb|[\# of PIXELS]| \\ +Number of pixels in the horizontal direction \verb|[\# of PIXELS]| is defined by integer. +% +\paragraph{\tt y\_pixel\_ctl} +\label{href_t:y_pixel_ctl} +\verb|[\# of PIXELS]| \\ +Number of pixels in the vertical direction \verb|[\# of PIXELS]| is defined by integer. +% +\paragraph{\tt modelview\_matrix\_ctl} +\label{href_t:modelview_matrix_ctl} +\verb|[X/Y/Z/W] [X/Y/Z/W] [VALUE]| \\ +Modelview matrix $A_{ij}$ is defined by array. Directions of row and columns are defined in the first and second texts, respectively, and the value of the each matrix component is defined by the third real value. +% +\paragraph{\tt look\_at\_point\_ctl} +\label{href_t:look_at_point_ctl} +\verb|[X/Y/Z] [VALUE]| \\ +Position to look at is defined by array. Directions are defined in the first text, and the value is defined by the second real value. +% +\paragraph{\tt eye\_position\_ctl} +\label{href_t:eye_position_ctl} +\verb|[X/Y/Z] [VALUE]| \\ +Position of eye (or camera) is defined by array. Directions are defined in the first text, and the value is defined by the second real value. +% +\paragraph{\tt up\_direction\_ctl} +\label{href_t:up_direction_ctl} +\verb|[X/Y/Z] [VALUE]| \\ +Up direction (positive in vertical) in image is defined by array. Directions are defined in the first text, and the value is defined by the second real value. +% +\paragraph{\tt view\_rotation\_vec\_ctl} +\label{href_t:view_rotation_vec_ctl} +\verb|[X/Y/Z] [VALUE]| \\ +Axis of rotation is defined in this array. Direction is defined in the first text, and the value is defined by the second real value. +% +\paragraph{\tt view\_rotation\_deg\_ctl} +\label{href_t:view_rotation_deg_ctl} +\verb|[DEGREE]| \\ +Angle of rotation using degree is defined by real value. +% +\paragraph{\tt scale\_factor\_vec\_ctl} +\label{href_t:scale_factor_ctl} +\verb|[SCALE]| \\ +Scale of object is defined by real value. +% +\paragraph{\tt scale\_factor\_vec\_ctl} +\label{href_t:scale_factor_vec_ctl} +\verb|[X/Y/Z] [SCALE]| \\ +Scale for each direction is defined in this array. Direction is defined in the first text, and the scale for each direction is defined by the second real value. +% +\paragraph{\tt eye\_position\_in\_viewer\_ctl} +\label{href_t:eye_position_in_viewer_ctl} +\verb|[X/Y/Z] [VALUE]| \\ +Eye (camera) position in the screen coordinate is defined by array. Direction is defined in the first text, and the scale for each direction is defined by the second real value. +% +% +\subsubsection{\tt projection\_matrix\_ctl} +\label{href_t:projection_matrix_ctl} +Parameters for projection onto screen are defined in this block (Go to \hyperref[href_i:projection_matrix_ctl] {\tt projection\_matrix\_ctl}) + +% +\subsubsection{\tt map\_rendering\_ctl} +\label{href_t:map_rendering_ctl} +% + + diff --git a/src/C_libraries/BASE/Makefile.depends b/src/C_libraries/BASE/Makefile.depends index d38cfe1a..b53908f7 100644 --- a/src/C_libraries/BASE/Makefile.depends +++ b/src/C_libraries/BASE/Makefile.depends @@ -18,3 +18,14 @@ numbers_to_bin_c.o: \ $(C_SRCDIR)/BASE/numbers_to_bin_c.c \ $(C_SRCDIR)/BASE/numbers_to_bin_c.h $(CC) -c $(OPTFLAGS) $(C_INCLUDE) $< +read_image_2_png.o: \ + $(C_SRCDIR)/BASE/read_image_2_png.c \ + $(C_SRCDIR)/BASE/read_image_2_png.h \ + $(C_SRCDIR)/BASE/write_image_2_png.h \ + $(C_SRCDIR)/BASE/calypso_param_c.h + $(CC) -c $(OPTFLAGS) $(C_INCLUDE) $< +write_image_2_png.o: \ + $(C_SRCDIR)/BASE/write_image_2_png.c \ + $(C_SRCDIR)/BASE/write_image_2_png.h \ + $(C_SRCDIR)/BASE/calypso_param_c.h + $(CC) -c $(OPTFLAGS) $(C_INCLUDE) $< diff --git a/src/C_libraries/BASE/read_image_2_png.c b/src/C_libraries/BASE/read_image_2_png.c new file mode 100644 index 00000000..458a7f72 --- /dev/null +++ b/src/C_libraries/BASE/read_image_2_png.c @@ -0,0 +1,328 @@ + +/* read_image_2_png.c */ + +#include "read_image_2_png.h" + +#define PNG_BYTES_TO_CHECK (4) +unsigned char **bimage; + +static void check_if_png(char *file_name, FILE **fp) + { + char sig[PNG_BYTES_TO_CHECK]; + + if ((*fp = fopen(file_name, "rb")) == NULL) exit(EXIT_FAILURE); + if (fread(sig, 1, PNG_BYTES_TO_CHECK, *fp) != PNG_BYTES_TO_CHECK) { + fclose(*fp); + exit(EXIT_FAILURE); + } + if (png_sig_cmp((png_bytep) sig, IZERO, PNG_BYTES_TO_CHECK)) { + fclose(*fp); + exit(EXIT_FAILURE); + } +} + +static void read_png_info(FILE *fp, png_structp *png_ptr, png_infop *info_ptr) +{ + *png_ptr = png_create_read_struct(PNG_LIBPNG_VER_STRING, NULL, NULL, NULL); + if (*png_ptr == NULL) { + fclose(fp); + exit(EXIT_FAILURE); + } + + *info_ptr = png_create_info_struct(*png_ptr); + if (*info_ptr == NULL) { + png_destroy_read_struct(png_ptr, (png_infopp)NULL, (png_infopp)NULL); + fclose(fp); + exit(EXIT_FAILURE); + } + if (setjmp(png_jmpbuf(*png_ptr))) { + png_destroy_read_struct(png_ptr, info_ptr, (png_infopp)NULL); + fclose(fp); + exit(EXIT_FAILURE); + } + png_init_io(*png_ptr, fp); + png_set_sig_bytes(*png_ptr, PNG_BYTES_TO_CHECK); + png_read_info(*png_ptr, *info_ptr); +} + +static void read_png_raw_image(FILE *fp, png_structp png_ptr, png_infop info_ptr, + png_bytepp *image, png_uint_32 *width, png_uint_32 *height, int *iflag_rgba) +{ + png_uint_32 i, j; + + *width = png_get_image_width(png_ptr, info_ptr); + *height = png_get_image_height(png_ptr, info_ptr); + + if (png_get_color_type(png_ptr, info_ptr) == PNG_COLOR_TYPE_RGBA){ + *iflag_rgba = RGBA_COLOR; + } + else if (png_get_color_type(png_ptr, info_ptr) == PNG_COLOR_TYPE_RGB){ + *iflag_rgba = RGB_COLOR; + } + else if (png_get_color_type(png_ptr, info_ptr) == PNG_COLOR_TYPE_GRAY_ALPHA){ + *iflag_rgba = BW_ALPHA; + } + else if (png_get_color_type(png_ptr, info_ptr) == PNG_COLOR_TYPE_GRAY){ + *iflag_rgba = B_AND_W; + } + + else exit(EXIT_FAILURE); + + + if ((*image = (png_bytepp)malloc(*height * sizeof(png_bytep))) == NULL) { + fclose(fp); + exit(EXIT_FAILURE); + } + for (i = 0; i < *height; i++) { + (*image)[i] = (png_bytep)malloc(png_get_rowbytes(png_ptr, info_ptr)); + if ((*image)[i] == NULL) { + for (j = 0; j < i; j++) free((*image)[j]); + free(*image); + fclose(fp); + exit(EXIT_FAILURE); + } + } + png_read_image(png_ptr, *image); +} + +static void read_png_image_w_gamma(FILE *fp, png_structp png_ptr, png_infop info_ptr, + png_bytepp *image, png_uint_32 *width, png_uint_32 *height, + int *iflag_rgba, double display_gamma) +{ + double file_gamma; + + /* display_gamma = 2.2;*/ + if (png_get_gAMA(png_ptr, info_ptr, &file_gamma)){ + png_set_gamma(png_ptr, display_gamma, file_gamma); + } else { + png_set_gamma(png_ptr, display_gamma, 0.50); + }; + png_read_update_info(png_ptr, info_ptr); + + read_png_raw_image(fp, png_ptr, info_ptr, image, width, height, iflag_rgba); +} + + +void read_png_file_c(const char *fhead, int *num_x, int *num_y, int *iflag_rgba) +{ + char fname[LENGTHBUF]; + FILE *fp; + png_uint_32 i; + png_uint_32 width; + png_uint_32 height; + double file_gamma; + png_structp png_ptr; + png_infop info_ptr; + double display_gamma = 1.0; + + + sprintf(fname, "%s.png",fhead); + check_if_png(fname, &fp); + read_png_info(fp, &png_ptr, &info_ptr); + read_png_image_w_gamma(fp, png_ptr, info_ptr, &bimage, &width, &height, + iflag_rgba, display_gamma); + fclose(fp); +/* + { +// Display gAMA Chunk + if (png_get_gAMA(png_ptr, info_ptr, &file_gamma)) + printf("gamma = %lf\n", file_gamma); + } +*/ + { + /* Display tEXT Chunk */ + png_textp text_ptr; + int num_text; + if (png_get_text(png_ptr, info_ptr, &text_ptr, &num_text)) + for (i = 0; i < num_text; i++) + printf("%s = %s\n", text_ptr[i].key, text_ptr[i].text); + } + + png_destroy_read_struct(&png_ptr, &info_ptr, (png_infopp)NULL); + + *num_x = (int) width; + *num_y = (int) height; + return; +} + +void copy_rgb_from_png_c(const int num_x, const int num_y, + const int iflag_rgba, unsigned char *cimage) +{ + int k, j, l; + + if(iflag_rgba == RGBA_COLOR){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[3*k ] = bimage[j][4*l ]; + cimage[3*k+1] = bimage[j][4*l+1]; + cimage[3*k+2] = bimage[j][4*l+2]; + } + }; + } else if(iflag_rgba == RGB_COLOR){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[3*k ] = bimage[j][3*l ]; + cimage[3*k+1] = bimage[j][3*l+1]; + cimage[3*k+2] = bimage[j][3*l+2]; + } + }; + } else if(iflag_rgba == BW_ALPHA){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[3*k ] = bimage[j][2*l]; + cimage[3*k+1] = bimage[j][2*l]; + cimage[3*k+2] = bimage[j][2*l]; + } + }; + } else if(iflag_rgba == B_AND_W){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[3*k ] = bimage[j][l]; + cimage[3*k+1] = bimage[j][l]; + cimage[3*k+2] = bimage[j][l]; + } + }; + }; + + free(bimage); +}; + +void copy_rgba_from_png_c(const int num_x, const int num_y, + const int iflag_rgba, unsigned char *cimage) +{ + int i, k, j, l; + + if(iflag_rgba == RGBA_COLOR){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[4*k ] = bimage[j][4*l ]; + cimage[4*k+1] = bimage[j][4*l+1]; + cimage[4*k+2] = bimage[j][4*l+2]; + cimage[4*k+3] = bimage[j][4*l+3]; + } + }; + } else if(iflag_rgba == RGB_COLOR){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[4*k ] = bimage[j][3*l ]; + cimage[4*k+1] = bimage[j][3*l+1]; + cimage[4*k+2] = bimage[j][3*l+2]; + cimage[4*k+3] = (unsigned char) 255; + } + }; + } else if(iflag_rgba == BW_ALPHA){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[4*k ] = bimage[j][2*l ]; + cimage[4*k+1] = bimage[j][2*l ]; + cimage[4*k+2] = bimage[j][2*l ]; + cimage[4*k+3] = bimage[j][2*l+1]; + } + }; + } else if(iflag_rgba == B_AND_W){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[4*k ] = bimage[j][l]; + cimage[4*k+1] = bimage[j][l]; + cimage[4*k+2] = bimage[j][l]; + cimage[4*k+3] = (unsigned char) 255; + } + }; + }; + + for (i = 0; i < num_y; i++) free(bimage[i]); + free(bimage); +}; + +void copy_grayscale_from_png_c(const int num_x, const int num_y, + const int iflag_rgba, unsigned char *cimage) +{ + int k, j, l, mixed; + + if(iflag_rgba == RGBA_COLOR){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + mixed = ((int) bimage[j][4*l ] + (int) bimage[j][4*l+1] + (int) bimage[j][4*l+2]) / 3; + cimage[k ] = (unsigned char) mixed; + } + }; + } else if(iflag_rgba == RGB_COLOR){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + mixed = ((int) bimage[j][3*l ] + (int) bimage[j][3*l+1] + (int) bimage[j][3*l+2]) / 3; + cimage[k ] = (unsigned char) mixed; + } + }; + } else if(iflag_rgba == BW_ALPHA){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[k ] = bimage[j][2*l ]; + } + }; + } else if(iflag_rgba == B_AND_W){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[k ] = bimage[j][l]; + } + }; + }; + + free(bimage); +}; + +void copy_grayalpha_from_png_c(const int num_x, const int num_y, + const int iflag_rgba, unsigned char *cimage) +{ + int i, k, j, l, mixed; + + if(iflag_rgba == RGBA_COLOR){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + mixed = ((int) bimage[j][4*l ] + (int) bimage[j][4*l+1] + (int) bimage[j][4*l+2]) / 3; + cimage[2*k ] = (unsigned char) mixed; + cimage[2*k+1] = bimage[j][2*l+1]; + } + }; + } else if(iflag_rgba == RGB_COLOR){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + mixed = ((int) bimage[j][3*l ] + (int) bimage[j][3*l+1] + (int) bimage[j][3*l+2]) / 3; + cimage[2*k ] = (unsigned char) mixed; + cimage[2*k+3] = (unsigned char) 255; + } + }; + } else if(iflag_rgba == BW_ALPHA){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[2*k ] = bimage[j][2*l ]; + cimage[2*k+1] = bimage[j][2*l+1]; + } + }; + } else if(iflag_rgba == B_AND_W){ + for (l = 0; l < num_x; l++) { + for (j = 0; j < num_y; j++) { + k = (num_y-j-1) * num_x + l; + cimage[2*k ] = bimage[j][l]; + cimage[2*k+3] = (unsigned char) 255; + } + }; + }; + + for (i = 0; i < num_y; i++) free(bimage[i]); + free(bimage); +}; diff --git a/src/C_libraries/BASE/read_image_2_png.h b/src/C_libraries/BASE/read_image_2_png.h new file mode 100644 index 00000000..496df623 --- /dev/null +++ b/src/C_libraries/BASE/read_image_2_png.h @@ -0,0 +1,26 @@ + +/* read_image_2_png.h */ + +#ifndef READ_IMAGE_2_PNG_ +#define READ_IMAGE_2_PNG_ + +#include +#include + +#include "write_image_2_png.h" +#include "calypso_param_c.h" + +/* prototypes */ + +void read_png_file_c(const char *fhead, int *num_x, int *num_y, int *iflag_rgba); + +void copy_rgb_from_png_c(const int num_x, const int num_y, + const int iflag_rgba, unsigned char *cimage); +void copy_rgba_from_png_c(const int num_x, const int num_y, + const int iflag_rgba, unsigned char *cimage); +void copy_grayscale_from_png_c(const int num_x, const int num_y, + const int iflag_rgba, unsigned char *cimage); +void copy_grayalpha_from_png_c(const int num_x, const int num_y, + const int iflag_rgba, unsigned char *cimage); + +#endif diff --git a/src/C_libraries/BASE/write_image_2_png.c b/src/C_libraries/BASE/write_image_2_png.c new file mode 100644 index 00000000..a6311367 --- /dev/null +++ b/src/C_libraries/BASE/write_image_2_png.c @@ -0,0 +1,239 @@ + +/* write_image_2_png.c */ + +#include "write_image_2_png.h" + + +unsigned char ** alloc_img_buffer_2_png_rgba(int num_x, int num_y){ + static unsigned char **image; + int j; + /* allocate memory image[y_pixel#][4*x_pixel#]*/ + if((image = (png_bytepp)malloc(num_y * sizeof(png_bytep))) == NULL){ + printf("malloc error for Vertical PNG image buffer \n"); + exit(0); + }; + for (j = 0; j < num_y; j++){ + if((image[j] = (png_bytep)malloc(4*num_x * sizeof(png_byte))) == NULL){ + printf("malloc error for Horizontal PNG image buffer %d \n", j); + exit(0); + }; + }; + return image; +}; + +unsigned char ** alloc_img_buffer_2_png_rgb(int num_x, int num_y){ + static unsigned char **image; + int j; + /* allocate memory image[y_pixel#][3*x_pixel#]*/ + if((image = (png_bytepp)malloc(num_y * sizeof(png_bytep))) == NULL){ + printf("malloc error for Vertical PNG image buffer \n"); + exit(0); + }; + for (j = 0; j < num_y; j++){ + if((image[j] = (png_bytep)malloc(3*num_x * sizeof(png_byte))) == NULL){ + printf("malloc error for Horizontal PNG image buffer %d \n", j); + exit(0); + }; + }; + return image; +}; + +void dealloc_img_buffer_2_png(int num_y, unsigned char **image){ + int j; + for (j=0; jheight); + */ +} + +void write_png_rgba(const char *file_prefix, png_uint_32 num_x, png_uint_32 num_y, + png_bytepp image){ + FILE *fp; + char file_name[LENGTHBUF]; + png_structp png_ptr; + png_infop info_ptr; + + sprintf(file_name, "%s.png", file_prefix); + printf("PNG file ouput: %s",file_name); + + void write_row_callback(png_structp png_ptr, png_uint_32 row, int pass); + + if ((fp = fopen(file_name, "wb")) == NULL) return; + png_ptr = png_create_write_struct(PNG_LIBPNG_VER_STRING, NULL, NULL, NULL); + if (png_ptr == NULL) { + fclose(fp); + return; + } + info_ptr = png_create_info_struct(png_ptr); + if (info_ptr == NULL) { + png_destroy_write_struct(&png_ptr, (png_infopp)NULL); + fclose(fp); + return; + } + if (setjmp(png_jmpbuf(png_ptr))) { + png_destroy_write_struct(&png_ptr, &info_ptr); + fclose(fp); + return; + } + /* send file info */ + png_init_io(png_ptr, fp); + png_set_write_status_fn(png_ptr, write_row_callback); + png_set_filter(png_ptr, 0, PNG_ALL_FILTERS); + png_set_compression_level(png_ptr, Z_BEST_COMPRESSION); + /* set IHDR chunk */ + png_set_IHDR(png_ptr, info_ptr, num_x, num_y, 8, PNG_COLOR_TYPE_RGB_ALPHA, + PNG_INTERLACE_NONE, PNG_COMPRESSION_TYPE_DEFAULT, PNG_FILTER_TYPE_DEFAULT); + png_set_gAMA(png_ptr, info_ptr, 1.0); + + { + time_t gmt; + png_time mod_time; + png_text text_ptr[1]; + + time(&gmt); + png_convert_from_time_t(&mod_time, gmt); + png_set_tIME(png_ptr, info_ptr, &mod_time); + + text_ptr[0].key = "Software"; + text_ptr[0].text = "Kemo's viewer"; + text_ptr[0].compression = PNG_TEXT_COMPRESSION_NONE; + png_set_text(png_ptr, info_ptr, text_ptr, 1); + } + + /* Write header */ + png_write_info(png_ptr, info_ptr); + /* Write image data*/ + png_write_image(png_ptr, image); + png_write_end(png_ptr, info_ptr); + /* Clear memory */ + png_destroy_write_struct(&png_ptr, &info_ptr); + fclose(fp); + + printf(" ...end \n"); + return; +} + +void write_png_rgb(const char *file_prefix, png_uint_32 num_x, png_uint_32 num_y, + png_bytepp image) +{ + FILE *fp; + char file_name[LENGTHBUF]; + png_structp png_ptr; + png_infop info_ptr; + + sprintf(file_name, "%s.png", file_prefix); + printf("PNG file ouput: %s",file_name); + + void write_row_callback(png_structp png_ptr, png_uint_32 row, int pass); + + if ((fp = fopen(file_name, "wb")) == NULL) return; + png_ptr = png_create_write_struct(PNG_LIBPNG_VER_STRING, NULL, NULL, NULL); + if (png_ptr == NULL) { + fclose(fp); + return; + } + info_ptr = png_create_info_struct(png_ptr); + if (info_ptr == NULL) { + png_destroy_write_struct(&png_ptr, (png_infopp)NULL); + fclose(fp); + return; + } + if (setjmp(png_jmpbuf(png_ptr))) { + png_destroy_write_struct(&png_ptr, &info_ptr); + fclose(fp); + return; + } + /* send file info */ + png_init_io(png_ptr, fp); + png_set_write_status_fn(png_ptr, write_row_callback); + png_set_filter(png_ptr, 0, PNG_ALL_FILTERS); + png_set_compression_level(png_ptr, Z_BEST_COMPRESSION); + /* set IHDR chunk */ + png_set_IHDR(png_ptr, info_ptr, num_x, num_y, 8, PNG_COLOR_TYPE_RGB, + PNG_INTERLACE_NONE, PNG_COMPRESSION_TYPE_DEFAULT, PNG_FILTER_TYPE_DEFAULT); + png_set_gamma(png_ptr, 2.2, 0.45455); + + { + time_t gmt; + png_time mod_time; + png_text text_ptr[1]; + + time(&gmt); + png_convert_from_time_t(&mod_time, gmt); + png_set_tIME(png_ptr, info_ptr, &mod_time); + + text_ptr[0].key = "Software"; + text_ptr[0].text = "Kemo's viewer"; + text_ptr[0].compression = PNG_TEXT_COMPRESSION_NONE; + png_set_text(png_ptr, info_ptr, text_ptr, 1); + } + + /* Write header */ + png_write_info(png_ptr, info_ptr); + /* Write image data*/ + png_write_image(png_ptr, image); + png_write_end(png_ptr, info_ptr); + /* Clear memory */ + png_destroy_write_struct(&png_ptr, &info_ptr); + fclose(fp); + + printf(" ...end \n"); + return; +} + +void write_png_rgba_c(const char *file_prefix, const int *num_x, const int *num_y, + const char *cimage){ + char fname[LENGTHBUF]; + unsigned char **image; + png_uint_32 nx = (png_uint_32) *num_x; + png_uint_32 ny = (png_uint_32) *num_y; + int i, j, k; + + image = (png_bytepp)malloc(ny * sizeof(png_bytep)); + for (j = 0; j < ny; j++) image[j] = (png_bytep)malloc(4*nx * sizeof(png_byte)); + + for (i = 0; i < nx; i++) { + for (j = 0; j < ny; j++) { + k = (ny-j-1)*nx + i; + image[j][4*i ] = (unsigned char) cimage[4*k]; + image[j][4*i+1] = (unsigned char) cimage[4*k+1]; + image[j][4*i+2] = (unsigned char) cimage[4*k+2]; + image[j][4*i+3] = (unsigned char) cimage[4*k+3]; + } + } + + write_png_rgba(file_prefix, nx, ny, image); + dealloc_img_buffer_2_png(ny, image); + return; +} + + +void write_png_rgb_c(const char *file_prefix, const int *num_x, const int *num_y, + const unsigned char *cimage){ + char fname[LENGTHBUF]; + unsigned char **image; + png_uint_32 nx = (png_uint_32) *num_x; + png_uint_32 ny = (png_uint_32) *num_y; + int i, j, k; + + image = (png_bytepp)malloc(ny * sizeof(png_bytep)); + for (j = 0; j < ny; j++) image[j] = (png_bytep)malloc(3*nx * sizeof(png_byte)); + + for (i = 0; i < nx; i++) { + for (j = 0; j < ny; j++) { + k = (ny-j-1)*nx + i; + image[j][3*i ] = cimage[3*k]; + image[j][3*i+1] = cimage[3*k+1]; + image[j][3*i+2] = cimage[3*k+2]; + } + } + + write_png_rgb(file_prefix, nx, ny, image); + dealloc_img_buffer_2_png(ny, image); + return; +} diff --git a/src/C_libraries/BASE/write_image_2_png.h b/src/C_libraries/BASE/write_image_2_png.h new file mode 100644 index 00000000..3e94c844 --- /dev/null +++ b/src/C_libraries/BASE/write_image_2_png.h @@ -0,0 +1,39 @@ + +/* write_image_2_png.h */ + +#ifndef WRITE_IMAGE_2_PNG_ +#define WRITE_IMAGE_2_PNG_ + +#include +#include + +#ifndef DEPENDENCY_CHECK + #include + #include +#endif + +#include "calypso_param_c.h" + +/* prototypes */ +unsigned char ** alloc_img_buffer_2_png_rgba(int num_x, int num_y); +unsigned char ** alloc_img_buffer_2_png_rgb(int num_x, int num_y); +void dealloc_img_buffer_2_png(int num_y, unsigned char **image); + + +void write_png_rgba(const char *file_prefix, png_uint_32 num_x, png_uint_32 num_y, + png_bytepp image); +void write_png_rgb(const char *file_prefix, png_uint_32 num_x, png_uint_32 num_y, + png_bytepp image); + +void write_png_rgba_c(const char *file_prefix, const int *num_x, const int *num_y, + const char *cimage); +void write_png_rgb_c(const char *file_prefix, const int *num_x, const int *num_y, + const unsigned char *cimage); + +/* file_name: output file_name + num_x, num_y: size of image (pixels) + image: image array + (unsigned char, 4*num_x*num_y for RGBA, 3*num_x*num_y for RGB) */ + +#endif + diff --git a/src/Fortran_libraries/MHD_src/IO/Makefile.depends b/src/Fortran_libraries/MHD_src/IO/Makefile.depends index 02268ab6..c35d41e6 100644 --- a/src/Fortran_libraries/MHD_src/IO/Makefile.depends +++ b/src/Fortran_libraries/MHD_src/IO/Makefile.depends @@ -14,6 +14,8 @@ bcast_ctl_data_mhd_time_rst.o: $(MHD_IO_DIR)/bcast_ctl_data_mhd_time_rst.f90 m_p $(F90) -c $(F90OPTFLAGS) $< bcast_dynamo_sect_control.o: $(MHD_IO_DIR)/bcast_dynamo_sect_control.f90 m_precision.o calypso_mpi.o m_machine_parameter.o t_control_data_dynamo_sects.o bcast_control_arrays.o bcast_section_control_data.o bcast_control_sph_MHD.o calypso_mpi_int.o calypso_mpi_char.o transfer_to_long_integers.o $(F90) -c $(F90OPTFLAGS) $< +bcast_dynamo_viz_control.o: $(MHD_IO_DIR)/bcast_dynamo_viz_control.f90 m_precision.o calypso_mpi.o m_machine_parameter.o t_control_data_dynamo_vizs.o calypso_mpi_int.o calypso_mpi_char.o transfer_to_long_integers.o bcast_section_control_data.o bcast_maps_control_data.o bcast_control_sph_MHD.o + $(F90) -c $(F90OPTFLAGS) $< bcast_monitor_data_ctl.o: $(MHD_IO_DIR)/bcast_monitor_data_ctl.f90 m_precision.o m_machine_parameter.o t_ctl_data_node_monitor.o calypso_mpi.o transfer_to_long_integers.o calypso_mpi_char.o calypso_mpi_int.o bcast_control_arrays.o $(F90) -c $(F90OPTFLAGS) $< check_read_bc_file.o: $(MHD_IO_DIR)/check_read_bc_file.f90 m_precision.o t_bc_data_list.o t_control_parameter.o calypso_mpi.o t_physical_property.o @@ -68,6 +70,8 @@ t_bc_data_list.o: $(MHD_IO_DIR)/t_bc_data_list.f90 m_precision.o t_control_param $(F90) -c $(F90OPTFLAGS) $< t_control_data_dynamo_sects.o: $(MHD_IO_DIR)/t_control_data_dynamo_sects.f90 m_precision.o m_machine_parameter.o t_control_data_sections.o t_ctl_data_crust_filter.o t_read_control_elements.o skip_comment_f.o write_control_elements.o ctl_data_section_IO.o ctl_file_sections_IO.o $(F90) -c $(F90OPTFLAGS) $< +t_control_data_dynamo_vizs.o: $(MHD_IO_DIR)/t_control_data_dynamo_vizs.f90 m_precision.o m_machine_parameter.o t_control_data_sections.o t_ctl_data_crust_filter.o t_control_data_maps.o t_read_control_elements.o skip_comment_f.o ctl_file_map_renderings_IO.o write_control_elements.o ctl_data_section_IO.o ctl_file_sections_IO.o + $(F90) -c $(F90OPTFLAGS) $< t_ctl_data_MHD.o: $(MHD_IO_DIR)/t_ctl_data_MHD.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_4_platforms.o t_ctl_data_MHD_model.o t_ctl_data_SPH_MHD_control.o t_ctl_data_4_sph_monitor.o t_ctl_data_node_monitor.o t_ctl_data_gen_sph_shell.o delete_data_files.o ctl_data_platforms_IO.o ctl_data_sph_monitor_IO.o ctl_data_MHD_model_IO.o ctl_file_gen_sph_shell_IO.o write_control_elements.o $(F90) -c $(F90OPTFLAGS) $< t_ctl_data_MHD_model.o: $(MHD_IO_DIR)/t_ctl_data_MHD_model.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_4_fields.o t_ctl_data_mhd_evolution.o t_ctl_data_mhd_evo_area.o t_ctl_data_node_boundary.o t_ctl_data_surf_boundary.o t_ctl_data_mhd_normalize.o t_ctl_data_mhd_forces.o t_ctl_data_coriolis_force.o t_ctl_data_gravity.o t_ctl_data_mhd_magne.o t_ctl_data_magnetic_scale.o t_ctl_data_temp_model.o t_ctl_data_dimless_numbers.o t_ctl_data_valuable_diffuse.o t_ctl_data_valuable_density.o skip_comment_f.o @@ -106,6 +110,8 @@ t_ctl_data_node_monitor.o: $(MHD_IO_DIR)/t_ctl_data_node_monitor.f90 m_precision $(F90) -c $(F90OPTFLAGS) $< t_ctl_data_sph_MHD_w_psf.o: $(MHD_IO_DIR)/t_ctl_data_sph_MHD_w_psf.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_MHD.o t_ctl_data_MHD_model.o t_ctl_data_SPH_MHD_control.o t_ctl_data_4_sph_monitor.o t_ctl_data_node_monitor.o t_ctl_data_gen_sph_shell.o t_control_data_surfacings.o t_control_data_dynamo_sects.o delete_data_files.o ctl_data_platforms_IO.o ctl_data_sph_monitor_IO.o ctl_data_MHD_model_IO.o control_data_surfacing_IO.o ctl_file_gen_sph_shell_IO.o write_control_elements.o $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_sph_MHD_w_vizs.o: $(MHD_IO_DIR)/t_ctl_data_sph_MHD_w_vizs.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_MHD.o t_ctl_data_MHD_model.o t_ctl_data_SPH_MHD_control.o t_ctl_data_4_sph_monitor.o t_ctl_data_node_monitor.o t_ctl_data_gen_sph_shell.o t_control_data_viz4.o t_control_data_dynamo_vizs.o viz4_step_ctls_to_time_ctl.o delete_data_files.o ctl_data_platforms_IO.o ctl_data_sph_monitor_IO.o ctl_data_MHD_model_IO.o ctl_data_four_vizs_IO.o ctl_file_gen_sph_shell_IO.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< t_ctl_data_stratified_model.o: $(MHD_IO_DIR)/t_ctl_data_stratified_model.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_character.o t_control_array_real.o skip_comment_f.o write_control_elements.o $(F90) -c $(F90OPTFLAGS) $< t_ctl_data_surf_boundary.o: $(MHD_IO_DIR)/t_ctl_data_surf_boundary.f90 m_precision.o m_machine_parameter.o t_control_array_chara2real.o diff --git a/src/Fortran_libraries/MHD_src/IO/bcast_dynamo_viz_control.f90 b/src/Fortran_libraries/MHD_src/IO/bcast_dynamo_viz_control.f90 new file mode 100644 index 00000000..d8e477ce --- /dev/null +++ b/src/Fortran_libraries/MHD_src/IO/bcast_dynamo_viz_control.f90 @@ -0,0 +1,62 @@ +!>@file bcast_dynamo_viz_control.f90 +!!@brief module bcast_dynamo_viz_control +!! +!!@author H. Matsui +!>@brief Control read routine +!!@date programmed by H.Matsui and H.Okuda +!!@n on July 2000 (ver 1.1) +!!@n Modified by H. Matsui on July, 2006 +!!@n Modified by H. Matsui on May, 2007 +!!@n Modified by H. Matsui on Oct., 2007 +!!@n Modified by H. Matsui on Oct., 2012 +!!@n Modified by H. Matsui on Apr., 2023 +!! +!!@verbatim +!! subroutine s_bcast_dynamo_viz_control(zm_ctls) +!! type(sph_dynamo_viz_controls), intent(in) :: zm_ctls +!!@endverbatim +! + module bcast_dynamo_viz_control +! + use m_precision +! + use calypso_mpi + use m_machine_parameter +! + implicit none +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine s_bcast_dynamo_viz_control(zm_ctls) +! + use t_control_data_dynamo_vizs +! + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers + use bcast_section_control_data + use bcast_maps_control_data + use bcast_control_sph_MHD +! + type(sph_dynamo_viz_controls), intent(inout) :: zm_ctls +! +! + call bcast_crustal_filtering_ctl(zm_ctls%crust_filter_ctl) + call bcast_files_4_psf_ctl(zm_ctls%zm_psf_ctls) + call bcast_files_4_psf_ctl(zm_ctls%zRMS_psf_ctls) + call bcast_files_4_map_ctl(zm_ctls%zm_map_ctls) + call bcast_files_4_map_ctl(zm_ctls%zRMS_map_ctls) +! + call calypso_mpi_bcast_character & + & (zm_ctls%block_name, cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(zm_ctls%i_viz_ctl, 0) +! + end subroutine s_bcast_dynamo_viz_control +! +! -------------------------------------------------------------------- +! + end module bcast_dynamo_viz_control diff --git a/src/Fortran_libraries/MHD_src/IO/t_control_data_dynamo_vizs.f90 b/src/Fortran_libraries/MHD_src/IO/t_control_data_dynamo_vizs.f90 new file mode 100644 index 00000000..0f0e6fb2 --- /dev/null +++ b/src/Fortran_libraries/MHD_src/IO/t_control_data_dynamo_vizs.f90 @@ -0,0 +1,279 @@ +!>@file t_control_data_dynamo_vizs.f90 +!!@brief module t_control_data_dynamo_vizs +!! +!!@author H. Matsui +!!@date Programmed in Nov., 2017 +! +!> @brief Control data structure for zonal mean visualization controls +!! +!!@verbatim +!! subroutine init_dynamo_viz_control(hd_block, zm_ctls) +!! subroutine read_dynamo_viz_control & +!! & (id_control, hd_block, zm_ctls, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(sph_dynamo_viz_controls), intent(inout) :: zm_ctls +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_dynamo_viz_control(id_control, zm_ctls, level) +!! integer(kind = kint), intent(in) :: id_control +!! type(sph_dynamo_viz_controls), intent(in) :: zm_ctls +!! integer(kind = kint), intent(inout) :: level +!! subroutine dealloc_dynamo_viz_control(zm_ctls) +!! type(sph_dynamo_viz_controls), intent(in) :: zm_ctls +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! begin dynamo_vizs_control +!! begin crustal_filtering_ctl +!! truncation_degree_ctl 13 +!! end crustal_filtering_ctl +!! +!! file zonal_mean_section_ctl +!! begin zonal_RMS_section_ctl +!! .... +!! end zonal_RMS_section_ctl +!! +!! array zonal_mean_rendering_ctl +!! file zonal_mean_rendering_ctl ctl_zm_Bline +!! begin zonal_mean_rendering_ctl +!! .... +!! end zonal_mean_rendering_ctl +!! end array zonal_mean_rendering_ctl +!! +!! array zonal_RMS_rendering_ctl +!! file zonal_RMS_rendering_ctl ctl_zRMS_Bline +!! begin zonal_RMS_rendering_ctl +!! .... +!! end zonal_RMS_rendering_ctl +!! end array zonal_RMS_rendering_ctl +!! end dynamo_vizs_control +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! +! + module t_control_data_dynamo_vizs +! + use m_precision +! + use m_machine_parameter + use t_control_data_sections + use t_ctl_data_crust_filter + use t_control_data_maps +! + implicit none +! +! +!> Structures of zonal mean controls + type sph_dynamo_viz_controls +!> Block name + character(len=kchara) :: block_name = 'dynamo_vizs_control' +!> Structure of crustal filtering of mangeitc field + type(clust_filtering_ctl) :: crust_filter_ctl +! +!> Structure of zonal mean sectioning controls + type(section_controls) :: zm_psf_ctls +!> Structure of zonal RMS sectioning controls + type(section_controls) :: zRMS_psf_ctls +! +!> Structures of map projection controls + type(map_rendering_controls) :: zm_map_ctls +!> Structures of map projection controls + type(map_rendering_controls) :: zRMS_map_ctls +! + integer (kind=kint) :: i_viz_ctl = 0 + end type sph_dynamo_viz_controls +! +! lavel for volume rendering +! +! Top level + character(len=kchara), parameter & + & :: hd_crustal_filtering = 'crustal_filtering_ctl' + character(len=kchara), parameter & + & :: hd_zm_section = 'zonal_mean_section_ctl' + character(len=kchara), parameter & + & :: hd_zRMS_section = 'zonal_RMS_section_ctl' + character(len=kchara), parameter & + & :: hd_zm_rendering = 'zonal_mean_rendering_ctl' + character(len=kchara), parameter & + & :: hd_zRMS_rendering = 'zonal_RMS_rendering_ctl' +! + private :: hd_zm_section, hd_zRMS_section + private :: hd_crustal_filtering +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_dynamo_viz_control & + & (id_control, hd_block, zm_ctls, c_buf) +! + use t_read_control_elements + use skip_comment_f + use ctl_file_map_renderings_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(sph_dynamo_viz_controls), intent(inout) :: zm_ctls + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(zm_ctls%i_viz_ctl .gt. 0) return + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_crustal_filtering_ctl & + & (id_control, hd_crustal_filtering, & + & zm_ctls%crust_filter_ctl, c_buf) +! + call read_single_section_ctl(id_control, hd_zm_section, & + & zm_ctls%zm_psf_ctls, c_buf) + call read_single_section_ctl(id_control, hd_zRMS_section, & + & zm_ctls%zRMS_psf_ctls, c_buf) +! + call read_files_4_map_ctl(id_control, hd_zm_rendering, & + & zm_ctls%zm_map_ctls, c_buf) + call read_files_4_map_ctl(id_control, hd_zRMS_rendering, & + & zm_ctls%zRMS_map_ctls, c_buf) + end do + zm_ctls%i_viz_ctl = 1 +! + end subroutine read_dynamo_viz_control +! +! -------------------------------------------------------------------- +! + subroutine write_dynamo_viz_control(id_control, zm_ctls, level) +! + use t_read_control_elements + use write_control_elements + use skip_comment_f + use ctl_file_map_renderings_IO +! + integer(kind = kint), intent(in) :: id_control + type(sph_dynamo_viz_controls), intent(in) :: zm_ctls + integer(kind = kint), intent(inout) :: level +! +! + if(zm_ctls%i_viz_ctl .le. 0) return +! + level = write_begin_flag_for_ctl(id_control, level, & + & zm_ctls%block_name) + call write_crustal_filtering_ctl(id_control, & + & zm_ctls%crust_filter_ctl, level) +! + call write_single_section_ctl(id_control, hd_zm_section, & + & zm_ctls%zm_psf_ctls, level) + call write_single_section_ctl(id_control, hd_zRMS_section, & + & zm_ctls%zRMS_psf_ctls, level) +! + call write_files_4_map_ctl(id_control, hd_zm_rendering, & + & zm_ctls%zm_map_ctls, level) + call write_files_4_map_ctl(id_control, hd_zRMS_rendering, & + & zm_ctls%zRMS_map_ctls, level) + level = write_end_flag_for_ctl(id_control, level, & + & zm_ctls%block_name) +! + end subroutine write_dynamo_viz_control +! +! -------------------------------------------------------------------- +! + subroutine init_dynamo_viz_control(hd_block, zm_ctls) +! + use ctl_file_map_renderings_IO +! + character(len=kchara), intent(in) :: hd_block + type(sph_dynamo_viz_controls), intent(inout) :: zm_ctls +! +! + zm_ctls%block_name = trim(hd_block) + call init_crustal_filtering_ctl(hd_crustal_filtering, & + & zm_ctls%crust_filter_ctl) + call init_psf_ctls_labels(hd_zm_section, zm_ctls%zm_psf_ctls) + call init_psf_ctls_labels(hd_zRMS_section, & + & zm_ctls%zRMS_psf_ctls) + call init_map_ctls_labels(hd_zm_rendering, zm_ctls%zm_map_ctls) + call init_map_ctls_labels(hd_zRMS_rendering, & + & zm_ctls%zRMS_map_ctls) +! + end subroutine init_dynamo_viz_control +! +! -------------------------------------------------------------------- +! + subroutine dealloc_dynamo_viz_control(zm_ctls) +! + type(sph_dynamo_viz_controls), intent(inout) :: zm_ctls +! +! + call reset_crustal_filtering_ctl(zm_ctls%crust_filter_ctl) + call dealloc_psf_ctl_stract(zm_ctls%zm_psf_ctls) + call dealloc_psf_ctl_stract(zm_ctls%zRMS_psf_ctls) + call dealloc_map_ctl_stract(zm_ctls%zm_map_ctls) + call dealloc_map_ctl_stract(zm_ctls%zRMS_map_ctls) +! + end subroutine dealloc_dynamo_viz_control +! +! -------------------------------------------------------------------- +! -------------------------------------------------------------------- +! + subroutine read_single_section_ctl & + & (id_control, hd_section, psf_ctls, c_buf) +! + use t_read_control_elements + use t_control_data_sections + use ctl_data_section_IO + use ctl_file_sections_IO + use skip_comment_f + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: hd_section + type(section_controls), intent(inout) :: psf_ctls + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(psf_ctls%num_psf_ctl .gt. 0) return +! + if(check_file_flag(c_buf, hd_section) & + & .or. check_begin_flag(c_buf, hd_section)) then + psf_ctls%num_psf_ctl = 1 + call alloc_psf_ctl_stract(psf_ctls) + call init_psf_ctl_stract(hd_section, & + & psf_ctls%psf_ctl_struct(1)) + psf_ctls%fname_psf_ctl(1) = 'NO_FILE' +! + call write_multi_ctl_file_message & + & (hd_section, psf_ctls%num_psf_ctl, c_buf%level) + call sel_read_control_4_psf_file(id_control, hd_section, & + & psf_ctls%fname_psf_ctl(psf_ctls%num_psf_ctl), & + & psf_ctls%psf_ctl_struct(psf_ctls%num_psf_ctl), c_buf) + end if +! + end subroutine read_single_section_ctl +! +! -------------------------------------------------------------------- +! + subroutine write_single_section_ctl & + & (id_control, hd_section, psf_ctls, level) +! + use t_control_data_sections + use ctl_file_sections_IO +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: hd_section + type(section_controls), intent(in) :: psf_ctls + integer(kind = kint), intent(inout) :: level +! +! + if(psf_ctls%num_psf_ctl .le. 0) return + call sel_write_control_4_psf_file(id_control, hd_section, & + & psf_ctls%fname_psf_ctl(1), psf_ctls%psf_ctl_struct(1), level) +! + end subroutine write_single_section_ctl +! +! -------------------------------------------------------------------- +! + end module t_control_data_dynamo_vizs diff --git a/src/Fortran_libraries/MHD_src/IO/t_ctl_data_sph_MHD_w_vizs.f90 b/src/Fortran_libraries/MHD_src/IO/t_ctl_data_sph_MHD_w_vizs.f90 new file mode 100644 index 00000000..fcac0744 --- /dev/null +++ b/src/Fortran_libraries/MHD_src/IO/t_ctl_data_sph_MHD_w_vizs.f90 @@ -0,0 +1,326 @@ +!>@file t_ctl_data_sph_MHD_w_vizs.f90 +!!@brief module t_ctl_data_sph_MHD_w_vizs +!! +!!@author H. Matsui +!>@brief Control read routine +!!@date programmed by H.Matsui and H.Okuda +!!@n on July 2000 (ver 1.1) +!!@n Modified by H. Matsui on July, 2006 +!!@n Modified by H. Matsui on May, 2007 +!!@n Modified by H. Matsui on Oct., 2007 +!!@n Modified by H. Matsui on Oct., 2012 +!! +!!@verbatim +!! subroutine read_control_4_sph_MHD_w_vizs(file_name, MHD_ctl, & +!! & add_VMHD_ctl, c_buf) +!! character(len=kchara), intent(in) :: file_name +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(mhd_simulation_control), intent(inout) :: MHD_ctl +!! type(add_vizs_sph_mhd_ctl), intent(inout) :: add_VMHD_ctl +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_control_4_sph_MHD_w_vizs(file_name, MHD_ctl, & +!! & add_VMHD_ctl) +!! subroutine write_sph_mhd_ctl_w_vizs(id_control, & +!! & MHD_ctl, add_VMHD_ctl, level) +!! character(len=kchara), intent(in) :: file_name +!! integer(kind = kint), intent(in) :: id_control +!! type(mhd_simulation_control), intent(in) :: MHD_ctl +!! type(add_vizs_sph_mhd_ctl), intent(in) :: add_VMHD_ctl +!! integer(kind = kint), intent(inout) :: level +!! +!! subroutine dealloc_sph_mhd_ctl_w_vizs(add_VMHD_ctl) +!! type(add_vizs_sph_mhd_ctl), intent(inout) :: add_VMHD_ctl +!!@endverbatim +! + module t_ctl_data_sph_MHD_w_vizs +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_ctl_data_MHD + use t_ctl_data_MHD_model + use t_ctl_data_SPH_MHD_control + use t_ctl_data_4_sph_monitor + use t_ctl_data_node_monitor + use t_ctl_data_gen_sph_shell +! + use t_control_data_viz4 + use t_control_data_dynamo_vizs +! + implicit none +! +! + integer(kind = kint), parameter, private :: id_control_file = 11 +! +!> Additional structures for spherical MHD dynamo with viz module + type add_vizs_sph_mhd_ctl +!> Structures of visualization controls + type(vis4_controls) :: viz4_ctls +!> Structures of zonal mean controls + type(sph_dynamo_viz_controls) :: zm_ctls + end type add_vizs_sph_mhd_ctl +! +! + character(len=kchara), parameter, private & + & :: hd_mhd_ctl = 'MHD_control' +! +! 2nd level for MHD +! + character(len=kchara), parameter, private & + & :: hd_platform = 'data_files_def' + character(len=kchara), parameter, private & + & :: hd_org_data = 'org_data_files_def' + character(len=kchara), parameter, private & + & :: hd_new_data = 'new_data_files_def' + character(len=kchara), parameter, private & + & :: hd_sph_shell = 'spherical_shell_ctl' + character(len=kchara), parameter, private & + & :: hd_model = 'model' + character(len=kchara), parameter, private & + & :: hd_control = 'control' + character(len=kchara), parameter, private & + & :: hd_pick_sph = 'sph_monitor_ctl' + character(len=kchara), parameter, private & + & :: hd_monitor_data = 'monitor_data_ctl' +! + character(len=kchara), parameter, private & + & :: hd_viz_ctl = 'visual_control' + character(len=kchara), parameter, private & + & :: hd_dynamo_viz_ctl = 'dynamo_vizs_control' +! +!> Here is the old label + character(len=kchara), parameter, private & + & :: hd_zm_viz_ctl = 'zonal_mean_control' +! + private :: read_sph_mhd_ctl_w_vizs +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine read_control_4_sph_MHD_w_vizs(file_name, MHD_ctl, & + & add_VMHD_ctl, c_buf) +! + use viz4_step_ctls_to_time_ctl +! + character(len=kchara), intent(in) :: file_name + type(mhd_simulation_control), intent(inout) :: MHD_ctl + type(add_vizs_sph_mhd_ctl), intent(inout) :: add_VMHD_ctl + type(buffer_for_control), intent(inout) :: c_buf +! +! + c_buf%level = c_buf%level + 1 + call init_sph_mhd_ctl_w_vizs_label(hd_mhd_ctl, & + & MHD_ctl, add_VMHD_ctl) + open(id_control_file, file = file_name, status='old' ) +! + do + call load_one_line_from_control(id_control_file, & + & hd_mhd_ctl, c_buf) + if(c_buf%iend .gt. 0) exit +! + call read_sph_mhd_ctl_w_vizs(id_control_file, & + & hd_mhd_ctl, MHD_ctl, add_VMHD_ctl, c_buf) + if(MHD_ctl%i_mhd_ctl .gt. 0) exit + end do + close(id_control_file) +! + c_buf%level = c_buf%level - 1 + if(c_buf%iend .gt. 0) return +! + call s_viz4_step_ctls_to_time_ctl(add_VMHD_ctl%viz4_ctls, & + & MHD_ctl%smctl_ctl%tctl) + call add_fields_viz4_to_fld_ctl(add_VMHD_ctl%viz4_ctls, & + & MHD_ctl%model_ctl%fld_ctl%field_ctl) +! + end subroutine read_control_4_sph_MHD_w_vizs +! +! ---------------------------------------------------------------------- +! + subroutine write_control_4_sph_MHD_w_vizs(file_name, MHD_ctl, & + & add_VMHD_ctl) +! + use delete_data_files +! + character(len=kchara), intent(in) :: file_name + type(mhd_simulation_control), intent(in) :: MHD_ctl + type(add_vizs_sph_mhd_ctl), intent(in) :: add_VMHD_ctl +! + integer(kind = kint) :: level1 +! +! + if(check_file_exist(file_name)) then + write(*,*) 'File ', trim(file_name), ' exist. Continue?' + read(*,*) + end if +! + write(*,*) 'Write MHD control file: ', trim(file_name) + open(id_control_file, file = file_name) + level1 = 0 + call write_sph_mhd_ctl_w_vizs(id_control_file, & + & MHD_ctl, add_VMHD_ctl, level1) + close(id_control_file) +! + end subroutine write_control_4_sph_MHD_w_vizs +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine read_sph_mhd_ctl_w_vizs(id_control, hd_block, & + & MHD_ctl, add_VMHD_ctl, c_buf) +! + use ctl_data_platforms_IO + use ctl_data_sph_monitor_IO + use ctl_data_MHD_model_IO + use ctl_data_four_vizs_IO + use ctl_file_gen_sph_shell_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(mhd_simulation_control), intent(inout) :: MHD_ctl + type(add_vizs_sph_mhd_ctl), intent(inout) :: add_VMHD_ctl + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(MHD_ctl%i_mhd_ctl .gt. 0) return + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! +! + call read_control_platforms & + & (id_control, hd_platform, MHD_ctl%plt, c_buf) + call read_control_platforms & + & (id_control, hd_org_data, MHD_ctl%org_plt, c_buf) +! + call sel_read_ctl_gen_shell_grids(id_control, hd_sph_shell, & + & MHD_ctl%fname_psph, MHD_ctl%psph_ctl, c_buf) +! + call read_sph_mhd_model & + & (id_control, hd_model, MHD_ctl%model_ctl, c_buf) + call read_sph_mhd_control & + & (id_control, hd_control, MHD_ctl%smctl_ctl, c_buf) +! + call read_monitor_data_ctl & + & (id_control, hd_monitor_data, MHD_ctl%nmtr_ctl, c_buf) + call read_sph_monitoring_ctl & + & (id_control, hd_pick_sph, MHD_ctl%smonitor_ctl, c_buf) +! + call s_read_viz4_controls & + & (id_control, hd_viz_ctl, add_VMHD_ctl%viz4_ctls, c_buf) +! + call read_dynamo_viz_control & + & (id_control, hd_dynamo_viz_ctl, add_VMHD_ctl%zm_ctls, c_buf) + call read_dynamo_viz_control & + & (id_control, hd_zm_viz_ctl, add_VMHD_ctl%zm_ctls, c_buf) + end do + MHD_ctl%i_mhd_ctl = 1 +! + end subroutine read_sph_mhd_ctl_w_vizs +! +! -------------------------------------------------------------------- +! + subroutine write_sph_mhd_ctl_w_vizs(id_control, & + & MHD_ctl, add_VMHD_ctl, level) +! + use ctl_data_platforms_IO + use ctl_data_sph_monitor_IO + use ctl_data_MHD_model_IO + use ctl_data_four_vizs_IO + use ctl_file_gen_sph_shell_IO +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + type(mhd_simulation_control), intent(in) :: MHD_ctl + type(add_vizs_sph_mhd_ctl), intent(in) :: add_VMHD_ctl +! + integer(kind = kint), intent(inout) :: level +! +! + if(MHD_ctl%i_mhd_ctl .le. 0) return +! + level = write_begin_flag_for_ctl(id_control, level, & + & MHD_ctl%block_name) + call write_control_platforms & + & (id_control, hd_platform, MHD_ctl%plt, level) + call write_control_platforms & + & (id_control, hd_org_data, MHD_ctl%org_plt, level) +! + call sel_write_ctl_gen_shell_grids(id_control, & + & MHD_ctl%fname_psph, MHD_ctl%psph_ctl, level) +! + call write_sph_mhd_model(id_control, MHD_ctl%model_ctl, level) + call write_sph_mhd_control(id_control, MHD_ctl%smctl_ctl, level) +! + call write_monitor_data_ctl(id_control, MHD_ctl%nmtr_ctl, level) + call write_sph_monitoring_ctl & + & (id_control, MHD_ctl%smonitor_ctl, level) +! + call write_viz4_controls & + & (id_control, add_VMHD_ctl%viz4_ctls, level) +! + call write_dynamo_viz_control & + & (id_control, add_VMHD_ctl%zm_ctls, level) + level = write_end_flag_for_ctl(id_control, level, & + & MHD_ctl%block_name) +! + end subroutine write_sph_mhd_ctl_w_vizs +! +! -------------------------------------------------------------------- +! + subroutine init_sph_mhd_ctl_w_vizs_label(hd_block, & + & MHD_ctl, add_VMHD_ctl) +! + use ctl_data_platforms_IO + use ctl_data_sph_monitor_IO + use ctl_data_MHD_model_IO + use ctl_data_four_vizs_IO + use ctl_file_gen_sph_shell_IO +! + character(len=kchara), intent(in) :: hd_block +! + type(mhd_simulation_control), intent(inout) :: MHD_ctl + type(add_vizs_sph_mhd_ctl), intent(inout) :: add_VMHD_ctl +! +! + MHD_ctl%block_name = trim(hd_block) + call init_platforms_labels(hd_platform, MHD_ctl%plt) + call init_platforms_labels(hd_org_data, MHD_ctl%org_plt) + call init_parallel_shell_ctl_label(hd_sph_shell, & + & MHD_ctl%psph_ctl) + call init_sph_mhd_model_label(hd_model, MHD_ctl%model_ctl) + call init_sph_mhd_control_label(hd_control, MHD_ctl%smctl_ctl) + call init_sph_monitoring_labels(hd_pick_sph, & + & MHD_ctl%smonitor_ctl) + call init_viz4_ctl_label(hd_viz_ctl, add_VMHD_ctl%viz4_ctls) + call init_dynamo_viz_control(hd_dynamo_viz_ctl, & + & add_VMHD_ctl%zm_ctls) + call init_monitor_data_ctl_label(hd_monitor_data, & + & MHD_ctl%nmtr_ctl) +! + end subroutine init_sph_mhd_ctl_w_vizs_label +! +! -------------------------------------------------------------------- +! -------------------------------------------------------------------- +! + subroutine dealloc_sph_mhd_ctl_w_vizs(add_VMHD_ctl) +! + type(add_vizs_sph_mhd_ctl), intent(inout) :: add_VMHD_ctl +! +! + call dealloc_viz4_controls(add_VMHD_ctl%viz4_ctls) + call dealloc_dynamo_viz_control(add_VMHD_ctl%zm_ctls) +! + end subroutine dealloc_sph_mhd_ctl_w_vizs +! +! -------------------------------------------------------------------- +! + end module t_ctl_data_sph_MHD_w_vizs diff --git a/src/Fortran_libraries/MHD_src/sph_MHD/Makefile.depends b/src/Fortran_libraries/MHD_src/sph_MHD/Makefile.depends index 5677a970..34c779ab 100644 --- a/src/Fortran_libraries/MHD_src/sph_MHD/Makefile.depends +++ b/src/Fortran_libraries/MHD_src/sph_MHD/Makefile.depends @@ -178,6 +178,8 @@ initial_magne_dynamobench.o: $(MHD_SPH_DIR)/initial_magne_dynamobench.f90 m_prec $(F90) -c $(F90OPTFLAGS) $< input_control_sph_MHD.o: $(MHD_SPH_DIR)/input_control_sph_MHD.f90 m_precision.o m_machine_parameter.o calypso_mpi.o t_const_spherical_grid.o t_MHD_file_parameter.o t_MHD_step_parameter.o t_SPH_MHD_model_data.o t_SPH_mesh_field_data.o t_FEM_mesh_field_data.o t_control_data_dynamo_sects.o t_rms_4_sph_spectr.o t_file_IO_parameter.o t_sph_boundary_input_data.o t_bc_data_list.o t_flex_delta_t_data.o t_work_SPH_MHD.o t_ctl_data_MHD.o t_ctl_data_sph_MHD_w_psf.o t_read_control_elements.o bcast_control_sph_MHD.o bcast_ctl_data_surfacings.o bcast_dynamo_sect_control.o t_time_data.o t_node_monitor_IO.o m_error_IDs.o set_control_sph_mhd.o set_control_SPH_MHD_w_viz.o sph_file_IO_select.o set_control_4_SPH_to_FEM.o parallel_load_data_4_sph.o set_control_SPH_MHD_noviz.o $(F90) -c $(F90OPTFLAGS) $< +input_control_sph_MHD_vizs.o: $(MHD_SPH_DIR)/input_control_sph_MHD_vizs.f90 m_precision.o m_machine_parameter.o calypso_mpi.o t_const_spherical_grid.o t_MHD_file_parameter.o t_MHD_step_parameter.o t_SPH_MHD_model_data.o t_SPH_mesh_field_data.o t_FEM_mesh_field_data.o t_control_data_dynamo_vizs.o t_rms_4_sph_spectr.o t_file_IO_parameter.o t_sph_boundary_input_data.o t_bc_data_list.o t_flex_delta_t_data.o t_work_SPH_MHD.o t_ctl_data_MHD.o t_ctl_data_sph_MHD_w_vizs.o t_read_control_elements.o bcast_control_sph_MHD.o bcast_ctl_data_viz4.o bcast_dynamo_viz_control.o t_time_data.o t_node_monitor_IO.o m_error_IDs.o set_control_sph_mhd.o set_control_SPH_MHD_w_viz.o sph_file_IO_select.o set_control_4_SPH_to_FEM.o parallel_load_data_4_sph.o + $(F90) -c $(F90OPTFLAGS) $< interact_coriolis_rlm.o: $(MHD_SPH_DIR)/interact_coriolis_rlm.f90 m_precision.o m_constants.o m_machine_parameter.o t_gaunt_coriolis_rlm.o cal_gaunt_itgs.o $(F90) -c $(F90OPTFLAGS) $< interpolate_reference_data.o: $(MHD_SPH_DIR)/interpolate_reference_data.f90 m_precision.o m_constants.o m_machine_parameter.o t_spheric_rj_data.o t_phys_data.o t_field_data_IO.o t_sph_radial_interpolate.o fill_scalar_field.o r_interpolate_sph_data.o radial_interpolation.o @@ -322,6 +324,8 @@ t_SPH_MHD_model_data.o: $(MHD_SPH_DIR)/t_SPH_MHD_model_data.f90 m_precision.o t_ $(F90) -c $(F90OPTFLAGS) $< t_SPH_MHD_zmean_sections.o: $(MHD_SPH_DIR)/t_SPH_MHD_zmean_sections.f90 m_precision.o m_machine_parameter.o m_work_time.o calypso_mpi.o t_time_data.o t_comm_table.o t_mesh_data.o t_phys_data.o t_spheric_parameter.o t_sph_trans_arrays_MHD.o t_cross_section.o t_mesh_SR.o t_VIZ_step_parameter.o t_elapsed_labels_4_SECTIONS.o t_control_data_dynamo_sects.o FEM_analyzer_sph_MHD.o nod_phys_send_recv.o sph_rtp_zonal_rms_data.o $(F90) -c $(F90OPTFLAGS) $< +t_SPH_MHD_zonal_mean_viz.o: $(MHD_SPH_DIR)/t_SPH_MHD_zonal_mean_viz.f90 m_precision.o m_machine_parameter.o m_work_time.o calypso_mpi.o t_elapsed_labels_4_VIZ.o t_time_data.o t_comm_table.o t_mesh_data.o t_phys_data.o t_map_projection.o t_spheric_parameter.o t_sph_trans_arrays_MHD.o t_cross_section.o t_mesh_SR.o t_VIZ_step_parameter.o t_control_data_dynamo_vizs.o map_projection.o FEM_analyzer_sph_MHD.o nod_phys_send_recv.o sph_rtp_zonal_rms_data.o + $(F90) -c $(F90OPTFLAGS) $< t_addresses_sph_transform.o: $(MHD_SPH_DIR)/t_addresses_sph_transform.f90 m_precision.o t_spheric_rtp_data.o $(F90) -c $(F90OPTFLAGS) $< t_boundary_data_sph_MHD.o: $(MHD_SPH_DIR)/t_boundary_data_sph_MHD.f90 m_precision.o t_boundary_params_sph_MHD.o t_boundary_sph_spectr.o t_coef_fdm2_MHD_boundaries.o t_coef_fdm4_zero_vpol_ICB.o t_coef_fdm4_free_vpol_ICB.o t_coef_fdm4_zero_vpol_CMB.o t_coef_fdm4_free_vpol_CMB.o t_coef_fdm4_vpol_centre.o t_coef_fdm3_n2e_zero_vp_ICB.o t_coef_fdm3_n2e_free_vp_ICB.o t_coef_fdm3_n2e_zero_vp_CMB.o t_coef_fdm3_n2e_free_vp_CMB.o t_coef_fdm3_n2e_zero_vp_CTR.o t_time_data.o t_spheric_parameter.o t_control_parameter.o set_evoluved_boundaries.o @@ -370,6 +374,8 @@ t_reference_scalar_param.o: $(MHD_SPH_DIR)/t_reference_scalar_param.f90 m_precis $(F90) -c $(F90OPTFLAGS) $< t_sph_MHD_w_psf.o: $(MHD_SPH_DIR)/t_sph_MHD_w_psf.f90 m_precision.o t_FEM_mesh_field_data.o t_SPH_MHD_zmean_sections.o t_viz_sections.o t_comm_table.o $(F90) -c $(F90OPTFLAGS) $< +t_sph_MHD_w_vizs.o: $(MHD_SPH_DIR)/t_sph_MHD_w_vizs.f90 m_precision.o t_FEM_mesh_field_data.o t_SPH_MHD_zonal_mean_viz.o t_four_visualizers.o t_VIZ_mesh_field.o + $(F90) -c $(F90OPTFLAGS) $< t_sph_center_matrix.o: $(MHD_SPH_DIR)/t_sph_center_matrix.f90 m_precision.o m_machine_parameter.o t_sph_matrix.o t_spheric_rj_data.o m_ludcmp_3band.o m_ludcmp_band.o lubksb_357band.o check_sph_radial_mat.o $(F90) -c $(F90OPTFLAGS) $< t_sph_mhd_monitor_data_IO.o: $(MHD_SPH_DIR)/t_sph_mhd_monitor_data_IO.f90 m_precision.o calypso_mpi.o m_machine_parameter.o t_SPH_mesh_field_data.o t_schmidt_poly_on_rtm.o t_rms_4_sph_spectr.o t_sum_sph_rms_data.o t_pickup_sph_spectr_data.o t_no_heat_Nusselt.o t_CMB_dipolarity.o t_sph_typical_scales.o t_IO_step_parameter.o t_energy_label_parameters.o t_boundary_params_sph_MHD.o t_field_on_circle.o t_field_4_dynamobench.o pickup_sph_spectr_data.o calypso_mpi_int.o m_error_IDs.o cal_rms_fields_by_sph.o cal_CMB_dipolarity.o write_picked_sph_spectr.o t_solver_SR.o init_rms_4_sph_spectr.o calypso_mpi_logical.o output_sph_pwr_volume_file.o write_sph_gauss_coefs.o pickup_gauss_coefficients.o cal_typical_scale.o write_typical_scale.o diff --git a/src/Fortran_libraries/MHD_src/sph_MHD/input_control_sph_MHD_vizs.f90 b/src/Fortran_libraries/MHD_src/sph_MHD/input_control_sph_MHD_vizs.f90 new file mode 100644 index 00000000..46ddb1a7 --- /dev/null +++ b/src/Fortran_libraries/MHD_src/sph_MHD/input_control_sph_MHD_vizs.f90 @@ -0,0 +1,159 @@ +!>@file input_control_sph_MHD_vizs.f90 +!!@brief module input_control_sph_MHD_vizs +!! +!!@author H.Matsui +!!@date Programmed by H.Matsui in March, 2015 +! +!>@brief Load mesh and filtering data for MHD simulation +!! +!!@verbatim +!! subroutine load_control_4_sph_MHD_w_vizs(file_name, MHD_ctl, & +!! & add_SMHD_ctl) +!! subroutine s_input_control_SPH_MHD_vizs & +!! & (ctl_file_name, MHD_files, MHD_ctl, add_VMHD_ctl, & +!! & MHD_step, SPH_model, SPH_WK, SPH_MHD, FEM_dat) +!! character(len=kchara), intent(in) :: ctl_file_name +!! type(MHD_file_IO_params), intent(inout) :: MHD_files +!! type(mhd_simulation_control), intent(inout) :: MHD_ctl +!! type(add_vizs_sph_mhd_ctl), intent(inout) :: add_VMHD_ctl +!! type(MHD_step_param), intent(inout) :: MHD_step +!! type(SPH_MHD_model_data), intent(inout) :: SPH_model +!! type(work_SPH_MHD), intent(inout) :: SPH_WK +!! type(SPH_mesh_field_data), intent(inout) :: SPH_MHD +!! type(FEM_mesh_field_data), intent(inout) :: FEM_dat +!!@endverbatim +! +! + module input_control_sph_MHD_vizs +! + use m_precision +! + use m_machine_parameter + use calypso_mpi +! + use t_const_spherical_grid + use t_MHD_file_parameter + use t_MHD_step_parameter + use t_SPH_MHD_model_data + use t_SPH_mesh_field_data + use t_FEM_mesh_field_data + use t_control_data_dynamo_vizs + use t_rms_4_sph_spectr + use t_file_IO_parameter + use t_sph_boundary_input_data + use t_bc_data_list + use t_flex_delta_t_data + use t_work_SPH_MHD +! + implicit none +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine load_control_4_sph_MHD_w_vizs(file_name, MHD_ctl, & + & add_VMHD_ctl) +! + use t_ctl_data_MHD + use t_ctl_data_sph_MHD_w_vizs + use t_read_control_elements + use bcast_control_sph_MHD + use bcast_ctl_data_viz4 + use bcast_dynamo_viz_control + +! + character(len=kchara), intent(in) :: file_name + type(mhd_simulation_control), intent(inout) :: MHD_ctl + type(add_vizs_sph_mhd_ctl), intent(inout) :: add_VMHD_ctl +! + type(buffer_for_control) :: c_buf1 +! +! + c_buf1%level = 0 + if(my_rank .eq. 0) then + call read_control_4_sph_MHD_w_vizs(file_name, MHD_ctl, & + & add_VMHD_ctl, c_buf1) + end if +! + if(c_buf1%iend .gt. 0) then + call calypso_MPI_abort(MHD_ctl%i_mhd_ctl, trim(file_name)) + end if +! + call bcast_sph_mhd_control_data(MHD_ctl) + call bcast_viz4_controls(add_VMHD_ctl%viz4_ctls) + call s_bcast_dynamo_viz_control(add_VMHD_ctl%zm_ctls) +! + end subroutine load_control_4_sph_MHD_w_vizs +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine s_input_control_SPH_MHD_vizs & + & (ctl_file_name, MHD_files, MHD_ctl, add_VMHD_ctl, & + & MHD_step, SPH_model, SPH_WK, SPH_MHD, FEM_dat) +! + use t_time_data + use t_ctl_data_MHD + use t_ctl_data_sph_MHD_w_vizs + use t_node_monitor_IO + use m_error_IDs +! + use set_control_sph_mhd + use set_control_SPH_MHD_w_viz + use sph_file_IO_select + use set_control_4_SPH_to_FEM + use parallel_load_data_4_sph +! + character(len=kchara), intent(in) :: ctl_file_name + type(MHD_file_IO_params), intent(inout) :: MHD_files + type(mhd_simulation_control), intent(inout) :: MHD_ctl + type(add_vizs_sph_mhd_ctl), intent(inout) :: add_VMHD_ctl +! + type(MHD_step_param), intent(inout) :: MHD_step + type(SPH_MHD_model_data), intent(inout) :: SPH_model + type(work_SPH_MHD), intent(inout) :: SPH_WK +! + type(SPH_mesh_field_data), intent(inout) :: SPH_MHD + type(FEM_mesh_field_data), intent(inout) :: FEM_dat +! +! Read control file + if (iflag_debug.eq.1) write(*,*) 'load_control_4_sph_MHD_w_vizs' + call load_control_4_sph_MHD_w_vizs(ctl_file_name, MHD_ctl, & + & add_VMHD_ctl) +! +! Set parameters from control + if (iflag_debug.eq.1) write(*,*) 'set_control_4_SPH_MHD' + call set_control_4_SPH_MHD(MHD_ctl%plt, MHD_ctl%org_plt, & + & MHD_ctl%model_ctl, MHD_ctl%smctl_ctl, MHD_ctl%psph_ctl, & + & MHD_files, SPH_model%bc_IO, SPH_model%refs, MHD_step, & + & SPH_model%MHD_prop, SPH_model%MHD_BC, SPH_WK%trans_p, & + & SPH_WK%trns_WK, SPH_MHD%sph_maker) +! + call s_set_control_SPH_MHD_w_viz & + & (MHD_ctl%model_ctl, MHD_ctl%psph_ctl, MHD_ctl%smonitor_ctl, & + & add_VMHD_ctl%zm_ctls%crust_filter_ctl, MHD_ctl%nmtr_ctl, & + & SPH_model%MHD_prop, SPH_model%MHD_BC, SPH_MHD%sph, & + & SPH_MHD%fld, FEM_dat%field, SPH_WK%monitor, FEM_dat%nod_mntr) +! +! Load spherical shell table + if (iflag_debug.eq.1) write(*,*) 'load_para_SPH_and_FEM_mesh' + call load_para_SPH_and_FEM_mesh & + & (MHD_files%FEM_mesh_flags, MHD_files%sph_file_param, & + & SPH_MHD, FEM_dat%geofem, MHD_files%mesh_file_IO) +! + call dealloc_sph_mhd_ctl_data(MHD_ctl) +! + call sph_boundary_IO_control & + & (SPH_model%MHD_prop, SPH_model%MHD_BC, SPH_model%bc_IO) +! +! Set initial time into time data + if (iflag_debug.eq.1) write(*,*) 'copy_delta_t' + call copy_delta_t(MHD_step%init_d, MHD_step%time_d) +! + end subroutine s_input_control_SPH_MHD_vizs +! +! ---------------------------------------------------------------------- +! + end module input_control_sph_MHD_vizs diff --git a/src/Fortran_libraries/MHD_src/sph_MHD/t_SPH_MHD_zonal_mean_viz.f90 b/src/Fortran_libraries/MHD_src/sph_MHD/t_SPH_MHD_zonal_mean_viz.f90 new file mode 100644 index 00000000..5b310c62 --- /dev/null +++ b/src/Fortran_libraries/MHD_src/sph_MHD/t_SPH_MHD_zonal_mean_viz.f90 @@ -0,0 +1,276 @@ +!>@file t_SPH_MHD_zonal_mean_viz.f90 +!!@brief module t_SPH_MHD_zonal_mean_viz +!! +!!@author H. Matsui +!!@date Programmed H. Matsui in Apr., 2012 +! +!>@brief Make zonal mean sections +!! +!!@verbatim +!! subroutine init_zonal_mean_vizs(elps_VIZ, viz_step, & +!! & geofem, edge_comm, nod_fld, zm_ctls, zmeans, m_SR) +!! type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ +!! type(VIZ_step_params), intent(in) :: viz_step +!! type(mesh_data), intent(in) :: geofem +!! type(phys_data), intent(in) :: nod_fld +!! type(sph_dynamo_viz_controls), intent(inout) :: zm_ctls +!! type(sph_zonal_mean_viz), intent(inout) :: zmeans +!! type(mesh_SR), intent(inout) :: m_SR +!! subroutine SPH_MHD_zmean_vizs(elps_VIZ, viz_step, time_d, & +!! & sph, geofem, WK, nod_fld, zmeans, m_SR) +!! type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ +!! type(VIZ_step_params), intent(in) :: viz_step +!! type(time_data), intent(in) :: time_d +!! type(sph_grids), intent(in) :: sph +!! type(mesh_data), intent(in) :: geofem +!! type(works_4_sph_trans_MHD), intent(in) :: WK +!! type(phys_data), intent(inout) :: nod_fld +!! type(sph_zonal_mean_viz), intent(inout) :: zmeans +!! type(mesh_SR), intent(inout) :: m_SR +!! +!! subroutine SPH_MHD_zonal_mean_vizs(viz_step, time_d, & +!! & sph, geofem, nod_fld, zm_psf, m_SR) +!! type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ +!! type(VIZ_step_params), intent(in) :: viz_step +!! type(time_data), intent(in) :: time_d +!! type(sph_grids), intent(in) :: sph +!! type(mesh_data), intent(in) :: geofem +!! type(phys_data), intent(inout) :: nod_fld +!! type(sectioning_module), intent(inout) :: zm_psf +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module t_SPH_MHD_zonal_mean_viz +! + use m_precision +! + use m_machine_parameter + use m_work_time + use calypso_mpi +! + use t_elapsed_labels_4_VIZ + use t_time_data + use t_comm_table + use t_mesh_data + use t_phys_data + use t_map_projection + use t_spheric_parameter + use t_sph_trans_arrays_MHD + use t_cross_section + use t_mesh_SR + use t_VIZ_step_parameter +! + implicit none +! +!> Structures of zonal mean controls + type sph_zonal_mean_viz +!> Structures of zonal mean sectioning controls + type(sectioning_module) :: zm_psf +!> Structures of zonal RMS sectioning controls + type(sectioning_module) :: zrms_psf +! +!> Structures of zonal mean rendering controls + type(map_rendering_module) :: zm_maps +!> Structures of zonal RMS rendering controls + type(map_rendering_module) :: zRMS_maps + end type sph_zonal_mean_viz +! + private :: SPH_MHD_zonal_RMS_vizs +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine init_zonal_mean_vizs(elps_VIZ, viz_step, & + & geofem, edge_comm, nod_fld, zm_ctls, zmeans, m_SR) +! + use t_control_data_dynamo_vizs + use map_projection +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(VIZ_step_params), intent(in) :: viz_step + type(mesh_data), intent(in) :: geofem + type(communication_table), intent(in) :: edge_comm + type(phys_data), intent(in) :: nod_fld +! + type(sph_dynamo_viz_controls), intent(inout) :: zm_ctls + type(sph_zonal_mean_viz), intent(inout) :: zmeans + type(mesh_SR), intent(inout) :: m_SR +! +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+1) + call SECTIONING_initialize & + & (viz_step%PSF_t%increment, elps_VIZ%elps_PSF, & + & geofem, edge_comm, nod_fld, zm_ctls%zm_psf_ctls, & + & zmeans%zm_psf, m_SR%SR_sig, m_SR%SR_il) + call SECTIONING_initialize & + & (viz_step%PSF_t%increment, elps_VIZ%elps_PSF, & + & geofem, edge_comm, nod_fld, zm_ctls%zRMS_psf_ctls, & + & zmeans%zrms_psf, m_SR%SR_sig, m_SR%SR_il) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+1) +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+5) + call MAP_PROJECTION_initialize(viz_step%MAP_t%increment, & + & elps_VIZ%elps_PSF, elps_VIZ%elps_MAP, geofem, edge_comm, & + & nod_fld, zm_ctls%zm_map_ctls, zmeans%zm_maps, & + & m_SR%SR_sig, m_SR%SR_il) + call MAP_PROJECTION_initialize(viz_step%MAP_t%increment, & + & elps_VIZ%elps_PSF, elps_VIZ%elps_MAP, geofem, edge_comm, & + & nod_fld, zm_ctls%zRMS_map_ctls, zmeans%zRMS_maps, & + & m_SR%SR_sig, m_SR%SR_il) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+5) +! + end subroutine init_zonal_mean_vizs +! +! --------------------------------------------------------------------- +! + subroutine SPH_MHD_zmean_vizs(elps_VIZ, viz_step, time_d, & + & sph, geofem, WK, nod_fld, zmeans, m_SR) +! + use FEM_analyzer_sph_MHD + use nod_phys_send_recv +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(VIZ_step_params), intent(in) :: viz_step + type(sph_grids), intent(in) :: sph +! + type(time_data), intent(in) :: time_d + type(mesh_data), intent(in) :: geofem + type(works_4_sph_trans_MHD), intent(in) :: WK +! + type(phys_data), intent(inout) :: nod_fld + type(sph_zonal_mean_viz), intent(inout) :: zmeans + type(mesh_SR), intent(inout) :: m_SR +! +! + call SPH_MHD_zonal_mean_vizs(elps_VIZ, viz_step, time_d, & + & sph, geofem, nod_fld, zmeans%zm_psf, zmeans%zm_maps, m_SR) + call SPH_MHD_zonal_RMS_vizs(elps_VIZ, viz_step, time_d, & + & sph, geofem, WK, nod_fld, zmeans%zrms_psf, zmeans%zRMS_maps, & + & m_SR) +! + end subroutine SPH_MHD_zmean_vizs +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine SPH_MHD_zonal_mean_vizs(elps_VIZ, viz_step, time_d, & + & sph, geofem, nod_fld, zm_psf, zm_maps, m_SR) +! + use sph_rtp_zonal_rms_data + use nod_phys_send_recv + use map_projection +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(VIZ_step_params), intent(in) :: viz_step + type(sph_grids), intent(in) :: sph +! + type(time_data), intent(in) :: time_d + type(mesh_data), intent(in) :: geofem +! + type(phys_data), intent(inout) :: nod_fld + type(sectioning_module), intent(inout) :: zm_psf + type(map_rendering_module), intent(inout) :: zm_maps + type(mesh_SR), intent(inout) :: m_SR +! +! + if((zm_psf%num_psf+zm_maps%num_map) .le. 0) return +! + if (iflag_debug.gt.0) write(*,*) 'zonal_mean_all_rtp_field' + call zonal_mean_all_rtp_field & + & (sph%sph_rtp, geofem%mesh%node, nod_fld) +! + if (iflag_debug.gt.0) write(*,*) 'phys_send_recv_all' + call nod_fields_send_recv(geofem%mesh, nod_fld, & + & m_SR%v_sol, m_SR%SR_sig, m_SR%SR_r) +! + if(zm_psf%num_psf .gt. 0) then + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+2) + if (iflag_debug.gt.0) write(*,*) 'SECTIONING_visualize zmean' + call SECTIONING_visualize & + & (viz_step%istep_psf, elps_VIZ%elps_PSF, & + & time_d, geofem, nod_fld, zm_psf) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+2) + end if +! + if(zm_maps%num_map .gt. 0) then + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+6) + call MAP_PROJECTION_visualize & + & (viz_step%istep_map, elps_VIZ%elps_PSF, elps_VIZ%elps_MAP, & + & time_d,geofem, nod_fld, zm_maps, m_SR%SR_sig) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+6) + end if +! + end subroutine SPH_MHD_zonal_mean_vizs +! +! --------------------------------------------------------------------- +! + subroutine SPH_MHD_zonal_RMS_vizs(elps_VIZ, viz_step, time_d, & + & sph, geofem, WK, nod_fld, zrms_psf, zrms_maps, m_SR) +! + use FEM_analyzer_sph_MHD + use sph_rtp_zonal_rms_data + use nod_phys_send_recv + use map_projection +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(VIZ_step_params), intent(in) :: viz_step + type(sph_grids), intent(in) :: sph +! + type(time_data), intent(in) :: time_d + type(mesh_data), intent(in) :: geofem + type(works_4_sph_trans_MHD), intent(in) :: WK +! + type(phys_data), intent(inout) :: nod_fld + type(sectioning_module), intent(inout) :: zrms_psf + type(map_rendering_module), intent(inout) :: zrms_maps + type(mesh_SR), intent(inout) :: m_SR +! +! + if((zrms_psf%num_psf+zrms_maps%num_map) .le. 0) return +! + if (iflag_debug.gt.0) write(*,*) 'SPH_to_FEM_bridge_MHD' + call SPH_to_FEM_bridge_MHD(sph, WK, geofem, nod_fld) + call zonal_rms_all_rtp_field & + & (sph%sph_rtp, geofem%mesh%node, nod_fld) +! + if (iflag_debug.gt.0) write(*,*) 'phys_send_recv_all' + call nod_fields_send_recv(geofem%mesh, nod_fld, & + & m_SR%v_sol, m_SR%SR_sig, m_SR%SR_r) +! + if(zrms_psf%num_psf .gt. 0) then + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+2) + if (iflag_debug.gt.0) write(*,*) 'SECTIONING_visualize RMS' + call SECTIONING_visualize & + & (viz_step%istep_psf, elps_VIZ%elps_PSF, & + & time_d, geofem, nod_fld, zrms_psf) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+2) + end if +! + if(zrms_maps%num_map .gt. 0) then + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+6) + call MAP_PROJECTION_visualize & + & (viz_step%istep_map, elps_VIZ%elps_PSF, elps_VIZ%elps_MAP, & + & time_d, geofem, nod_fld, zRMS_maps, m_SR%SR_sig) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+6) + end if +! + end subroutine SPH_MHD_zonal_RMS_vizs +! +! --------------------------------------------------------------------- +! + end module t_SPH_MHD_zonal_mean_viz diff --git a/src/Fortran_libraries/MHD_src/sph_MHD/t_sph_MHD_w_vizs.f90 b/src/Fortran_libraries/MHD_src/sph_MHD/t_sph_MHD_w_vizs.f90 new file mode 100644 index 00000000..f0586a2b --- /dev/null +++ b/src/Fortran_libraries/MHD_src/sph_MHD/t_sph_MHD_w_vizs.f90 @@ -0,0 +1,31 @@ +!>@file t_sph_MHD_w_vizs.f90 +!!@brief module t_sph_MHD_w_vizs +!! +!!@author H. Matsui +!!@date Programmed H. Matsui in Apr., 2010 +! +!>@brief Structures for visualizers in spherical MHD dynamo + module t_sph_MHD_w_vizs +! + use m_precision +! + use t_FEM_mesh_field_data + use t_SPH_MHD_zonal_mean_viz + use t_four_visualizers + use t_VIZ_mesh_field +! + implicit none +! +!> Structure for visualization in spherical MHD + type sph_MHD_w_vizs +!> Structure of FEM mesh and field structures + type(FEM_mesh_field_data) :: FEM_DAT +!> Structure of geometry informations for visualization + type(VIZ_mesh_field) :: VIZ_DAT +!> Structure of sectioning and isosurfaceing modules + type(four_visualize_modules) :: VIZ4s +!> Structures of zonal mean controls + type(sph_zonal_mean_viz) :: zmeans + end type sph_MHD_w_vizs +! + end module t_sph_MHD_w_vizs diff --git a/src/Fortran_libraries/PARALLEL_src/COMM_src/Makefile.depends b/src/Fortran_libraries/PARALLEL_src/COMM_src/Makefile.depends index 70751427..c3e01c02 100644 --- a/src/Fortran_libraries/PARALLEL_src/COMM_src/Makefile.depends +++ b/src/Fortran_libraries/PARALLEL_src/COMM_src/Makefile.depends @@ -10,6 +10,8 @@ bcast_control_arrays.o: $(COMMDIR)/bcast_control_arrays.f90 m_precision.o m_cons $(F90) -c $(F90OPTFLAGS) $< bcast_file_IO_parameter.o: $(COMMDIR)/bcast_file_IO_parameter.f90 m_precision.o m_constants.o t_file_IO_parameter.o calypso_mpi_int.o calypso_mpi_char.o transfer_to_long_integers.o calypso_mpi_logical.o $(F90) -c $(F90OPTFLAGS) $< +cal_local_position_by_tetra.o: $(COMMDIR)/cal_local_position_by_tetra.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< calypso_SR.o: $(COMMDIR)/calypso_SR.f90 m_precision.o m_constants.o calypso_mpi.o t_solver_SR.o calypso_SR_core.o set_to_send_buffer.o select_copy_from_recv.o set_to_send_buf_tri.o select_copy_from_recv_tri.o $(F90) -c $(F90OPTFLAGS) $< calypso_SR_2.o: $(COMMDIR)/calypso_SR_2.f90 m_precision.o m_constants.o calypso_mpi.o t_solver_SR.o calypso_SR_core.o set_to_send_buffer.o select_copy_from_recv.o set_to_send_buf_tri.o select_copy_from_recv_tri.o @@ -50,6 +52,8 @@ const_element_comm_tables.o: $(COMMDIR)/const_element_comm_tables.f90 m_precisio $(F90) -c $(F90OPTFLAGS) $< const_global_element_ids.o: $(COMMDIR)/const_global_element_ids.f90 m_precision.o m_constants.o m_machine_parameter.o calypso_mpi.o t_solver_SR.o t_comm_table.o calypso_mpi_int.o t_solver_SR_int8.o solver_SR_type.o t_para_double_numbering.o t_element_double_number.o $(F90) -c $(F90OPTFLAGS) $< +const_surface_comm_table.o: $(COMMDIR)/const_surface_comm_table.f90 m_precision.o calypso_mpi.o t_next_node_ele_4_node.o t_mesh_data.o t_geometry_data.o t_surface_data.o t_comm_table.o t_failed_export_list.o t_mesh_SR.o m_machine_parameter.o m_geometry_constants.o t_para_double_numbering.o t_element_double_number.o t_const_comm_table.o t_sum_local_node_id_list.o const_global_element_ids.o t_work_for_comm_check.o diff_geometory_comm_test.o nod_phys_send_recv.o solver_SR_type.o mesh_send_recv_check.o + $(F90) -c $(F90OPTFLAGS) $< field_to_send_buffer.o: $(COMMDIR)/field_to_send_buffer.f90 m_precision.o $(F90) -c $(F90OPTFLAGS) $< m_elapsed_labels_SEND_RECV.o: $(COMMDIR)/m_elapsed_labels_SEND_RECV.f90 m_precision.o m_work_time.o @@ -118,6 +122,8 @@ t_mesh_SR.o: $(COMMDIR)/t_mesh_SR.f90 m_precision.o t_solver_SR.o t_solver_SR_in $(F90) -c $(F90OPTFLAGS) $< t_para_double_numbering.o: $(COMMDIR)/t_para_double_numbering.f90 m_precision.o m_constants.o calypso_mpi.o t_solver_SR.o t_solver_SR_int.o t_geometry_data.o t_comm_table.o solver_SR_type.o find_belonged_process.o $(F90) -c $(F90OPTFLAGS) $< +t_parallel_surface_indices.o: $(COMMDIR)/t_parallel_surface_indices.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o t_mesh_data.o t_comm_table.o t_mesh_SR.o t_para_double_numbering.o t_geometry_data.o t_surface_data.o reverse_SR_int.o solver_SR_type.o + $(F90) -c $(F90OPTFLAGS) $< t_solver_SR.o: $(COMMDIR)/t_solver_SR.f90 m_precision.o calypso_mpi.o $(F90) -c $(F90OPTFLAGS) $< t_solver_SR_int.o: $(COMMDIR)/t_solver_SR_int.f90 m_precision.o calypso_mpi.o t_solver_SR.o diff --git a/src/Fortran_libraries/PARALLEL_src/COMM_src/cal_local_position_by_tetra.f90 b/src/Fortran_libraries/PARALLEL_src/COMM_src/cal_local_position_by_tetra.f90 new file mode 100644 index 00000000..1be7b975 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/COMM_src/cal_local_position_by_tetra.f90 @@ -0,0 +1,157 @@ +! +! module cal_local_position_by_tetra +! +! Written by H. Matsui on Aug., 2006 +! +! subroutine s_cal_local_position_by_tetra(nnod_4_ele_l, xi, & +! & coefs_by_tet) +! + module cal_local_position_by_tetra +! + use m_precision +! + implicit none +! + private :: cal_position_in_ele, cal_position_in_ele_quad + private :: cal_position_in_ele_lag +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_local_position_by_tetra(nnod_4_ele_l, xi, & + & coefs_by_tet) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: nnod_4_ele_l + real(kind = kreal), intent(in) :: coefs_by_tet(nnod_4_ele_l) + real(kind = kreal), intent(inout) :: xi(3) +! +! + if (nnod_4_ele_l .eq. num_t_linear) then + call cal_position_in_ele(xi, coefs_by_tet) + else if (nnod_4_ele_l .eq. num_t_quad) then + call cal_position_in_ele_quad(xi, coefs_by_tet) + else if (nnod_4_ele_l .eq. num_t_lag) then + call cal_position_in_ele_lag(xi, coefs_by_tet) + end if +! + end subroutine s_cal_local_position_by_tetra +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_position_in_ele(xi, coefs_by_tet) +! + real(kind = kreal), intent(in) :: coefs_by_tet(8) + real(kind = kreal), intent(inout) :: xi(3) +! +! + xi(1) =- coefs_by_tet(1) + coefs_by_tet(2) & + & + coefs_by_tet(3) - coefs_by_tet(4) & + & - coefs_by_tet(5) + coefs_by_tet(6) & + & + coefs_by_tet(7) - coefs_by_tet(8) +! + xi(2) =- coefs_by_tet(1) - coefs_by_tet(2) & + & + coefs_by_tet(3) + coefs_by_tet(4) & + & - coefs_by_tet(5) - coefs_by_tet(6) & + & + coefs_by_tet(7) + coefs_by_tet(8) +! + xi(3) =- coefs_by_tet(1) - coefs_by_tet(2) & + & - coefs_by_tet(3) - coefs_by_tet(4) & + & + coefs_by_tet(5) + coefs_by_tet(6) & + & + coefs_by_tet(7) + coefs_by_tet(8) +! + end subroutine cal_position_in_ele +! +!----------------------------------------------------------------------- +! + subroutine cal_position_in_ele_quad(xi, coefs_by_tet) +! + real(kind = kreal), intent(in) :: coefs_by_tet(20) + real(kind = kreal), intent(inout) :: xi(3) +! +! + xi(1) =- coefs_by_tet( 1) + coefs_by_tet( 2) & + & + coefs_by_tet( 3) - coefs_by_tet( 4) & + & - coefs_by_tet( 5) + coefs_by_tet( 6) & + & + coefs_by_tet( 7) - coefs_by_tet( 8) & + & + coefs_by_tet(10) & + & - coefs_by_tet(12) & + & + coefs_by_tet(14) & + & - coefs_by_tet(16) & + & - coefs_by_tet(17) + coefs_by_tet(18) & + & + coefs_by_tet(19) - coefs_by_tet(20) +! + xi(2) =- coefs_by_tet( 1) - coefs_by_tet( 2) & + & + coefs_by_tet( 3) + coefs_by_tet( 4) & + & - coefs_by_tet( 5) - coefs_by_tet( 6) & + & + coefs_by_tet( 7) + coefs_by_tet( 8) & + & - coefs_by_tet( 9) & + & + coefs_by_tet(11) & + & - coefs_by_tet(13) & + & + coefs_by_tet(15) & + & - coefs_by_tet(17) - coefs_by_tet(18) & + & + coefs_by_tet(19) + coefs_by_tet(20) +! + xi(3) =- coefs_by_tet( 1) - coefs_by_tet( 2) & + & - coefs_by_tet( 3) - coefs_by_tet( 4) & + & + coefs_by_tet( 5) + coefs_by_tet( 6) & + & + coefs_by_tet( 7) + coefs_by_tet( 8) & + & - coefs_by_tet( 9) - coefs_by_tet(10) & + & - coefs_by_tet(11) - coefs_by_tet(12) & + & + coefs_by_tet(13) + coefs_by_tet(14) & + & + coefs_by_tet(15) + coefs_by_tet(16) +! + end subroutine cal_position_in_ele_quad +! +!----------------------------------------------------------------------- +! + subroutine cal_position_in_ele_lag(xi, coefs_by_tet) +! + real(kind = kreal), intent(in) :: coefs_by_tet(27) + real(kind = kreal), intent(inout) :: xi(3) +! +! + xi(1) =- coefs_by_tet( 1) + coefs_by_tet( 2) & + & + coefs_by_tet( 3) - coefs_by_tet( 4) & + & - coefs_by_tet( 5) + coefs_by_tet( 6) & + & + coefs_by_tet( 7) - coefs_by_tet( 8) & + & + coefs_by_tet(10) & + & - coefs_by_tet(12) & + & + coefs_by_tet(14) & + & - coefs_by_tet(16) & + & - coefs_by_tet(17) + coefs_by_tet(18) & + & + coefs_by_tet(19) - coefs_by_tet(20) & + & - coefs_by_tet(21) + coefs_by_tet(22) +! + xi(2) =- coefs_by_tet( 1) - coefs_by_tet( 2) & + & + coefs_by_tet( 3) + coefs_by_tet( 4) & + & - coefs_by_tet( 5) - coefs_by_tet( 6) & + & + coefs_by_tet( 7) + coefs_by_tet( 8) & + & - coefs_by_tet( 9) & + & + coefs_by_tet(11) & + & - coefs_by_tet(13) & + & + coefs_by_tet(15) & + & - coefs_by_tet(17) - coefs_by_tet(18) & + & + coefs_by_tet(19) + coefs_by_tet(20) & + & - coefs_by_tet(23) + coefs_by_tet(24) +! + xi(3) =- coefs_by_tet( 1) - coefs_by_tet( 2) & + & - coefs_by_tet( 3) - coefs_by_tet( 4) & + & + coefs_by_tet( 5) + coefs_by_tet( 6) & + & + coefs_by_tet( 7) + coefs_by_tet( 8) & + & - coefs_by_tet( 9) - coefs_by_tet(10) & + & - coefs_by_tet(11) - coefs_by_tet(12) & + & + coefs_by_tet(13) + coefs_by_tet(14) & + & + coefs_by_tet(15) + coefs_by_tet(16) & + & - coefs_by_tet(25) + coefs_by_tet(26) +! + end subroutine cal_position_in_ele_lag +! +!----------------------------------------------------------------------- +! + end module cal_local_position_by_tetra diff --git a/src/Fortran_libraries/PARALLEL_src/COMM_src/const_surface_comm_table.f90 b/src/Fortran_libraries/PARALLEL_src/COMM_src/const_surface_comm_table.f90 new file mode 100644 index 00000000..25bf7c59 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/COMM_src/const_surface_comm_table.f90 @@ -0,0 +1,179 @@ +!>@file const_surface_comm_table.f90 +!!@brief module const_surface_comm_table +!! +!!@author H. Matsui +!!@date Programmed in June, 2015 +! +!> @brief Belonged element list for each node +!! +!!@verbatim +!! subroutine const_surf_comm_table & +!! & (node, nod_comm, surf_comm, surf, m_SR) +!! subroutine dealloc_surf_comm_table(surf_comm, surf) +!! type(node_data), intent(in) :: node +!! type(communication_table), intent(in) :: nod_comm +!! type(communication_table), intent(inout) :: surf_comm +!! type(surface_data), intent(inout) :: surf +!! type(mesh_SR), intent(inout) :: m_SR +!! +!! subroutine surf_send_recv_test & +!! & (surf, surf_comm, surf_check, SR_sig, SR_r) +!! type(node_data), intent(in) :: node +!! type(surface_data), intent(in) :: surf +!! type(communication_table), intent(in) :: surf_comm +!! type(work_for_comm_check), intent(inout) :: surf_check +!! type(send_recv_status), intent(inout) :: SR_sig +!! type(send_recv_real_buffer), intent(inout) :: SR_r +!!@endverbatim +! + module const_surface_comm_table +! + use m_precision + use calypso_mpi + use t_next_node_ele_4_node + use t_mesh_data + use t_geometry_data + use t_surface_data + use t_comm_table + use t_failed_export_list + use t_mesh_SR +! + use m_machine_parameter + use m_geometry_constants +! + implicit none +! + character(len=kchara), parameter :: txt_surf = 'surface' +! + private :: txt_surf +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine const_surf_comm_table & + & (node, nod_comm, surf_comm, surf, m_SR) +! + use t_para_double_numbering + use t_element_double_number + use t_const_comm_table + use t_sum_local_node_id_list + use const_global_element_ids +! + type(node_data), intent(in) :: node + type(communication_table), intent(in) :: nod_comm +! + type(surface_data), intent(inout) :: surf + type(communication_table), intent(inout) :: surf_comm + type(mesh_SR), intent(inout) :: m_SR +! + type(node_ele_double_number) :: inod_dbl + type(element_double_number) :: isurf_dbl + type(element_around_node) :: neib_surf + type(failed_table) :: fail_tbl_s + type(sum_of_local_id_list) :: sum_list_s +! + integer(kind = kint) :: internal_num = 0 + integer(kind = kint_gl), allocatable :: istack_inersurf(:) +! +! + call dealloc_interior_surf(surf) + call alloc_global_surf_id(surf) + call alloc_interior_surf(surf) +! + call alloc_double_numbering(node%numnod, inod_dbl) + call set_node_double_numbering(node, nod_comm, inod_dbl, & + & m_SR%SR_sig, m_SR%SR_i) +! + call alloc_ele_double_number(surf%numsurf, isurf_dbl) + call find_belonged_pe_4_surf(my_rank, inod_dbl, & + & surf%numsurf, surf%nnod_4_surf, surf%ie_surf, & + & internal_num, surf%interior_surf, isurf_dbl) +! + call set_surf_id_4_node_sum_order(node, surf, inod_dbl, & + & neib_surf, sum_list_s) +! + call alloc_failed_export(0, fail_tbl_s) + call const_comm_table_by_connenct & + & (txt_surf, surf%numsurf, surf%nnod_4_surf, surf%ie_surf, & + & surf%x_surf, node, nod_comm, inod_dbl, isurf_dbl, neib_surf, & + & sum_list_s, surf_comm, fail_tbl_s, m_SR%SR_sig) + call dealloc_iele_belonged(neib_surf) + call dealloc_failed_export(fail_tbl_s) +! + allocate(istack_inersurf(0:nprocs)) + istack_inersurf(0:nprocs) = 0 +! + call count_number_of_node_stack(internal_num, istack_inersurf) + call set_global_ele_id(txt_surf, surf%numsurf, istack_inersurf, & + & surf%interior_surf, surf_comm, surf%isurf_global, & + & m_SR%SR_sig, m_SR%SR_il) + deallocate(istack_inersurf) +! + call calypso_mpi_barrier + call check_element_position & + & (txt_surf, node%inod_global, surf%numsurf, & + & surf%nnod_4_surf, surf%ie_surf, surf%isurf_global, & + & surf%x_surf, inod_dbl, surf_comm, m_SR%SR_sig, m_SR%SR_r) + call dealloc_sum_of_local_id_list(sum_list_s) + call dealloc_ele_double_number(isurf_dbl) + call dealloc_double_numbering(inod_dbl) +! + end subroutine const_surf_comm_table +! +!----------------------------------------------------------------------- +! + subroutine dealloc_surf_comm_table(surf_comm, surf) +! + type(communication_table), intent(inout) :: surf_comm + type(surface_data), intent(inout) :: surf +! + call dealloc_comm_table(surf_comm) + call dealloc_interior_surf(surf) + call dealloc_global_surf_id(surf) +! + end subroutine dealloc_surf_comm_table +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine surf_send_recv_test & + & (surf, surf_comm, surf_check, SR_sig, SR_r) +! + use t_work_for_comm_check + use diff_geometory_comm_test + use nod_phys_send_recv + use solver_SR_type + use mesh_send_recv_check +! + type(surface_data), intent(in) :: surf + type(communication_table), intent(in) :: surf_comm +! + type(work_for_comm_check), intent(inout) :: surf_check + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r +! +! + call alloc_geom_4_comm_test(surf%numsurf, surf_check) + call set_element_4_comm_test(surf%numsurf, surf%interior_surf, & + & surf%x_surf, surf_check%xx_test) + call SOLVER_SEND_RECV_3_type(surf%numsurf, surf_comm, & + & SR_sig, SR_r, surf_check%xx_test) +! + call ele_send_recv_check & + & (surf%numsurf, surf%isurf_global, surf%x_surf, surf_check) +! + if(i_debug .gt. 0) write(*,*) my_rank, & + & 'Failed communication for surface', surf_check%num_diff + call collect_failed_comm(surf_check) + if(my_rank .eq. 0) write(*,*) my_rank, & + & 'Total Failed communication for surface', & + & surf_check%istack_diff_pe(nprocs) +! + end subroutine surf_send_recv_test +! +! ---------------------------------------------------------------------- +! + end module const_surface_comm_table diff --git a/src/Fortran_libraries/PARALLEL_src/COMM_src/t_parallel_surface_indices.f90 b/src/Fortran_libraries/PARALLEL_src/COMM_src/t_parallel_surface_indices.f90 new file mode 100644 index 00000000..9ad775fa --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/COMM_src/t_parallel_surface_indices.f90 @@ -0,0 +1,249 @@ +!>@file t_parallel_surface_indices.f90 +!!@brief module t_parallel_surface_indices +!! +!!@author H. Matsui +!!@date Programmed in June, 2006 +! +!>@brief Data structuresa for visualizers +!! +!!@verbatim +!! subroutine init_para_surf_indices(mesh, ele_comm, surf_comm, & +!! & iele_dbl, isurf_dbl, & +!! & para_surf, m_SR) +!! subroutine dealloc_para_surf_indices(para_surf) +!! type(mesh_geometry), intent(in) :: mesh +!! type(communication_table), intent(in) :: ele_comm +!! type(communication_table), intent(in) :: surf_comm +!! type(node_ele_double_number), intent(in) :: iele_dbl +!! type(node_ele_double_number), intent(in) :: isurf_dbl +!! type(paralell_surface_indices), intent(inout) :: para_surf +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module t_parallel_surface_indices +! + use m_precision + use m_machine_parameter + use m_geometry_constants +! + use t_mesh_data + use t_comm_table + use t_mesh_SR + use t_para_double_numbering +! +!> Structure of data for visualization + type paralell_surface_indices + integer(kind = kint), allocatable :: isf_4_ele_dbl(:,:,:) + integer(kind = kint), allocatable :: iele_4_surf_dbl(:,:,:) + end type paralell_surface_indices +! + private :: alloc_para_surf_indices + private :: set_iele_4_surf_double_index + private :: set_isf_4_ele_double_index +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine init_para_surf_indices(mesh, ele_comm, surf_comm, & + & iele_dbl, isurf_dbl, & + & para_surf, m_SR) +! + type(mesh_geometry), intent(in) :: mesh + type(communication_table), intent(in) :: ele_comm + type(communication_table), intent(in) :: surf_comm + type(node_ele_double_number), intent(in) :: iele_dbl + type(node_ele_double_number), intent(in) :: isurf_dbl +! + type(paralell_surface_indices), intent(inout) :: para_surf + type(mesh_SR), intent(inout) :: m_SR +! +! + call alloc_para_surf_indices(mesh%ele, mesh%surf, para_surf) + call set_isf_4_ele_double_index(mesh%ele, mesh%surf, & + & isurf_dbl, ele_comm, para_surf%isf_4_ele_dbl, m_SR) + call set_iele_4_surf_double_index(mesh%surf, iele_dbl, surf_comm, & + & para_surf%iele_4_surf_dbl, m_SR) +! + end subroutine init_para_surf_indices +! +! ---------------------------------------------------------------------- +! + subroutine dealloc_para_surf_indices(para_surf) + type(paralell_surface_indices), intent(inout) :: para_surf +! + deallocate(para_surf%isf_4_ele_dbl, para_surf%iele_4_surf_dbl) +! + end subroutine dealloc_para_surf_indices +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine alloc_para_surf_indices(ele, surf, para_surf) +! + use t_geometry_data + use t_surface_data +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(paralell_surface_indices), intent(inout) :: para_surf +! + allocate(para_surf%isf_4_ele_dbl(ele%numele,nsurf_4_ele,2)) + allocate(para_surf%iele_4_surf_dbl(surf%numsurf,2,3)) +! + if(ele%numele .gt. 0) then +!$omp parallel workshare + para_surf%isf_4_ele_dbl = 0 +!$omp end parallel workshare + end if + if(surf%numsurf .gt. 0) then +!$omp parallel workshare + para_surf%iele_4_surf_dbl = 0 +!$omp end parallel workshare + end if +! + end subroutine alloc_para_surf_indices +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine set_iele_4_surf_double_index & + & (surf, iele_dbl, surf_comm, iele_4_surf_dbl, m_SR) +! + use m_geometry_constants + use reverse_SR_int + use solver_SR_type +! + type(surface_data), intent(in) :: surf + type(node_ele_double_number), intent(in) :: iele_dbl + type(communication_table), intent(in) :: surf_comm +! + integer(kind = kint), intent(inout) & + & :: iele_4_surf_dbl(surf%numsurf,2,3) + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: isurf, iele, inum, k1, k2, ip, ist, ied + integer(kind = kint), allocatable :: iflag_backside(:) + integer(kind = kint), allocatable :: iflag_backside_check(:,:,:) +! +! +!$omp parallel do private(isurf,iele) + do isurf = 1, surf%numsurf + iele = surf%iele_4_surf(isurf,1,1) + iele_4_surf_dbl(isurf,1,1) = iele_dbl%irank(iele) + iele_4_surf_dbl(isurf,1,2) = iele_dbl%index(iele) + iele_4_surf_dbl(isurf,1,3) = surf%iele_4_surf(isurf,1,2) + iele = surf%iele_4_surf(isurf,2,1) + iele_4_surf_dbl(isurf,2,1) = iele_dbl%irank(iele) + iele_4_surf_dbl(isurf,2,2) = iele_dbl%index(iele) + iele_4_surf_dbl(isurf,2,3) = surf%iele_4_surf(isurf,2,2) + end do +!$omp end parallel do +! + + allocate(iflag_backside(surf_comm%ntot_import)) + allocate(iflag_backside_check(surf_comm%ntot_export,2,3)) +! + do k2 = 1, 3 + do k1 = 1, 2 + do inum = 1, surf_comm%ntot_import + isurf = surf_comm%item_import(inum) + iflag_backside(inum) = iele_4_surf_dbl(isurf,k1,k2) + end do + + call comm_items_send_recv & + & (surf_comm%num_neib, surf_comm%id_neib, & + & surf_comm%istack_import, iflag_backside(1), & + & surf_comm%num_neib, surf_comm%id_neib, & + & surf_comm%istack_export, izero, & + & iflag_backside_check(1,k1,k2), m_SR%SR_sig) + end do + end do + + do ip = 1, surf_comm%num_neib + ist = surf_comm%istack_export(ip-1) + 1 + ied = surf_comm%istack_export(ip) + do inum = ist, ied + isurf = surf_comm%item_export(inum) + if(iele_4_surf_dbl(isurf,2,3) .eq. 0 & + & .and. iflag_backside_check(inum,2,3) .gt. 0) then + if( iele_4_surf_dbl(isurf,1,1) & + & .eq. iflag_backside_check(inum,1,1) & + & .and. iele_4_surf_dbl(isurf,1,2) & + & .eq. iflag_backside_check(inum,1,2) & + & .and. iele_4_surf_dbl(isurf,1,3) & + & .eq. iflag_backside_check(inum,1,3)) then + iele_4_surf_dbl(isurf,2,1:3) & + & = iflag_backside_check(inum,2,1:3) + else + iele_4_surf_dbl(isurf,2,1:3) & + & = iflag_backside_check(inum,1,1:3) + end if + end if + end do + end do +! + deallocate(iflag_backside) + deallocate(iflag_backside_check) +! + call SOLVER_SEND_RECV_int_type(surf%numsurf, surf_comm, & + & m_SR%SR_sig, m_SR%SR_i, iele_4_surf_dbl(1,1,1)) + call SOLVER_SEND_RECV_int_type(surf%numsurf, surf_comm, & + & m_SR%SR_sig, m_SR%SR_i, iele_4_surf_dbl(1,1,2)) + call SOLVER_SEND_RECV_int_type(surf%numsurf, surf_comm, & + & m_SR%SR_sig, m_SR%SR_i, iele_4_surf_dbl(1,1,3)) + call SOLVER_SEND_RECV_int_type(surf%numsurf, surf_comm, & + & m_SR%SR_sig, m_SR%SR_i, iele_4_surf_dbl(1,2,1)) + call SOLVER_SEND_RECV_int_type(surf%numsurf, surf_comm, & + & m_SR%SR_sig, m_SR%SR_i, iele_4_surf_dbl(1,2,2)) + call SOLVER_SEND_RECV_int_type(surf%numsurf, surf_comm, & + & m_SR%SR_sig, m_SR%SR_i, iele_4_surf_dbl(1,2,3)) +! + end subroutine set_iele_4_surf_double_index +! +! --------------------------------------------------------------------- +! + subroutine set_isf_4_ele_double_index & + & (ele, surf, isurf_dbl, ele_comm, isf_4_ele_dbl, m_SR) +! + use solver_SR_type +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(node_ele_double_number), intent(in) :: isurf_dbl + type(communication_table), intent(in) :: ele_comm +! + integer(kind = kint), intent(inout) & + & :: isf_4_ele_dbl(ele%numele,nsurf_4_ele,2) + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: isurf, iele, k1 +! +! + do k1 = 1, nsurf_4_ele +!$omp parallel do private(isurf,iele) + do iele = 1, ele%numele + isurf = abs(surf%isf_4_ele(iele,k1)) + + isf_4_ele_dbl(iele,k1,1) = isurf_dbl%irank(isurf) + isf_4_ele_dbl(iele,k1,2) = isurf_dbl%index(isurf) & + & * (surf%isf_4_ele(iele,k1) / isurf) + + end do +!$omp end parallel do + end do +! + do k1 = 1, nsurf_4_ele + call SOLVER_SEND_RECV_int_type(ele%numele, ele_comm, & + & m_SR%SR_sig, m_SR%SR_i, isf_4_ele_dbl(1,k1,1)) + call SOLVER_SEND_RECV_int_type(ele%numele, ele_comm, & + & m_SR%SR_sig, m_SR%SR_i, isf_4_ele_dbl(1,k1,2)) + end do +! + end subroutine set_isf_4_ele_double_index +! +! --------------------------------------------------------------------- +! + end module t_parallel_surface_indices diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/Makefile b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/Makefile new file mode 100644 index 00000000..b35931e3 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/Makefile @@ -0,0 +1,33 @@ +# +# +# + +INTERPOLATE_DIR = $$(PARA_SRCDIR)/INTERPOLATE +SOURCES = $(shell ls *.f90) +MOD_INTERPOLATE = $(addsuffix .o,$(basename $(SOURCES)) ) + +# +# ------------------------------------------------------------------------- +# + +dir_list: + @echo 'INTERPOLATE_DIR = $(INTERPOLATE_DIR)' >> $(MAKENAME) + +libtarget: + +lib_archve: libtarget + @echo ' $$(AR) $$(ARFLUGS) rcsv $$@ $$(MOD_INTERPOLATE)' >> $(MAKENAME) + +mod_list: + @echo MOD_INTERPOLATE= \\ >> $(MAKENAME) + @echo $(MOD_INTERPOLATE) >> $(MAKENAME) + @echo '#' >> $(MAKENAME) + +module: + @cat Makefile.depends >> $(MAKENAME) + +depends: + @$(MAKE_MOD_DEP) Makefile.depends '$$(INTERPOLATE_DIR)' $(SOURCES) + +clean: + rm -f *.o *.mod *~ *.par *.diag *.a diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/Makefile.depends b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/Makefile.depends new file mode 100644 index 00000000..777d18a6 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/Makefile.depends @@ -0,0 +1,21 @@ +cal_position_and_grad.o: $(INTERPOLATE_DIR)/cal_position_and_grad.f90 m_precision.o m_constants.o m_geometry_constants.o cal_shape_function_3d.o interpolate_position_in_ele.o cal_shape_function_2d.o cal_shape_function_1d.o + $(F90) -c $(F90OPTFLAGS) $< +interpolate_position_in_ele.o: $(INTERPOLATE_DIR)/interpolate_position_in_ele.f90 m_precision.o + $(F90) -c $(F90OPTFLAGS) $< +interpolate_scalar_ele20.o: $(INTERPOLATE_DIR)/interpolate_scalar_ele20.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +interpolate_scalar_ele27.o: $(INTERPOLATE_DIR)/interpolate_scalar_ele27.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +interpolate_scalar_ele8.o: $(INTERPOLATE_DIR)/interpolate_scalar_ele8.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +modify_local_positions.o: $(INTERPOLATE_DIR)/modify_local_positions.f90 m_precision.o solver_33_array.o cal_position_and_grad.o + $(F90) -c $(F90OPTFLAGS) $< +sel_interpolate_scalar.o: $(INTERPOLATE_DIR)/sel_interpolate_scalar.f90 m_precision.o m_geometry_constants.o interpolate_scalar_ele8.o interpolate_scalar_ele20.o interpolate_scalar_ele27.o + $(F90) -c $(F90OPTFLAGS) $< +t_find_interpolate_in_ele.o: $(INTERPOLATE_DIR)/t_find_interpolate_in_ele.f90 m_precision.o m_constants.o m_connect_hexa_2_tetra.o cal_local_position_by_tetra.o modify_local_positions.o solver_33_array.o t_geometry_data.o t_interpolate_coefs_dest.o + $(F90) -c $(F90OPTFLAGS) $< +t_interpolate_coefs_dest.o: $(INTERPOLATE_DIR)/t_interpolate_coefs_dest.f90 m_precision.o t_interpolate_tbl_dest.o + $(F90) -c $(F90OPTFLAGS) $< +t_interpolate_tbl_dest.o: $(INTERPOLATE_DIR)/t_interpolate_tbl_dest.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< + diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/cal_position_and_grad.f90 b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/cal_position_and_grad.f90 new file mode 100644 index 00000000..e1e3aaa8 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/cal_position_and_grad.f90 @@ -0,0 +1,338 @@ +!>@file cal_position_and_grad.f90 +!!@brief module cal_position_and_grad +!! +!!@date Programmed by H.Matsui in Aug. 2011 +! +!>@brief find point in one element and return local coordinate +!! +!!@verbatim +!! subroutine cal_position_and_grad_surf(nnod_sf, xx_z, dnxi, dnei,& +!! & x_local_ele, xi) +!! subroutine cal_position_and_grad_edge(nnod_ed, xx_z, dnxi, & +!! & x_local_ele, xi) +!!@endverbatim +! + module cal_position_and_grad +! + use m_precision +! + use m_constants + use m_geometry_constants +! + implicit none +! + private :: cal_position_and_grad_8, cal_position_and_grad_20 + private :: cal_position_and_grad_27 + private :: cal_position_and_grad_4, cal_position_and_grad_sf8 + private :: cal_position_and_grad_9 + private :: cal_position_and_grad_2, cal_position_and_grad_3 +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine cal_position_and_gradient(nnod_ele, xx_z, & + & dnxi, dnei, dnzi, x_local_ele, xi) +! + integer (kind = kint), intent(in) :: nnod_ele + real(kind = kreal), intent(in) :: x_local_ele(nnod_ele,3) + real(kind = kreal), intent(in) :: xi(3) +! + real(kind=kreal), intent(inout) :: xx_z(3) + real(kind=kreal), intent(inout) :: dnxi(3), dnei(3), dnzi(3) +! +! + if (nnod_ele .eq. num_t_linear) then + call cal_position_and_grad_8(xx_z, dnxi, dnei, dnzi, & + & x_local_ele, xi) + else if (nnod_ele .eq. num_t_quad) then + call cal_position_and_grad_20(xx_z, dnxi, dnei, dnzi, & + & x_local_ele, xi) + else if (nnod_ele .eq. num_t_lag) then + call cal_position_and_grad_27(xx_z, dnxi, dnei, dnzi, & + & x_local_ele, xi) + end if +! + end subroutine cal_position_and_gradient +! +!----------------------------------------------------------------------- +! + subroutine cal_position_and_grad_surf(nnod_sf, xx_z, dnxi, dnei, & + & x_local_ele, xi) +! + integer (kind = kint), intent(in) :: nnod_sf + real(kind = kreal), intent(in) :: x_local_ele(nnod_sf,3) + real(kind = kreal), intent(in) :: xi(2) +! + real(kind=kreal), intent(inout) :: xx_z(3), dnxi(3), dnei(3) +! +! + if (nnod_sf .eq. num_linear_sf) then + call cal_position_and_grad_4(xx_z, dnxi, dnei, x_local_ele, xi) + else if (nnod_sf .eq. num_quad_sf) then + call cal_position_and_grad_sf8(xx_z, dnxi, dnei, x_local_ele, xi) + else if (nnod_sf .eq. num_lag_sf) then + call cal_position_and_grad_9(xx_z, dnxi, dnei, x_local_ele, xi) + end if +! + end subroutine cal_position_and_grad_surf +! +! +!----------------------------------------------------------------------- +! + subroutine cal_position_and_grad_edge(nnod_ed, xx_z, dnxi, & + & x_local_ele, xi) +! + integer (kind = kint), intent(in) :: nnod_ed + real(kind = kreal), intent(in) :: x_local_ele(nnod_ed,3) + real(kind = kreal), intent(in) :: xi(1) +! + real(kind=kreal), intent(inout) :: xx_z(3), dnxi(3) +! +! + if (nnod_ed .eq. num_linear_edge) then + call cal_position_and_grad_2(xx_z, dnxi, x_local_ele, xi) + else if (nnod_ed .eq. num_quad_edge) then + call cal_position_and_grad_3(xx_z, dnxi, x_local_ele, xi) + end if +! + end subroutine cal_position_and_grad_edge +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_position_and_grad_8(xx_z, dnxi, dnei, dnzi, & + & x_local_ele, xi) +! + use cal_shape_function_3d + use interpolate_position_in_ele +! + real(kind = kreal), intent(in) :: x_local_ele(8,3) + real(kind = kreal), intent(in) :: xi(3) +! + real(kind=kreal), intent(inout) :: xx_z(3) + real(kind=kreal), intent(inout) :: dnxi(3), dnei(3), dnzi(3) +! + real(kind=kreal) :: an_l(8,1) + real(kind=kreal) :: dnxi_l(8,1), dnei_l(8,1), dnzi_l(8,1) +! +! + call s_cal_shape_function_linear(ione, an_l, dnxi_l, & + & dnei_l, dnzi_l, xi(1), xi(2), xi(3) ) + call interporate_one_position_linear(xx_z, x_local_ele, & + & an_l(1,1) ) + call interporate_one_position_linear(dnxi, x_local_ele, & + & dnxi_l(1,1) ) + call interporate_one_position_linear(dnei, x_local_ele, & + & dnei_l(1,1) ) + call interporate_one_position_linear(dnzi, x_local_ele, & + & dnzi_l(1,1) ) +! + end subroutine cal_position_and_grad_8 +! +!----------------------------------------------------------------------- +! + subroutine cal_position_and_grad_20(xx_z, dnxi, dnei, dnzi, & + & x_local_ele, xi) +! + use cal_shape_function_3d + use interpolate_position_in_ele +! + real(kind = kreal), intent(in) :: x_local_ele(20,3) + real(kind = kreal), intent(in) :: xi(3) +! + real(kind=kreal), intent(inout) :: xx_z(3) + real(kind=kreal), intent(inout) :: dnxi(3), dnei(3), dnzi(3) +! + real(kind=kreal) :: an_l(20,1) + real(kind=kreal) :: dnxi_l(20,1), dnei_l(20,1), dnzi_l(20,1) +! +! + call s_cal_shape_function_quad(ione, an_l, dnxi_l, & + & dnei_l, dnzi_l, xi(1), xi(2), xi(3) ) + call interporate_one_position_quad(xx_z, x_local_ele, & + & an_l(1,1) ) + call interporate_one_position_quad(dnxi, x_local_ele, & + & dnxi_l(1,1) ) + call interporate_one_position_quad(dnei, x_local_ele, & + & dnei_l(1,1) ) + call interporate_one_position_quad(dnzi, x_local_ele, & + & dnzi_l(1,1) ) +! + end subroutine cal_position_and_grad_20 +! +!----------------------------------------------------------------------- +! + subroutine cal_position_and_grad_27(xx_z, dnxi, dnei, dnzi, & + & x_local_ele, xi) +! + use cal_shape_function_3d + use interpolate_position_in_ele +! + real(kind = kreal), intent(in) :: x_local_ele(27,3) + real(kind = kreal), intent(in) :: xi(3) +! + real(kind=kreal), intent(inout) :: xx_z(3) + real(kind=kreal), intent(inout) :: dnxi(3), dnei(3), dnzi(3) +! + real(kind=kreal) :: an_l(27,1) + real(kind=kreal) :: dnxi_l(27,1), dnei_l(27,1), dnzi_l(27,1) +! +! + call s_cal_shape_function_lag(ione, an_l, dnxi_l, & + & dnei_l, dnzi_l, xi(1), xi(2), xi(3) ) + call interporate_one_position_lag(xx_z, x_local_ele, & + & an_l(1,1) ) + call interporate_one_position_lag(dnxi, x_local_ele, & + & dnxi_l(1,1) ) + call interporate_one_position_lag(dnei, x_local_ele, & + & dnei_l(1,1) ) + call interporate_one_position_lag(dnzi, x_local_ele, & + & dnzi_l(1,1) ) +! + end subroutine cal_position_and_grad_27 +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_position_and_grad_4(xx_z, dnxi, dnei, & + & x_local_ele, xi) +! + use cal_shape_function_2d + use interpolate_position_in_ele +! + real(kind = kreal), intent(in) :: x_local_ele(num_linear_sf,3) + real(kind = kreal), intent(in) :: xi(2) +! + real(kind=kreal), intent(inout) :: xx_z(3) + real(kind=kreal), intent(inout) :: dnxi(3), dnei(3) +! + real(kind=kreal) :: an_sf(num_linear_sf,1) + real(kind=kreal) :: dnxi_sf1(num_linear_sf,1) + real(kind=kreal) :: dnei_sf1(num_linear_sf,1) +! +! + call s_cal_shape_function_2d_linear(ione, an_sf, dnxi_sf1, & + & dnei_sf1, xi(1), xi(2) ) + call interporate_one_position_by_4(xx_z, x_local_ele, & + & an_sf(1,1) ) + call interporate_one_position_by_4(dnxi, x_local_ele, & + & dnxi_sf1(1,1) ) + call interporate_one_position_by_4(dnei, x_local_ele, & + & dnei_sf1(1,1) ) +! + end subroutine cal_position_and_grad_4 +! +!----------------------------------------------------------------------- +! + subroutine cal_position_and_grad_sf8(xx_z, dnxi, dnei, & + & x_local_ele, xi) +! + use cal_shape_function_2d + use interpolate_position_in_ele +! + real(kind = kreal), intent(in) :: x_local_ele(num_quad_sf,3) + real(kind = kreal), intent(in) :: xi(2) +! + real(kind=kreal), intent(inout) :: xx_z(3) + real(kind=kreal), intent(inout) :: dnxi(3), dnei(3) +! + real(kind=kreal) :: an_sf(num_quad_sf,1) + real(kind=kreal) :: dnxi_sf8(num_quad_sf,1) + real(kind=kreal) :: dnei_sf8(num_quad_sf,1) +! +! + call s_cal_shape_function_2d_quad(ione, an_sf, dnxi_sf8, & + & dnei_sf8, xi(1), xi(2) ) + call interporate_one_position_linear(xx_z, x_local_ele, & + & an_sf(1,1) ) + call interporate_one_position_linear(dnxi, x_local_ele, & + & dnxi_sf8(1,1) ) + call interporate_one_position_linear(dnei, x_local_ele, & + & dnei_sf8(1,1) ) +! + end subroutine cal_position_and_grad_sf8 +! +!----------------------------------------------------------------------- +! + subroutine cal_position_and_grad_9(xx_z, dnxi, dnei, & + & x_local_ele, xi) +! + use cal_shape_function_2d + use interpolate_position_in_ele +! + real(kind = kreal), intent(in) :: x_local_ele(num_lag_sf,3) + real(kind = kreal), intent(in) :: xi(2) +! + real(kind=kreal), intent(inout) :: xx_z(3) + real(kind=kreal), intent(inout) :: dnxi(3), dnei(3) +! + real(kind=kreal) :: an_sf(num_lag_sf,1) + real(kind=kreal) :: dnxi_sf9(num_lag_sf,1) + real(kind=kreal) :: dnei_sf9(num_lag_sf,1) +! +! + call s_cal_shape_function_2d_lag(ione, an_sf, dnxi_sf9, & + & dnei_sf9, xi(1), xi(2) ) + call interporate_one_position_by_9(xx_z, x_local_ele, & + & an_sf(1,1) ) + call interporate_one_position_by_9(dnxi, x_local_ele, & + & dnxi_sf9(1,1) ) + call interporate_one_position_by_9(dnei, x_local_ele, & + & dnei_sf9(1,1) ) +! + end subroutine cal_position_and_grad_9 +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_position_and_grad_2(xx_z, dnxi, x_local_ele, xi) +! + use cal_shape_function_1d + use interpolate_position_in_ele +! + real(kind = kreal), intent(in) :: x_local_ele(num_linear_edge,3) + real(kind = kreal), intent(in) :: xi(1) +! + real(kind=kreal), intent(inout) :: xx_z(3), dnxi(3) +! + real(kind=kreal) :: an_ed(num_linear_edge,1) + real(kind=kreal) :: dnxi_ed1(num_linear_edge,1) +! +! + call s_cal_shape_function_1d_linear(ione, an_ed, dnxi_ed1, xi) + call interporate_one_position_by_2(xx_z, x_local_ele, an_ed(1,1)) + call interporate_one_position_by_2(dnxi, x_local_ele, & + & dnxi_ed1(1,1) ) +! + end subroutine cal_position_and_grad_2 +! +!----------------------------------------------------------------------- +! + subroutine cal_position_and_grad_3(xx_z, dnxi, x_local_ele, xi) +! + use cal_shape_function_1d + use interpolate_position_in_ele +! + real(kind = kreal), intent(in) :: x_local_ele(num_quad_edge,3) + real(kind = kreal), intent(in) :: xi(1) +! + real(kind=kreal), intent(inout) :: xx_z(3), dnxi(3) +! + real(kind=kreal) :: an_ed(num_quad_edge,1) + real(kind=kreal) :: dnxi_ed3(num_quad_edge,1) +! +! + call s_cal_shape_function_1d_quad(ione, an_ed, dnxi_ed3, xi) + call interporate_one_position_by_3(xx_z, x_local_ele, & + & an_ed(1,1) ) + call interporate_one_position_by_3(dnxi, x_local_ele, & + & dnxi_ed3(1,1) ) +! + end subroutine cal_position_and_grad_3 +! +!----------------------------------------------------------------------- +! + end module cal_position_and_grad diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_position_in_ele.f90 b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_position_in_ele.f90 new file mode 100644 index 00000000..ef3d76e7 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_position_in_ele.f90 @@ -0,0 +1,278 @@ +!>@file interpolate_position_in_ele.f90 +!!@brief module interpolate_position_in_ele +!! +!!@author H. Matsui +!!@date Programmed in Sep. 2006 +!! +!>@brief Interpolate positions in each element, surface, and edge +!! +!!@verbatim +!! subroutine interporate_one_position_linear(x_out, x_local, an) +!! real (kind=kreal), intent(in) :: x_local(8,3) +!! real (kind=kreal), intent(in) :: an(8) +!! real (kind=kreal), intent(inout) :: x_out(3) +!! subroutine interporate_one_position_quad(x_out, x_local, an) +!! real (kind=kreal), intent(in) :: x_local(20,3) +!! real (kind=kreal), intent(in) :: an(20) +!! real (kind=kreal), intent(inout) :: x_out(3) +!! subroutine interporate_one_position_lag(x_out, x_local, an) +!! real (kind=kreal), intent(in) :: x_local(27,3) +!! real (kind=kreal), intent(in) :: an(27) +!! real (kind=kreal), intent(inout) :: x_out(3) +!! +!! subroutine interporate_one_position_by_4(x_out, x_local, an) +!! real (kind=kreal), intent(in) :: x_local(4,3) +!! real (kind=kreal), intent(in) :: an(4) +!! real (kind=kreal), intent(inout) :: x_out(3) +!! subroutine interporate_one_position_by_9(x_out, x_local, an) +!! real (kind=kreal), intent(in) :: x_local(9,3) +!! real (kind=kreal), intent(in) :: an(9) +!! real (kind=kreal), intent(inout) :: x_out(3) +!! +!! subroutine interporate_one_position_by_2(x_out, x_local, an) +!! real (kind=kreal), intent(in) :: x_local(2,3) +!! real (kind=kreal), intent(in) :: an(2) +!! real (kind=kreal), intent(inout) :: x_out(3) +!! subroutine interporate_one_position_by_3(x_out, x_local, an) +!! real (kind=kreal), intent(in) :: x_local(3,3) +!! real (kind=kreal), intent(in) :: an(3) +!! real (kind=kreal), intent(inout) :: x_out(3) +!!@endverbatim + module interpolate_position_in_ele +! + use m_precision +! + implicit none +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine interporate_one_position_linear(x_out, x_local, an) +! + real (kind=kreal), intent(in) :: x_local(8,3) + real (kind=kreal), intent(in) :: an(8) +! + real (kind=kreal), intent(inout) :: x_out(3) +! +! + x_out(1) = an( 1) * x_local( 1,1) + an( 2) * x_local( 2,1) & + & + an( 3) * x_local( 3,1) + an( 4) * x_local( 4,1) & + & + an( 5) * x_local( 5,1) + an( 6) * x_local( 6,1) & + & + an( 7) * x_local( 7,1) + an( 8) * x_local( 8,1) +! + x_out(2) = an( 1) * x_local( 1,2) + an( 2) * x_local( 2,2) & + & + an( 3) * x_local( 3,2) + an( 4) * x_local( 4,2) & + & + an( 5) * x_local( 5,2) + an( 6) * x_local( 6,2) & + & + an( 7) * x_local( 7,2) + an( 8) * x_local( 8,2) +! + x_out(3) = an( 1) * x_local( 1,3) + an( 2) * x_local( 2,3) & + & + an( 3) * x_local( 3,3) + an( 4) * x_local( 4,3) & + & + an( 5) * x_local( 5,3) + an( 6) * x_local( 6,3) & + & + an( 7) * x_local( 7,3) + an( 8) * x_local( 8,3) +! +! + end subroutine interporate_one_position_linear +! +! ---------------------------------------------------------------------- +! + subroutine interporate_one_position_quad(x_out, x_local, an) +! + real (kind=kreal), intent(in) :: x_local(20,3) + real (kind=kreal), intent(in) :: an(20) +! + real (kind=kreal), intent(inout) :: x_out(3) +! +! + x_out(1) = an( 1) * x_local( 1,1) + an( 2) * x_local( 2,1) & + & + an( 3) * x_local( 3,1) + an( 4) * x_local( 4,1) & + & + an( 5) * x_local( 5,1) + an( 6) * x_local( 6,1) & + & + an( 7) * x_local( 7,1) + an( 8) * x_local( 8,1) & + & + an( 9) * x_local( 9,1) + an(10) * x_local(10,1) & + & + an(11) * x_local(11,1) + an(12) * x_local(12,1) & + & + an(13) * x_local(13,1) + an(14) * x_local(14,1) & + & + an(15) * x_local(15,1) + an(16) * x_local(16,1) & + & + an(17) * x_local(17,1) + an(18) * x_local(18,1) & + & + an(19) * x_local(19,1) + an(20) * x_local(20,1) +! + x_out(2) = an( 1) * x_local( 1,2) + an( 2) * x_local( 2,2) & + & + an( 3) * x_local( 3,2) + an( 4) * x_local( 4,2) & + & + an( 5) * x_local( 5,2) + an( 6) * x_local( 6,2) & + & + an( 7) * x_local( 7,2) + an( 8) * x_local( 8,2) & + & + an( 9) * x_local( 9,2) + an(10) * x_local(10,2) & + & + an(11) * x_local(11,2) + an(12) * x_local(12,2) & + & + an(13) * x_local(13,2) + an(14) * x_local(14,2) & + & + an(15) * x_local(15,2) + an(16) * x_local(16,2) & + & + an(17) * x_local(17,2) + an(18) * x_local(18,2) & + & + an(19) * x_local(19,2) + an(20) * x_local(20,2) +! + x_out(3) = an( 1) * x_local( 1,3) + an( 2) * x_local( 2,3) & + & + an( 3) * x_local( 3,3) + an( 4) * x_local( 4,3) & + & + an( 5) * x_local( 5,3) + an( 6) * x_local( 6,3) & + & + an( 7) * x_local( 7,3) + an( 8) * x_local( 8,3) & + & + an( 9) * x_local( 9,3) + an(10) * x_local(10,3) & + & + an(11) * x_local(11,3) + an(12) * x_local(12,3) & + & + an(13) * x_local(13,3) + an(14) * x_local(14,3) & + & + an(15) * x_local(15,3) + an(16) * x_local(16,3) & + & + an(17) * x_local(17,3) + an(18) * x_local(18,3) & + & + an(19) * x_local(19,3) + an(20) * x_local(20,3) +! +! + end subroutine interporate_one_position_quad +! +! ---------------------------------------------------------------------- +! + subroutine interporate_one_position_lag(x_out, x_local, an) +! + real (kind=kreal), intent(in) :: x_local(27,3) + real (kind=kreal), intent(in) :: an(27) +! + real (kind=kreal), intent(inout) :: x_out(3) +! +! + x_out(1) = an( 1) * x_local( 1,1) + an( 2) * x_local( 2,1) & + & + an( 3) * x_local( 3,1) + an( 4) * x_local( 4,1) & + & + an( 5) * x_local( 5,1) + an( 6) * x_local( 6,1) & + & + an( 7) * x_local( 7,1) + an( 8) * x_local( 8,1) & + & + an( 9) * x_local( 9,1) + an(10) * x_local(10,1) & + & + an(11) * x_local(11,1) + an(12) * x_local(12,1) & + & + an(13) * x_local(13,1) + an(14) * x_local(14,1) & + & + an(15) * x_local(15,1) + an(16) * x_local(16,1) & + & + an(17) * x_local(17,1) + an(18) * x_local(18,1) & + & + an(19) * x_local(19,1) + an(20) * x_local(20,1) & + & + an(21) * x_local(21,1) + an(22) * x_local(12,1) & + & + an(23) * x_local(23,1) + an(24) * x_local(14,1) & + & + an(25) * x_local(25,1) + an(26) * x_local(16,1) & + & + an(27) * x_local(27,1) +! + x_out(2) = an( 1) * x_local( 1,2) + an( 2) * x_local( 2,2) & + & + an( 3) * x_local( 3,2) + an( 4) * x_local( 4,2) & + & + an( 5) * x_local( 5,2) + an( 6) * x_local( 6,2) & + & + an( 7) * x_local( 7,2) + an( 8) * x_local( 8,2) & + & + an( 9) * x_local( 9,2) + an(10) * x_local(10,2) & + & + an(11) * x_local(11,2) + an(12) * x_local(12,2) & + & + an(13) * x_local(13,2) + an(14) * x_local(14,2) & + & + an(15) * x_local(15,2) + an(16) * x_local(16,2) & + & + an(17) * x_local(17,2) + an(18) * x_local(18,2) & + & + an(19) * x_local(19,2) + an(20) * x_local(20,2) & + & + an(21) * x_local(21,2) + an(22) * x_local(12,2) & + & + an(23) * x_local(23,2) + an(24) * x_local(14,2) & + & + an(25) * x_local(25,2) + an(26) * x_local(16,2) & + & + an(27) * x_local(27,2) +! + x_out(3) = an( 1) * x_local( 1,3) + an( 2) * x_local( 2,3) & + & + an( 3) * x_local( 3,3) + an( 4) * x_local( 4,3) & + & + an( 5) * x_local( 5,3) + an( 6) * x_local( 6,3) & + & + an( 7) * x_local( 7,3) + an( 8) * x_local( 8,3) & + & + an( 9) * x_local( 9,3) + an(10) * x_local(10,3) & + & + an(11) * x_local(11,3) + an(12) * x_local(12,3) & + & + an(13) * x_local(13,3) + an(14) * x_local(14,3) & + & + an(15) * x_local(15,3) + an(16) * x_local(16,3) & + & + an(17) * x_local(17,3) + an(18) * x_local(18,3) & + & + an(19) * x_local(19,3) + an(20) * x_local(20,3) & + & + an(21) * x_local(21,3) + an(22) * x_local(12,3) & + & + an(23) * x_local(23,3) + an(24) * x_local(14,3) & + & + an(25) * x_local(25,3) + an(26) * x_local(16,3) & + & + an(27) * x_local(27,3) +! +! + end subroutine interporate_one_position_lag +! +! ---------------------------------------------------------------------- +! + subroutine interporate_one_position_by_4(x_out, x_local, an) +! + real (kind=kreal), intent(in) :: x_local(4,3) + real (kind=kreal), intent(in) :: an(4) +! + real (kind=kreal), intent(inout) :: x_out(3) +! +! + x_out(1) = an( 1) * x_local( 1,1) + an( 2) * x_local( 2,1) & + & + an( 3) * x_local( 3,1) + an( 4) * x_local( 4,1) +! + x_out(2) = an( 1) * x_local( 1,2) + an( 2) * x_local( 2,2) & + & + an( 3) * x_local( 3,2) + an( 4) * x_local( 4,2) +! + x_out(3) = an( 1) * x_local( 1,3) + an( 2) * x_local( 2,3) & + & + an( 3) * x_local( 3,3) + an( 4) * x_local( 4,3) +! +! + end subroutine interporate_one_position_by_4 +! +! ---------------------------------------------------------------------- +! + subroutine interporate_one_position_by_9(x_out, x_local, an) +! + real (kind=kreal), intent(in) :: x_local(9,3) + real (kind=kreal), intent(in) :: an(9) +! + real (kind=kreal), intent(inout) :: x_out(3) +! +! + x_out(1) = an( 1) * x_local( 1,1) + an( 2) * x_local( 2,1) & + & + an( 3) * x_local( 3,1) + an( 4) * x_local( 4,1) & + & + an( 5) * x_local( 5,1) + an( 6) * x_local( 6,1) & + & + an( 7) * x_local( 7,1) + an( 8) * x_local( 8,1) & + & + an( 9) * x_local( 9,1) +! + x_out(2) = an( 1) * x_local( 1,2) + an( 2) * x_local( 2,2) & + & + an( 3) * x_local( 3,2) + an( 4) * x_local( 4,2) & + & + an( 5) * x_local( 5,2) + an( 6) * x_local( 6,2) & + & + an( 7) * x_local( 7,2) + an( 8) * x_local( 8,2) & + & + an( 9) * x_local( 9,2) +! + x_out(3) = an( 1) * x_local( 1,3) + an( 2) * x_local( 2,3) & + & + an( 3) * x_local( 3,3) + an( 4) * x_local( 4,3) & + & + an( 5) * x_local( 5,3) + an( 6) * x_local( 6,3) & + & + an( 7) * x_local( 7,3) + an( 8) * x_local( 8,3) & + & + an( 9) * x_local( 9,3) +! +! + end subroutine interporate_one_position_by_9 +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine interporate_one_position_by_2(x_out, x_local, an) +! + real (kind=kreal), intent(in) :: x_local(2,3) + real (kind=kreal), intent(in) :: an(2) +! + real (kind=kreal), intent(inout) :: x_out(3) +! +! + x_out(1) = an( 1) * x_local( 1,1) + an( 2) * x_local( 2,1) + x_out(2) = an( 1) * x_local( 1,2) + an( 2) * x_local( 2,2) + x_out(3) = an( 1) * x_local( 1,3) + an( 2) * x_local( 2,3) +! +! + end subroutine interporate_one_position_by_2 +! +! ---------------------------------------------------------------------- +! + subroutine interporate_one_position_by_3(x_out, x_local, an) +! + real (kind=kreal), intent(in) :: x_local(3,3) + real (kind=kreal), intent(in) :: an(3) +! + real (kind=kreal), intent(inout) :: x_out(3) +! +! + x_out(1) = an( 1) * x_local( 1,1) + an( 2) * x_local( 2,1) & + & + an( 3) * x_local( 3,1) +! + x_out(2) = an( 1) * x_local( 1,2) + an( 2) * x_local( 2,2) & + & + an( 3) * x_local( 3,2) +! + x_out(3) = an( 1) * x_local( 1,3) + an( 2) * x_local( 2,3) & + & + an( 3) * x_local( 3,3) +! +! + end subroutine interporate_one_position_by_3 +! +! ---------------------------------------------------------------------- +! + end module interpolate_position_in_ele diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_scalar_ele20.f90 b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_scalar_ele20.f90 new file mode 100644 index 00000000..6c2e60ce --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_scalar_ele20.f90 @@ -0,0 +1,385 @@ +!>@file interpolate_scalar_ele20.f90 +!!@brief module interpolate_scalar_ele20 +!! +!!@author H. Matsui +!!@date Programmed by H. Matsui in July, 2006 +!!@n Modified by H. Matsui in Nov., 2013 +! +!> @brief Interpolation for scaslar in quardorature element +!! +!!@verbatim +!! subroutine single_interpolate_scalar_ele20(numnod, numele, ie, & +!! & v_org, iele_gauss, xi_gauss, scalar) +!! integer (kind = kint), intent(in) :: numnod, numele +!! integer (kind = kint), intent(in) :: ie(numele,20) +!! integer (kind = kint), intent(in) :: iele_gauss +!! real (kind=kreal), intent(in) :: xi_gauss(3) +!! real (kind=kreal), intent(in) :: v_org(numnod) +!! real (kind=kreal), intent(inout) :: scalar +!! subroutine s_interpolate_scalar_ele20(np_smp, numnod, & +!! & numele, ie, v_org, istack_smp, num_points, iele_gauss,& +!! & xi_gauss, vect) +!! +!! subroutine itp_matvec_scalar_edge3(np_smp, NP, v_org, & +!! & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +!! subroutine itp_matvec_scalar_ele20(np_smp, NP, v_org, & +!! & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +!!@endverbatim +! + module interpolate_scalar_ele20 +! + use m_precision +! + implicit none +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine single_interpolate_scalar_ele20(numnod, numele, ie, & + & v_org, iele_gauss, xi_gauss, scalar) +! + use m_constants +! + integer (kind = kint), intent(in) :: numnod, numele + integer (kind = kint), intent(in) :: ie(numele,20) + integer (kind = kint), intent(in) :: iele_gauss + real (kind=kreal), intent(in) :: xi_gauss(3) + real (kind=kreal), intent(in) :: v_org(numnod) +! + real (kind=kreal), intent(inout) :: scalar +! + real (kind=kreal) :: xi, ei, zi + real (kind=kreal) :: xi_nega, ei_nega, zi_nega + real (kind=kreal) :: xi_posi, ei_posi, zi_posi + real (kind=kreal) :: xi_sqre, ei_sqre, zi_sqre +! + real (kind=kreal) :: an1, an2, an3, an4, an5, an6, an7, an8 + real (kind=kreal) :: an9, an10, an11, an12, an13, an14 + real (kind=kreal) :: an15, an16, an17, an18, an19, an20 +! + integer (kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 + integer (kind = kint) :: i9, i10, i11, i12, i13, i14, i15, i16 + integer (kind = kint) :: i17, i18, i19, i20 +! + i1 = ie(iele_gauss,1) + i2 = ie(iele_gauss,2) + i3 = ie(iele_gauss,3) + i4 = ie(iele_gauss,4) + i5 = ie(iele_gauss,5) + i6 = ie(iele_gauss,6) + i7 = ie(iele_gauss,7) + i8 = ie(iele_gauss,8) + i9 = ie(iele_gauss,9 ) + i10 = ie(iele_gauss,10) + i11 = ie(iele_gauss,11) + i12 = ie(iele_gauss,12) + i13 = ie(iele_gauss,13) + i14 = ie(iele_gauss,14) + i15 = ie(iele_gauss,15) + i16 = ie(iele_gauss,16) + i17 = ie(iele_gauss,17) + i18 = ie(iele_gauss,18) + i19 = ie(iele_gauss,19) + i20 = ie(iele_gauss,20) +! + xi = xi_gauss(1) + ei = xi_gauss(2) + zi = xi_gauss(3) +! + xi_nega = one - xi + xi_posi = one + xi + xi_sqre = one - xi * xi +! + ei_nega = one - ei + ei_posi = one + ei + ei_sqre = one - ei * ei +! + zi_nega = one - zi + zi_posi = one + zi + zi_sqre = one - zi * zi +! + an1 = r125 * xi_nega * ei_nega * zi_nega * (-xi-ei-zi-two) + an2 = r125 * xi_posi * ei_nega * zi_nega * ( xi-ei-zi-two) + an3 = r125 * xi_posi * ei_posi * zi_nega * ( xi+ei-zi-two) + an4 = r125 * xi_nega * ei_posi * zi_nega * (-xi+ei-zi-two) + an5 = r125 * xi_nega * ei_nega * zi_posi * (-xi-ei+zi-two) + an6 = r125 * xi_posi * ei_nega * zi_posi * ( xi-ei+zi-two) + an7 = r125 * xi_posi * ei_posi * zi_posi * ( xi+ei+zi-two) + an8 = r125 * xi_nega * ei_posi * zi_posi * (-xi+ei+zi-two) +! + an9 = quad * xi_sqre * ei_nega * zi_nega + an10 = quad * xi_posi * ei_sqre * zi_nega + an11 = quad * xi_sqre * ei_posi * zi_nega + an12 = quad * xi_nega * ei_sqre * zi_nega +! + an13 = quad * xi_sqre * ei_nega * zi_posi + an14 = quad * xi_posi * ei_sqre * zi_posi + an15 = quad * xi_sqre * ei_posi * zi_posi + an16 = quad * xi_nega * ei_sqre * zi_posi +! + an17 = quad * xi_nega * ei_nega * zi_sqre + an18 = quad * xi_posi * ei_nega * zi_sqre + an19 = quad * xi_posi * ei_posi * zi_sqre + an20 = quad * xi_nega * ei_posi * zi_sqre +! +! + scalar = an1 * v_org(i1 ) + an2 * v_org(i2 ) & + & + an3 * v_org(i3 ) + an4 * v_org(i4 ) & + & + an5 * v_org(i5 ) + an6 * v_org(i6 ) & + & + an7 * v_org(i7 ) + an8 * v_org(i8 ) & + & + an9 * v_org(i9 ) + an10 * v_org(i10) & + & + an11 * v_org(i11) + an12 * v_org(i12) & + & + an13 * v_org(i13) + an14 * v_org(i14) & + & + an15 * v_org(i15) + an16 * v_org(i16) & + & + an17 * v_org(i17) + an18 * v_org(i18) & + & + an19 * v_org(i19) + an20 * v_org(i20) +! + end subroutine single_interpolate_scalar_ele20 +! +! ---------------------------------------------------------------------- +! + subroutine s_interpolate_scalar_ele20(np_smp, numnod, & + & numele, ie, v_org, istack_smp, num_points, iele_gauss, & + & xi_gauss, vect) +! + use m_constants +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: numnod, numele + integer (kind = kint), intent(in) :: ie(numele,20) + integer (kind = kint), intent(in) :: istack_smp(0:np_smp) + integer (kind = kint), intent(in) :: num_points + integer (kind = kint), intent(in) :: iele_gauss(num_points) + real (kind=kreal), intent(in) :: xi_gauss(num_points,3) + real (kind=kreal), intent(in) :: v_org(numnod) +! + real (kind=kreal), intent(inout) :: vect(num_points) +! + real (kind=kreal) :: xi, ei, zi + real (kind=kreal) :: xi_nega, ei_nega, zi_nega + real (kind=kreal) :: xi_posi, ei_posi, zi_posi + real (kind=kreal) :: xi_sqre, ei_sqre, zi_sqre +! + real (kind=kreal) :: an1, an2, an3, an4, an5, an6, an7, an8 + real (kind=kreal) :: an9, an10, an11, an12, an13, an14 + real (kind=kreal) :: an15, an16, an17, an18, an19, an20 +! + integer (kind = kint) :: ip, ist, ied + integer (kind = kint) :: iele, i1, i2, i3, i4, i5, i6, i7, i8 + integer (kind = kint) :: i9, i10, i11, i12, i13, i14, i15, i16 + integer (kind = kint) :: i17, i18, i19, i20 +! + integer (kind = kint) :: ig +! +! +!$omp parallel do private(ist,ied,ig,iele,i1,i2,i3,i4,i5,i6,i7,i8,i9, & +!$omp& i10,i11,i12,i13,i14,i15,i16,i17,i18,i19,i20, & +!$omp& xi,ei,zi, xi_nega, xi_posi, ei_nega, ei_posi, & +!$omp& zi_nega, zi_posi, xi_sqre, ei_sqre, zi_sqre, & +!$omp& an1,an2,an3,an4,an5,an6,an7,an8,an9,an10, & +!$omp& an11,an12,an13,an14,an15,an16,an17,an18, & +!$omp& an19,an20) + do ip = 1, np_smp + ist = istack_smp(ip-1) + 1 + ied = istack_smp(ip) + do ig = ist, ied +! + iele = iele_gauss(ig) +! + i1 = ie(iele,1) + i2 = ie(iele,2) + i3 = ie(iele,3) + i4 = ie(iele,4) + i5 = ie(iele,5) + i6 = ie(iele,6) + i7 = ie(iele,7) + i8 = ie(iele,8) + i9 = ie(iele,9 ) + i10 = ie(iele,10) + i11 = ie(iele,11) + i12 = ie(iele,12) + i13 = ie(iele,13) + i14 = ie(iele,14) + i15 = ie(iele,15) + i16 = ie(iele,16) + i17 = ie(iele,17) + i18 = ie(iele,18) + i19 = ie(iele,19) + i20 = ie(iele,20) +! + xi = xi_gauss(ig,1) + ei = xi_gauss(ig,2) + zi = xi_gauss(ig,3) +! + xi_nega = one - xi + xi_posi = one + xi + xi_sqre = one - xi * xi +! + ei_nega = one - ei + ei_posi = one + ei + ei_sqre = one - ei * ei +! + zi_nega = one - zi + zi_posi = one + zi + zi_sqre = one - zi * zi +! + an1 = r125 * xi_nega * ei_nega * zi_nega * (-xi-ei-zi-two) + an2 = r125 * xi_posi * ei_nega * zi_nega * ( xi-ei-zi-two) + an3 = r125 * xi_posi * ei_posi * zi_nega * ( xi+ei-zi-two) + an4 = r125 * xi_nega * ei_posi * zi_nega * (-xi+ei-zi-two) + an5 = r125 * xi_nega * ei_nega * zi_posi * (-xi-ei+zi-two) + an6 = r125 * xi_posi * ei_nega * zi_posi * ( xi-ei+zi-two) + an7 = r125 * xi_posi * ei_posi * zi_posi * ( xi+ei+zi-two) + an8 = r125 * xi_nega * ei_posi * zi_posi * (-xi+ei+zi-two) +! + an9 = quad * xi_sqre * ei_nega * zi_nega + an10 = quad * xi_posi * ei_sqre * zi_nega + an11 = quad * xi_sqre * ei_posi * zi_nega + an12 = quad * xi_nega * ei_sqre * zi_nega +! + an13 = quad * xi_sqre * ei_nega * zi_posi + an14 = quad * xi_posi * ei_sqre * zi_posi + an15 = quad * xi_sqre * ei_posi * zi_posi + an16 = quad * xi_nega * ei_sqre * zi_posi +! + an17 = quad * xi_nega * ei_nega * zi_sqre + an18 = quad * xi_posi * ei_nega * zi_sqre + an19 = quad * xi_posi * ei_posi * zi_sqre + an20 = quad * xi_nega * ei_posi * zi_sqre +! +! + vect(ig) = an1 * v_org(i1 ) + an2 * v_org(i2 ) & + & + an3 * v_org(i3 ) + an4 * v_org(i4 ) & + & + an5 * v_org(i5 ) + an6 * v_org(i6 ) & + & + an7 * v_org(i7 ) + an8 * v_org(i8 ) & + & + an9 * v_org(i9 ) + an10 * v_org(i10) & + & + an11 * v_org(i11) + an12 * v_org(i12) & + & + an13 * v_org(i13) + an14 * v_org(i14) & + & + an15 * v_org(i15) + an16 * v_org(i16) & + & + an17 * v_org(i17) + an18 * v_org(i18) & + & + an19 * v_org(i19) + an20 * v_org(i20) +! + end do + end do +!$omp end parallel do +! + end subroutine s_interpolate_scalar_ele20 +! +! ---------------------------------------------------------------------- +! + subroutine itp_matvec_scalar_edge3(np_smp, NP, v_org, & + & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +! + use m_constants +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: NP + real (kind=kreal), intent(in) :: v_org(NP) +! + integer(kind = kint), intent(in) :: NC, NCM + integer(kind = kint), intent(in) :: IEND_SUM_smp(0:np_smp) + integer(kind = kint), intent(in) :: INM(0:NC) + integer(kind = kint), intent(in) :: IAM(NCM) + real(kind = kreal), intent(in) :: AM(NCM) +! + real (kind=kreal), intent(inout) :: vect(NC) +! + integer (kind = kint) :: ip, ist, ist_s, ied_s, ig + integer (kind = kint) :: i1, i2, i3 +! +! +!$omp parallel do private(ist_s,ied_s,ig,ist, i1,i2,i3) + do ip = 1, np_smp + ist_s = IEND_SUM_smp(ip-1) + 1 + ied_s = IEND_SUM_smp(ip) + do ig = ist_s, ied_s + ist = INM(ig-1) +! + i1 = IAM(ist+ 1) + i2 = IAM(ist+ 2) + i3 = IAM(ist+ 3) +! + vect(ig) = AM(ist+ 1) * v_org(i1 ) + AM(ist+ 2) * v_org(i2 ) & + & + AM(ist+ 3) * v_org(i3 ) + end do + end do +!$omp end parallel do +! + end subroutine itp_matvec_scalar_edge3 +! +! ---------------------------------------------------------------------- +! + subroutine itp_matvec_scalar_ele20(np_smp, NP, v_org, & + & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +! + use m_constants +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: NP + real (kind=kreal), intent(in) :: v_org(NP) +! + integer(kind = kint), intent(in) :: NC, NCM + integer(kind = kint), intent(in) :: IEND_SUM_smp(0:np_smp) + integer(kind = kint), intent(in) :: INM(0:NC) + integer(kind = kint), intent(in) :: IAM(NCM) + real(kind = kreal), intent(in) :: AM(NCM) +! + real (kind=kreal), intent(inout) :: vect(NC) +! + integer (kind = kint) :: ip, ist, ist_s, ied_s, ig + integer (kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 + integer (kind = kint) :: i9, i10, i11, i12, i13, i14, i15, i16 + integer (kind = kint) :: i17, i18, i19, i20 +! +! +!$omp parallel do private(ist_s,ied_s,ig,ist,i1,i2,i3,i4,i5,i6,i7,i8,i9,& +!$omp& i10,i11,i12,i13,i14,i15,i16,i17,i18,i19,i20) + do ip = 1, np_smp + ist_s = IEND_SUM_smp(ip-1) + 1 + ied_s = IEND_SUM_smp(ip) + do ig = ist_s, ied_s + ist = INM(ig-1) +! + i1 = IAM(ist+ 1) + i2 = IAM(ist+ 2) + i3 = IAM(ist+ 3) + i4 = IAM(ist+ 4) + i5 = IAM(ist+ 5) + i6 = IAM(ist+ 6) + i7 = IAM(ist+ 7) + i8 = IAM(ist+ 8) + i9 = IAM(ist+ 9) + i10 = IAM(ist+10) + i11 = IAM(ist+11) + i12 = IAM(ist+12) + i13 = IAM(ist+13) + i14 = IAM(ist+14) + i15 = IAM(ist+15) + i16 = IAM(ist+16) + i17 = IAM(ist+17) + i18 = IAM(ist+18) + i19 = IAM(ist+19) + i20 = IAM(ist+20) +! + vect(ig) = AM(ist+ 1) * v_org(i1 ) + AM(ist+ 2) * v_org(i2 ) & + & + AM(ist+ 3) * v_org(i3 ) + AM(ist+ 4) * v_org(i4 ) & + & + AM(ist+ 5) * v_org(i5 ) + AM(ist+ 6) * v_org(i6 ) & + & + AM(ist+ 7) * v_org(i7 ) + AM(ist+ 8) * v_org(i8 ) & + & + AM(ist+ 9) * v_org(i9 ) + AM(ist+10) * v_org(i10) & + & + AM(ist+11) * v_org(i11) + AM(ist+12) * v_org(i12) & + & + AM(ist+13) * v_org(i13) + AM(ist+14) * v_org(i14) & + & + AM(ist+15) * v_org(i15) + AM(ist+16) * v_org(i16) & + & + AM(ist+17) * v_org(i17) + AM(ist+18) * v_org(i18) & + & + AM(ist+19) * v_org(i19) + AM(ist+20) * v_org(i20) + end do + end do +!$omp end parallel do +! + end subroutine itp_matvec_scalar_ele20 +! +! ---------------------------------------------------------------------- +! + end module interpolate_scalar_ele20 diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_scalar_ele27.f90 b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_scalar_ele27.f90 new file mode 100644 index 00000000..66f70da7 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_scalar_ele27.f90 @@ -0,0 +1,463 @@ +!>@file interpolate_scalar_ele27.f90 +!!@brief module interpolate_scalar_ele27 +!! +!!@author H. Matsui +!!@date Programmed by H. Matsui in July, 2006 +!!@n Modified by H. Matsui in Nov., 2013 +! +!> @brief Interpolation for scalar in Lagrange element +!! +!!@verbatim +!! subroutine single_interpolate_scalar_ele27(numnod, numele, ie, & +!! & v_org, iele_gauss, xi_gauss, scalar) +!! integer (kind = kint), intent(in) :: numnod, numele +!! integer (kind = kint), intent(in) :: ie(numele,27) +!! integer (kind = kint), intent(in) :: iele_gauss +!! real (kind=kreal), intent(in) :: xi_gauss(3) +!! real (kind=kreal), intent(in) :: v_org(numnod) +!! real (kind=kreal), intent(inout) :: scalar +!! subroutine s_interpolate_scalar_ele27(np_smp, numnod, numele,ie,& +!! & v_org, istack_smp, num_points, iele_gauss, & +!! & xi_gauss, vect) +!! integer (kind = kint), intent(in) :: np_smp +!! integer (kind = kint), intent(in) :: numnod, numele +!! integer (kind = kint), intent(in) :: ie(numele,27) +!! integer (kind = kint), intent(in) :: istack_smp(0:np_smp) +!! integer (kind = kint), intent(in) :: num_points +!! integer (kind = kint), intent(in) :: iele_gauss(num_points) +!! real (kind=kreal), intent(in) :: xi_gauss(num_points,3) +!! real (kind=kreal), intent(in) :: v_org(numnod) +!! real (kind=kreal), intent(inout) :: vect(num_points) +!! +!! subroutine itp_matvec_scalar_surf9(np_smp, NP, v_org, & +!! & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +!! subroutine itp_matvec_scalar_ele27(np_smp, NP, v_org, & +!! & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +!!@endverbatim +! + module interpolate_scalar_ele27 +! + use m_precision +! + implicit none +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine single_interpolate_scalar_ele27(numnod, numele, ie, & + & v_org, iele_gauss, xi_gauss, scalar) +! + use m_constants +! + integer (kind = kint), intent(in) :: numnod, numele + integer (kind = kint), intent(in) :: ie(numele,27) + integer (kind = kint), intent(in) :: iele_gauss + real (kind=kreal), intent(in) :: xi_gauss(3) + real (kind=kreal), intent(in) :: v_org(numnod) +! + real (kind=kreal), intent(inout) :: scalar +! + real (kind=kreal) :: xi, ei, zi + real (kind=kreal) :: xi_nega, ei_nega, zi_nega + real (kind=kreal) :: xi_posi, ei_posi, zi_posi + real (kind=kreal) :: xi_sqre, ei_sqre, zi_sqre +! + real (kind=kreal) :: an1, an2, an3, an4, an5, an6, an7, an8 + real (kind=kreal) :: an9, an10, an11, an12, an13, an14 + real (kind=kreal) :: an15, an16, an17, an18, an19, an20 + real (kind=kreal) :: an21, an22, an23, an24, an25, an26, an27 +! + integer (kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 + integer (kind = kint) :: i9, i10, i11, i12, i13, i14, i15, i16 + integer (kind = kint) :: i17, i18, i19, i20, i21, i22, i23, i24 + integer (kind = kint) :: i25, i26, i27 +! + i1 = ie(iele_gauss,1) + i2 = ie(iele_gauss,2) + i3 = ie(iele_gauss,3) + i4 = ie(iele_gauss,4) + i5 = ie(iele_gauss,5) + i6 = ie(iele_gauss,6) + i7 = ie(iele_gauss,7) + i8 = ie(iele_gauss,8) + i9 = ie(iele_gauss,9 ) + i10 = ie(iele_gauss,10) + i11 = ie(iele_gauss,11) + i12 = ie(iele_gauss,12) + i13 = ie(iele_gauss,13) + i14 = ie(iele_gauss,14) + i15 = ie(iele_gauss,15) + i16 = ie(iele_gauss,16) + i17 = ie(iele_gauss,17) + i18 = ie(iele_gauss,18) + i19 = ie(iele_gauss,19) + i20 = ie(iele_gauss,20) + i21 = ie(iele_gauss,21) + i22 = ie(iele_gauss,22) + i23 = ie(iele_gauss,23) + i24 = ie(iele_gauss,24) + i25 = ie(iele_gauss,25) + i26 = ie(iele_gauss,26) + i27 = ie(iele_gauss,27) +! + xi = xi_gauss(1) + ei = xi_gauss(2) + zi = xi_gauss(3) +! + xi_nega = one - xi + xi_posi = one + xi + xi_sqre = one - xi * xi +! + ei_nega = one - ei + ei_posi = one + ei + ei_sqre = one - ei * ei +! + zi_nega = one - zi + zi_posi = one + zi + zi_sqre = one - zi * zi +! + an1 = r125 * xi_nega * ei_nega * zi_nega * xi * ei * zi + an2 = r125 * xi_posi * ei_nega * zi_nega * xi * ei * zi + an3 = r125 * xi_posi * ei_posi * zi_nega * xi * ei * zi + an4 = r125 * xi_nega * ei_posi * zi_nega * xi * ei * zi + an5 = r125 * xi_nega * ei_nega * zi_posi * xi * ei * zi + an6 = r125 * xi_posi * ei_nega * zi_posi * xi * ei * zi + an7 = r125 * xi_posi * ei_posi * zi_posi * xi * ei * zi + an8 = r125 * xi_nega * ei_posi * zi_posi * xi * ei * zi +! + an9 = quad * xi_sqre * ei_nega * zi_nega * ei * zi + an10 = quad * xi_posi * ei_sqre * zi_nega * xi * zi + an11 = quad * xi_sqre * ei_posi * zi_nega * ei * zi + an12 = quad * xi_nega * ei_sqre * zi_nega * xi * zi +! + an13 = quad * xi_sqre * ei_nega * zi_posi * ei * zi + an14 = quad * xi_posi * ei_sqre * zi_posi * xi * zi + an15 = quad * xi_sqre * ei_posi * zi_posi * ei * zi + an16 = quad * xi_nega * ei_sqre * zi_posi * xi * zi +! + an17 = quad * xi_nega * ei_nega * zi_sqre * xi * ei + an18 = quad * xi_posi * ei_nega * zi_sqre * xi * ei + an19 = quad * xi_posi * ei_posi * zi_sqre * xi * ei + an20 = quad * xi_nega * ei_posi * zi_sqre * xi * ei +! + an21 = half * xi_nega * ei_sqre * zi_sqre * xi + an22 = half * xi_posi * ei_sqre * zi_sqre * xi + an23 = half * xi_sqre * ei_nega * zi_sqre * ei + an24 = half * xi_sqre * ei_posi * zi_sqre * ei + an25 = half * xi_sqre * ei_sqre * zi_nega * zi + an26 = half * xi_sqre * ei_sqre * zi_posi * zi +! + an27 = xi_sqre * ei_sqre * zi_sqre +! +! + scalar = an1 * v_org(i1 ) + an2 * v_org(i2 ) & + & + an3 * v_org(i3 ) + an4 * v_org(i4 ) & + & + an5 * v_org(i5 ) + an6 * v_org(i6 ) & + & + an7 * v_org(i7 ) + an8 * v_org(i8 ) & + & + an9 * v_org(i9 ) + an10 * v_org(i10) & + & + an11 * v_org(i11) + an12 * v_org(i12) & + & + an13 * v_org(i13) + an14 * v_org(i14) & + & + an15 * v_org(i15) + an16 * v_org(i16) & + & + an17 * v_org(i17) + an18 * v_org(i18) & + & + an19 * v_org(i19) + an20 * v_org(i20) & + & + an21 * v_org(i21) + an22 * v_org(i22) & + & + an23 * v_org(i23) + an24 * v_org(i24) & + & + an25 * v_org(i25) + an26 * v_org(i26) & + & + an27 * v_org(i27) +! + end subroutine single_interpolate_scalar_ele27 +! +! ---------------------------------------------------------------------- +! + subroutine s_interpolate_scalar_ele27(np_smp, numnod, numele, ie, & + & v_org, istack_smp, num_points, iele_gauss, & + & xi_gauss, vect) +! + use m_constants +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: numnod, numele + integer (kind = kint), intent(in) :: ie(numele,27) + integer (kind = kint), intent(in) :: istack_smp(0:np_smp) + integer (kind = kint), intent(in) :: num_points + integer (kind = kint), intent(in) :: iele_gauss(num_points) + real (kind=kreal), intent(in) :: xi_gauss(num_points,3) + real (kind=kreal), intent(in) :: v_org(numnod) +! + real (kind=kreal), intent(inout) :: vect(num_points) +! + real (kind=kreal) :: xi, ei, zi + real (kind=kreal) :: xi_nega, ei_nega, zi_nega + real (kind=kreal) :: xi_posi, ei_posi, zi_posi + real (kind=kreal) :: xi_sqre, ei_sqre, zi_sqre +! + real (kind=kreal) :: an1, an2, an3, an4, an5, an6, an7, an8 + real (kind=kreal) :: an9, an10, an11, an12, an13, an14 + real (kind=kreal) :: an15, an16, an17, an18, an19, an20 + real (kind=kreal) :: an21, an22, an23, an24, an25, an26, an27 +! + integer (kind = kint) :: ip, ist, ied + integer (kind = kint) :: iele, i1, i2, i3, i4, i5, i6, i7, i8 + integer (kind = kint) :: i9, i10, i11, i12, i13, i14, i15, i16 + integer (kind = kint) :: i17, i18, i19, i20, i21, i22, i23, i24 + integer (kind = kint) :: i25, i26, i27 +! + integer (kind = kint) :: ig +! +! +!$omp parallel do private(ist,ied,ig,iele,i1,i2,i3,i4,i5,i6,i7,i8,i9, & +!$omp& i10,i11,i12,i13,i14,i15,i16,i17,i18,i19,i20, & +!$omp& i21,i22,i23,i24,i25,i26,i27,xi,ei,zi, & +!$omp& xi_nega, xi_posi, ei_nega, ei_posi, & +!$omp& zi_nega, zi_posi, xi_sqre, ei_sqre, zi_sqre, & +!$omp& an1,an2,an3,an4,an5,an6,an7,an8,an9,an10, & +!$omp& an11,an12,an13,an14,an15,an16,an17,an18, & +!$omp& an19,an20,an21,an22,an23,an24,an25,an26,an27) + do ip = 1, np_smp + ist = istack_smp(ip-1) + 1 + ied = istack_smp(ip) + do ig = ist, ied +! + iele = iele_gauss(ig) +! + i1 = ie(iele,1) + i2 = ie(iele,2) + i3 = ie(iele,3) + i4 = ie(iele,4) + i5 = ie(iele,5) + i6 = ie(iele,6) + i7 = ie(iele,7) + i8 = ie(iele,8) + i9 = ie(iele,9 ) + i10 = ie(iele,10) + i11 = ie(iele,11) + i12 = ie(iele,12) + i13 = ie(iele,13) + i14 = ie(iele,14) + i15 = ie(iele,15) + i16 = ie(iele,16) + i17 = ie(iele,17) + i18 = ie(iele,18) + i19 = ie(iele,19) + i20 = ie(iele,20) + i21 = ie(iele,21) + i22 = ie(iele,22) + i23 = ie(iele,23) + i24 = ie(iele,24) + i25 = ie(iele,25) + i26 = ie(iele,26) + i27 = ie(iele,27) +! + xi = xi_gauss(ig,1) + ei = xi_gauss(ig,2) + zi = xi_gauss(ig,3) +! + xi_nega = one - xi + xi_posi = one + xi + xi_sqre = one - xi * xi +! + ei_nega = one - ei + ei_posi = one + ei + ei_sqre = one - ei * ei +! + zi_nega = one - zi + zi_posi = one + zi + zi_sqre = one - zi * zi +! + an1 = r125 * xi_nega * ei_nega * zi_nega * xi * ei * zi + an2 = r125 * xi_posi * ei_nega * zi_nega * xi * ei * zi + an3 = r125 * xi_posi * ei_posi * zi_nega * xi * ei * zi + an4 = r125 * xi_nega * ei_posi * zi_nega * xi * ei * zi + an5 = r125 * xi_nega * ei_nega * zi_posi * xi * ei * zi + an6 = r125 * xi_posi * ei_nega * zi_posi * xi * ei * zi + an7 = r125 * xi_posi * ei_posi * zi_posi * xi * ei * zi + an8 = r125 * xi_nega * ei_posi * zi_posi * xi * ei * zi +! + an9 = quad * xi_sqre * ei_nega * zi_nega * ei * zi + an10 = quad * xi_posi * ei_sqre * zi_nega * xi * zi + an11 = quad * xi_sqre * ei_posi * zi_nega * ei * zi + an12 = quad * xi_nega * ei_sqre * zi_nega * xi * zi +! + an13 = quad * xi_sqre * ei_nega * zi_posi * ei * zi + an14 = quad * xi_posi * ei_sqre * zi_posi * xi * zi + an15 = quad * xi_sqre * ei_posi * zi_posi * ei * zi + an16 = quad * xi_nega * ei_sqre * zi_posi * xi * zi +! + an17 = quad * xi_nega * ei_nega * zi_sqre * xi * ei + an18 = quad * xi_posi * ei_nega * zi_sqre * xi * ei + an19 = quad * xi_posi * ei_posi * zi_sqre * xi * ei + an20 = quad * xi_nega * ei_posi * zi_sqre * xi * ei +! + an21 = half * xi_nega * ei_sqre * zi_sqre * xi + an22 = half * xi_posi * ei_sqre * zi_sqre * xi + an23 = half * xi_sqre * ei_nega * zi_sqre * ei + an24 = half * xi_sqre * ei_posi * zi_sqre * ei + an25 = half * xi_sqre * ei_sqre * zi_nega * zi + an26 = half * xi_sqre * ei_sqre * zi_posi * zi +! + an27 = xi_sqre * ei_sqre * zi_sqre +! +! + vect(ig) = an1 * v_org(i1 ) + an2 * v_org(i2 ) & + & + an3 * v_org(i3 ) + an4 * v_org(i4 ) & + & + an5 * v_org(i5 ) + an6 * v_org(i6 ) & + & + an7 * v_org(i7 ) + an8 * v_org(i8 ) & + & + an9 * v_org(i9 ) + an10 * v_org(i10) & + & + an11 * v_org(i11) + an12 * v_org(i12) & + & + an13 * v_org(i13) + an14 * v_org(i14) & + & + an15 * v_org(i15) + an16 * v_org(i16) & + & + an17 * v_org(i17) + an18 * v_org(i18) & + & + an19 * v_org(i19) + an20 * v_org(i20) & + & + an21 * v_org(i21) + an22 * v_org(i22) & + & + an23 * v_org(i23) + an24 * v_org(i24) & + & + an25 * v_org(i25) + an26 * v_org(i26) & + & + an27 * v_org(i27) +! + end do + end do +!$omp end parallel do +! + end subroutine s_interpolate_scalar_ele27 +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine itp_matvec_scalar_surf9(np_smp, NP, v_org, & + & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +! + use m_constants +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: NP + real (kind=kreal), intent(in) :: v_org(NP) +! + integer(kind = kint), intent(in) :: NC, NCM + integer(kind = kint), intent(in) :: IEND_SUM_smp(0:np_smp) + integer(kind = kint), intent(in) :: INM(0:NC) + integer(kind = kint), intent(in) :: IAM(NCM) + real(kind = kreal), intent(in) :: AM(NCM) +! + real (kind=kreal), intent(inout) :: vect(NC) +! + integer (kind = kint) :: ip, ist, ist_s, ied_s, ig + integer (kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8, i9 +! +! +!$omp parallel do private(ist_s,ied_s,ig,ist, & +!$omp& i1,i2,i3,i4,i5,i6,i7,i8,i9) + do ip = 1, np_smp + ist_s = IEND_SUM_smp(ip-1) + 1 + ied_s = IEND_SUM_smp(ip) + do ig = ist_s, ied_s + ist = INM(ig-1) +! + i1 = IAM(ist+ 1) + i2 = IAM(ist+ 2) + i3 = IAM(ist+ 3) + i4 = IAM(ist+ 4) + i5 = IAM(ist+ 5) + i6 = IAM(ist+ 6) + i7 = IAM(ist+ 7) + i8 = IAM(ist+ 8) + i9 = IAM(ist+ 9) +! + vect(ig) = AM(ist+ 1) * v_org(i1 ) + AM(ist+ 2) * v_org(i2 ) & + & + AM(ist+ 3) * v_org(i3 ) + AM(ist+ 4) * v_org(i4 ) & + & + AM(ist+ 5) * v_org(i5 ) + AM(ist+ 6) * v_org(i6 ) & + & + AM(ist+ 7) * v_org(i7 ) + AM(ist+ 8) * v_org(i8 ) & + & + AM(ist+ 9) * v_org(i9 ) + end do + end do +!$omp end parallel do +! + end subroutine itp_matvec_scalar_surf9 +! +! ---------------------------------------------------------------------- +! + subroutine itp_matvec_scalar_ele27(np_smp, NP, v_org, & + & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +! + use m_constants +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: NP + real (kind=kreal), intent(in) :: v_org(NP) +! + integer(kind = kint), intent(in) :: NC, NCM + integer(kind = kint), intent(in) :: IEND_SUM_smp(0:np_smp) + integer(kind = kint), intent(in) :: INM(0:NC) + integer(kind = kint), intent(in) :: IAM(NCM) + real(kind = kreal), intent(in) :: AM(NCM) +! + real (kind=kreal), intent(inout) :: vect(NC) +! + integer (kind = kint) :: ip, ist, ist_s, ied_s, ig + integer (kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 + integer (kind = kint) :: i9, i10, i11, i12, i13, i14, i15, i16 + integer (kind = kint) :: i17, i18, i19, i20, i21, i22, i23, i24 + integer (kind = kint) :: i25, i26, i27 +! +! +!$omp parallel do private(ist_s,ied_s,ig,ist,i1,i2,i3,i4,i5,i6,i7,i8,i9,& +!$omp& i10,i11,i12,i13,i14,i15,i16,i17,i18,i19,i20, & +!$omp& i21,i22,i23,i24,i25,i26,i27) + do ip = 1, np_smp + ist_s = IEND_SUM_smp(ip-1) + 1 + ied_s = IEND_SUM_smp(ip) + do ig = ist_s, ied_s + ist = INM(ig-1) +! + i1 = IAM(ist+ 1) + i2 = IAM(ist+ 2) + i3 = IAM(ist+ 3) + i4 = IAM(ist+ 4) + i5 = IAM(ist+ 5) + i6 = IAM(ist+ 6) + i7 = IAM(ist+ 7) + i8 = IAM(ist+ 8) + i9 = IAM(ist+ 9) + i10 = IAM(ist+10) + i11 = IAM(ist+11) + i12 = IAM(ist+12) + i13 = IAM(ist+13) + i14 = IAM(ist+14) + i15 = IAM(ist+15) + i16 = IAM(ist+16) + i17 = IAM(ist+17) + i18 = IAM(ist+18) + i19 = IAM(ist+19) + i20 = IAM(ist+20) + i21 = IAM(ist+21) + i22 = IAM(ist+22) + i23 = IAM(ist+23) + i24 = IAM(ist+24) + i25 = IAM(ist+25) + i26 = IAM(ist+26) + i27 = IAM(ist+27) +! + vect(ig) = AM(ist+ 1) * v_org(i1 ) + AM(ist+ 2) * v_org(i2 ) & + & + AM(ist+ 3) * v_org(i3 ) + AM(ist+ 4) * v_org(i4 ) & + & + AM(ist+ 5) * v_org(i5 ) + AM(ist+ 6) * v_org(i6 ) & + & + AM(ist+ 7) * v_org(i7 ) + AM(ist+ 8) * v_org(i8 ) & + & + AM(ist+ 9) * v_org(i9 ) + AM(ist+10) * v_org(i10) & + & + AM(ist+11) * v_org(i11) + AM(ist+12) * v_org(i12) & + & + AM(ist+13) * v_org(i13) + AM(ist+14) * v_org(i14) & + & + AM(ist+15) * v_org(i15) + AM(ist+16) * v_org(i16) & + & + AM(ist+17) * v_org(i17) + AM(ist+18) * v_org(i18) & + & + AM(ist+19) * v_org(i19) + AM(ist+20) * v_org(i20) & + & + AM(ist+21) * v_org(i21) + AM(ist+22) * v_org(i22) & + & + AM(ist+23) * v_org(i23) + AM(ist+24) * v_org(i24) & + & + AM(ist+25) * v_org(i25) + AM(ist+26) * v_org(i26) & + & + AM(ist+27) * v_org(i27) + end do + end do +!$omp end parallel do +! + end subroutine itp_matvec_scalar_ele27 +! +! ---------------------------------------------------------------------- +! + end module interpolate_scalar_ele27 diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_scalar_ele8.f90 b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_scalar_ele8.f90 new file mode 100644 index 00000000..f61d5255 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/interpolate_scalar_ele8.f90 @@ -0,0 +1,342 @@ +!>@file interpolate_scalar_ele8.f90 +!!@brief module interpolate_scalar_ele8 +!! +!!@author H. Matsui +!!@date Programmed by H. Matsui in July, 2006 +!!@n Modified by H. Matsui in Nov., 2013 +! +!> @brief Interpolation for scalar in tri-linear element +!! +!!@verbatim +!! subroutine itp_matvec_scalar_edge2(np_smp, numnod, v_org, & +!! & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +!! subroutine single_interpolate_scalar_ele8(numnod, numele, ie, & +!! & v_org, iele_gauss, xi_gauss, scalar) +!! subroutine s_interpolate_scalar_ele8(np_smp, numnod, numele, ie,& +!! & v_org, istack_smp, num_points, iele_gauss, & +!! & xi_gauss, vect) +!! +!! subroutine itp_matvec_scalar_node(np_smp, NP, v_org, & +!! & NC, NCM, INM, IAM, IEND_SUM_smp, vect) +!! subroutine itp_matvec_scalar_edge2(np_smp, NP, v_org, & +!! & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +!! subroutine itp_matvec_scalar_surf4(np_smp, NP, v_org, & +!! & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +!! subroutine itp_matvec_scalar_ele8(np_smp, NP, v_org, & +!! & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +!!@endverbatim +! + module interpolate_scalar_ele8 +! + use m_precision + use m_constants +! + implicit none +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine itp_matvec_scalar_edge2(np_smp, numnod, v_org, & + & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: numnod + real (kind=kreal), intent(in) :: v_org(numnod) +! + integer(kind = kint), intent(in) :: NC, NCM + integer(kind = kint), intent(in) :: IEND_SUM_smp(0:np_smp) + integer(kind = kint), intent(in) :: INM(0:NC) + integer(kind = kint), intent(in) :: IAM(NCM) + real(kind = kreal), intent(in) :: AM(NCM) +! + real (kind=kreal), intent(inout) :: vect(NC) +! + integer (kind = kint) :: ip, ist_s, ied_s, ist, ig + integer (kind = kint) :: i1, i2 +! +! +!$omp parallel do private(ist_s,ied_s,ist,ig,i1,i2) + do ip = 1, np_smp + ist_s = IEND_SUM_smp(ip-1) + 1 + ied_s = IEND_SUM_smp(ip) + do ig = ist_s, ied_s + ist = INM(ig-1) + i1 = IAM(ist+ 1) + i2 = IAM(ist+ 2) + vect(ig) = AM(ist+1) * v_org(i1 ) + AM(ist+2) * v_org(i2 ) + end do + end do +!$omp end parallel do +! + end subroutine itp_matvec_scalar_edge2 +! +! ---------------------------------------------------------------------- +! + subroutine single_interpolate_scalar_ele8(numnod, numele, ie, & + & v_org, iele_gauss, xi_gauss, scalar) +! + integer (kind = kint), intent(in) :: numnod, numele + integer (kind = kint), intent(in) :: ie(numele,8) + integer (kind = kint), intent(in) :: iele_gauss + real (kind=kreal), intent(in) :: xi_gauss(3) + real (kind=kreal), intent(in) :: v_org(numnod) +! + real (kind=kreal), intent(inout) :: scalar +! + real (kind=kreal) :: xi, ei, zi + real (kind=kreal) :: xi_nega, ei_nega, zi_nega + real (kind=kreal) :: xi_posi, ei_posi, zi_posi +! + real (kind=kreal) :: an1, an2, an3, an4, an5, an6, an7, an8 +! + integer (kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 +! + i1 = ie(iele_gauss,1) + i2 = ie(iele_gauss,2) + i3 = ie(iele_gauss,3) + i4 = ie(iele_gauss,4) + i5 = ie(iele_gauss,5) + i6 = ie(iele_gauss,6) + i7 = ie(iele_gauss,7) + i8 = ie(iele_gauss,8) +! + xi = xi_gauss(1) + ei = xi_gauss(2) + zi = xi_gauss(3) +! + xi_nega = one - xi + xi_posi = one + xi +! + ei_nega = one - ei + ei_posi = one + ei +! + zi_nega = one - zi + zi_posi = one + zi +! + an1 = r125 * xi_nega * ei_nega * zi_nega + an2 = r125 * xi_posi * ei_nega * zi_nega + an3 = r125 * xi_posi * ei_posi * zi_nega + an4 = r125 * xi_nega * ei_posi * zi_nega + an5 = r125 * xi_nega * ei_nega * zi_posi + an6 = r125 * xi_posi * ei_nega * zi_posi + an7 = r125 * xi_posi * ei_posi * zi_posi + an8 = r125 * xi_nega * ei_posi * zi_posi +! +! + scalar = an1 * v_org(i1 ) + an2 * v_org(i2 ) & + & + an3 * v_org(i3 ) + an4 * v_org(i4 ) & + & + an5 * v_org(i5 ) + an6 * v_org(i6 ) & + & + an7 * v_org(i7 ) + an8 * v_org(i8 ) +! + end subroutine single_interpolate_scalar_ele8 +! +! ---------------------------------------------------------------------- +! + subroutine s_interpolate_scalar_ele8(np_smp, numnod, numele, ie, & + & v_org, istack_smp, num_points, iele_gauss, & + & xi_gauss, vect) +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: numnod, numele + integer (kind = kint), intent(in) :: ie(numele,8) + integer (kind = kint), intent(in) :: istack_smp(0:np_smp) + integer (kind = kint), intent(in) :: num_points + integer (kind = kint), intent(in) :: iele_gauss(num_points) + real (kind=kreal), intent(in) :: xi_gauss(num_points,3) + real (kind=kreal), intent(in) :: v_org(numnod) +! + real (kind=kreal), intent(inout) :: vect(num_points) +! + real (kind=kreal) :: xi, ei, zi + real (kind=kreal) :: xi_nega, ei_nega, zi_nega + real (kind=kreal) :: xi_posi, ei_posi, zi_posi +! + real (kind=kreal) :: an1, an2, an3, an4, an5, an6, an7, an8 +! + integer (kind = kint) :: ip, ist, ied + integer (kind = kint) :: iele, i1, i2, i3, i4, i5, i6, i7, i8 +! + integer (kind = kint) :: ig +! +! +!$omp parallel do private(ist,ied,ig,iele,i1,i2,i3,i4,i5,i6,i7,i8, & +!$omp& xi,ei,zi,xi_nega, xi_posi, ei_nega, ei_posi, & +!$omp& zi_nega, zi_posi, an1,an2,an3,an4,an5,an6, & +!$omp& an7,an8) + do ip = 1, np_smp + ist = istack_smp(ip-1) + 1 + ied = istack_smp(ip) + do ig = ist, ied +! + iele = iele_gauss(ig) +! + i1 = ie(iele,1) + i2 = ie(iele,2) + i3 = ie(iele,3) + i4 = ie(iele,4) + i5 = ie(iele,5) + i6 = ie(iele,6) + i7 = ie(iele,7) + i8 = ie(iele,8) +! + xi = xi_gauss(ig,1) + ei = xi_gauss(ig,2) + zi = xi_gauss(ig,3) +! + xi_nega = one - xi + xi_posi = one + xi +! + ei_nega = one - ei + ei_posi = one + ei +! + zi_nega = one - zi + zi_posi = one + zi +! + an1 = r125 * xi_nega * ei_nega * zi_nega + an2 = r125 * xi_posi * ei_nega * zi_nega + an3 = r125 * xi_posi * ei_posi * zi_nega + an4 = r125 * xi_nega * ei_posi * zi_nega + an5 = r125 * xi_nega * ei_nega * zi_posi + an6 = r125 * xi_posi * ei_nega * zi_posi + an7 = r125 * xi_posi * ei_posi * zi_posi + an8 = r125 * xi_nega * ei_posi * zi_posi +! +! + vect(ig) = an1 * v_org(i1 ) + an2 * v_org(i2 ) & + & + an3 * v_org(i3 ) + an4 * v_org(i4 ) & + & + an5 * v_org(i5 ) + an6 * v_org(i6 ) & + & + an7 * v_org(i7 ) + an8 * v_org(i8 ) +! + end do + end do +!$omp end parallel do +! + end subroutine s_interpolate_scalar_ele8 +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine itp_matvec_scalar_node(np_smp, NP, v_org, & + & NC, NCM, INM, IAM, IEND_SUM_smp, vect) +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: NP + real (kind=kreal), intent(in) :: v_org(NP) +! + integer(kind = kint), intent(in) :: NC, NCM + integer(kind = kint), intent(in) :: IEND_SUM_smp(0:np_smp) + integer(kind = kint), intent(in) :: INM(0:NC) + integer(kind = kint), intent(in) :: IAM(NCM) +! + real (kind=kreal), intent(inout) :: vect(NC) +! + integer (kind = kint) :: ip, ist_s, ied_s, ist, ig + integer (kind = kint) :: i1 +! +! +!$omp parallel do private(ist_s,ied_s,ist,ig,i1) + do ip = 1, np_smp + ist_s = IEND_SUM_smp(ip-1) + 1 + ied_s = IEND_SUM_smp(ip) + do ig = ist_s, ied_s + ist = INM(ig-1) + i1 = IAM(ist+ 1) + vect(ig) = v_org(i1 ) + end do + end do +!$omp end parallel do +! + end subroutine itp_matvec_scalar_node +! +! ---------------------------------------------------------------------- +! + subroutine itp_matvec_scalar_surf4(np_smp, NP, v_org, & + & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: NP + real (kind=kreal), intent(in) :: v_org(NP) +! + integer(kind = kint), intent(in) :: NC, NCM + integer(kind = kint), intent(in) :: IEND_SUM_smp(0:np_smp) + integer(kind = kint), intent(in) :: INM(0:NC) + integer(kind = kint), intent(in) :: IAM(NCM) + real(kind = kreal), intent(in) :: AM(NCM) +! + real (kind=kreal), intent(inout) :: vect(NC) +! + integer (kind = kint) :: ip, ist_s, ied_s, ist, ig + integer (kind = kint) :: i1, i2, i3, i4 +! +! +!$omp parallel do private(ist_s,ied_s,ist,ig,i1,i2,i3,i4) + do ip = 1, np_smp + ist_s = IEND_SUM_smp(ip-1) + 1 + ied_s = IEND_SUM_smp(ip) + do ig = ist_s, ied_s + ist = INM(ig-1) + i1 = IAM(ist+ 1) + i2 = IAM(ist+ 2) + i3 = IAM(ist+ 3) + i4 = IAM(ist+ 4) +! + vect(ig) = AM(ist+1) * v_org(i1 ) + AM(ist+2) * v_org(i2 ) & + + AM(ist+3) * v_org(i3 ) + AM(ist+4) * v_org(i4 ) + end do + end do +!$omp end parallel do +! + end subroutine itp_matvec_scalar_surf4 +! +! ---------------------------------------------------------------------- +! + subroutine itp_matvec_scalar_ele8(np_smp, NP, v_org, & + & NC, NCM, INM, IAM, AM, IEND_SUM_smp, vect) +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: NP + real (kind=kreal), intent(in) :: v_org(NP) +! + integer(kind = kint), intent(in) :: NC, NCM + integer(kind = kint), intent(in) :: IEND_SUM_smp(0:np_smp) + integer(kind = kint), intent(in) :: INM(0:NC) + integer(kind = kint), intent(in) :: IAM(NCM) + real(kind = kreal), intent(in) :: AM(NCM) +! + real (kind=kreal), intent(inout) :: vect(NC) +! + integer (kind = kint) :: ip, ist_s, ied_s, ist, ig + integer (kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 +! +! +!$omp parallel do private(ist_s,ied_s,ist,ig,i1,i2,i3,i4,i5,i6,i7,i8) + do ip = 1, np_smp + ist_s = IEND_SUM_smp(ip-1) + 1 + ied_s = IEND_SUM_smp(ip) + do ig = ist_s, ied_s + ist = INM(ig-1) + i1 = IAM(ist+ 1) + i2 = IAM(ist+ 2) + i3 = IAM(ist+ 3) + i4 = IAM(ist+ 4) + i5 = IAM(ist+ 5) + i6 = IAM(ist+ 6) + i7 = IAM(ist+ 7) + i8 = IAM(ist+ 8) +! + vect(ig) = AM(ist+1) * v_org(i1 ) + AM(ist+2) * v_org(i2 ) & + + AM(ist+3) * v_org(i3 ) + AM(ist+4) * v_org(i4 ) & + + AM(ist+5) * v_org(i5 ) + AM(ist+6) * v_org(i6 ) & + + AM(ist+7) * v_org(i7 ) + AM(ist+8) * v_org(i8 ) + end do + end do +!$omp end parallel do +! + end subroutine itp_matvec_scalar_ele8 +! +! ---------------------------------------------------------------------- +! + end module interpolate_scalar_ele8 diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/modify_local_positions.f90 b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/modify_local_positions.f90 new file mode 100644 index 00000000..a3857f4b --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/modify_local_positions.f90 @@ -0,0 +1,161 @@ +!>@file modify_local_positions.f90 +!!@brief module modify_local_positions +!! +!!@date Programmed by H.Matsui in Aug. 2011 +! +!>@brief find point in one element and return local coordinate +!! +!!@verbatim +!! subroutine s_modify_local_positions(maxitr, eps_iter, xi, & +!! & x_target, nnod_ele_2, x_local_ele, iflag_message, & +!! & differ, ierr_modify) +!! subroutine modify_local_positions_no_fix(maxitr, eps_iter, xi, & +!! & x_target, nnod_ele_2, x_local_ele, iflag_message, & +!! & differ, ierr_modify) +!!@verbatim +! + module modify_local_positions +! + use m_precision +! + use solver_33_array + use cal_position_and_grad +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_modify_local_positions(maxitr, eps_iter, xi, & + & x_target, nnod_ele_2, x_local_ele, iflag_message, & + & differ, ierr_modify) +! + integer(kind= kint), intent(in) :: iflag_message + integer(kind= kint), intent(in) :: maxitr + real(kind = kreal), intent(in) :: x_target(3) + real(kind = kreal), intent(in) :: eps_iter + integer(kind= kint), intent(in) :: nnod_ele_2 + real(kind = kreal), intent(in) :: x_local_ele(nnod_ele_2,3) +! + real(kind = kreal), intent(inout) :: differ + real(kind = kreal), intent(inout) :: xi(3) + integer (kind = kint), intent(inout) :: ierr_modify +! + integer (kind = kint) :: nd, iter + real(kind=kreal) :: s_correct(3), differ_prev +! + real(kind=kreal) :: dx(3), xx_z(3) + real(kind=kreal) :: dnxi(3), dnei(3), dnzi(3) + real(kind=kreal) :: dnxi_mat(3,3) +! +! + ierr_modify = maxitr + 1 + do nd = 1, 3 + if ( xi(nd) .gt. 1.0d0 ) xi(nd) = 1.0d0 + if ( xi(nd) .lt. -1.0d0 ) xi(nd) =-1.0d0 + end do +! + do iter = 1, maxitr + call cal_position_and_gradient(nnod_ele_2, xx_z, & + & dnxi, dnei, dnzi, x_local_ele, xi) +! + dx(1:3) = xx_z(1:3)-x_target(1:3) + differ = sqrt( dx(1)**2 + dx(2)**2 + dx(3)**2 ) +! +! if (iflag_message .eq. 1) then +! write(60+my_rank,*) 'iteration, differ', iter, differ +! write(60+my_rank,*) xx_z(1:3) +! write(60+my_rank,*) x_target(1:3) +! write(60+my_rank,*) dnxi, dnei, dnzi +! end if +! +! + if ( differ .lt. eps_iter) then + ierr_modify = iter + exit + end if +! + if (iter.gt.3 .and. abs(differ-differ_prev).lt.eps_iter) then + ierr_modify = -iter + exit + end if + differ_prev = differ +! + dnxi_mat(1:3,1) = dnxi(1:3) + dnxi_mat(1:3,2) = dnei(1:3) + dnxi_mat(1:3,3) = dnzi(1:3) + call solve_33_array(s_correct, dx, dnxi_mat) +! + xi(1:3) = xi(1:3) - s_correct(1:3) +! + do nd = 1, 3 + if ( xi(nd) .gt. 1.0d0 ) xi(nd) = 1.0d0 + if ( xi(nd) .lt. -1.0d0 ) xi(nd) =-1.0d0 + end do +! + end do +! + end subroutine s_modify_local_positions +! +!----------------------------------------------------------------------- +! + subroutine modify_local_positions_no_fix(maxitr, eps_iter, xi, & + & x_target, nnod_ele_2, x_local_ele, iflag_message, & + & differ, ierr_modify) +! + integer(kind= kint), intent(in) :: iflag_message + integer(kind= kint), intent(in) :: maxitr + real(kind = kreal), intent(in) :: x_target(3) + real(kind = kreal), intent(in) :: eps_iter + integer(kind= kint), intent(in) :: nnod_ele_2 + real(kind = kreal), intent(in) :: x_local_ele(nnod_ele_2,3) +! + real(kind = kreal), intent(inout) :: differ + real(kind = kreal), intent(inout) :: xi(3) + integer (kind = kint), intent(inout) :: ierr_modify +! + integer (kind = kint) :: nd, iter + real(kind=kreal) :: s_correct(3) +! + real(kind=kreal) :: dx(3), xx_z(3) + real(kind=kreal) :: dnxi(3), dnei(3), dnzi(3) + real(kind=kreal) :: dnxi_mat(3,3) +! +! + ierr_modify = maxitr + 1 + do iter = 1, maxitr + call cal_position_and_gradient(nnod_ele_2, xx_z, & + & dnxi, dnei, dnzi, x_local_ele, xi) +! + dx(1:3) = xx_z(1:3)-x_target(1:3) + differ = sqrt( dx(1)**2 + dx(2)**2 + dx(3)**2 ) +! +! if (iflag_message .eq. 1) then +! write(60+my_rank,*) 'iteration, differ', iter, differ +! write(60+my_rank,*) xx_z(1:3) +! write(60+my_rank,*) x_target(1:3) +! write(60+my_rank,*) dnxi, dnei, dnzi +! end if +! + if ( differ .lt. eps_iter) then + ierr_modify = iter + exit + end if +! + dnxi_mat(1:3,1) = dnxi(1:3) + dnxi_mat(1:3,2) = dnei(1:3) + dnxi_mat(1:3,3) = dnzi(1:3) + call solve_33_array(s_correct, dx, dnxi_mat) +! + xi(1:3) = xi(1:3) - s_correct(1:3) +! + end do +! + end subroutine modify_local_positions_no_fix +! +!----------------------------------------------------------------------- +! + end module modify_local_positions diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/sel_interpolate_scalar.f90 b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/sel_interpolate_scalar.f90 new file mode 100644 index 00000000..8d102789 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/sel_interpolate_scalar.f90 @@ -0,0 +1,116 @@ +!>@file sel_interpolate_scalar.f90 +!!@brief module sel_interpolate_scalar.f90 +!! +!!@author H. Matsui +!!@date Programmed in Sep., 2006 +! +!>@brief interpolation on each subdomains +!! +!!@verbatim +!! subroutine sel_sgl_interpolate_scalar_ele & +!! & (numnod, numele, nnod_4_ele, ie, v_org, iele_gauss, & +!! & xi_gauss, vect) +!! integer (kind = kint), intent(in) :: numnod, numele, nnod_4_ele +!! integer (kind = kint), intent(in) :: ie(numele,nnod_4_ele) +!! integer (kind = kint), intent(in) :: iele_gauss +!! real (kind=kreal), intent(in) :: xi_gauss(3) +!! real (kind=kreal), intent(in) :: v_org(numnod) +!! real (kind=kreal), intent(inout) :: vect +!! subroutine s_sel_interpolate_scalar_ele & +!! & (np_smp, numnod, numele, nnod_4_ele, ie, & +!! & v_org, istack_smp, num_points, iele_gauss, & +!! & xi_gauss, vect) +!! integer (kind = kint), intent(in) :: np_smp +!! integer (kind = kint), intent(in) :: numnod, numele +!! integer (kind = kint), intent(in) :: ie(numele,20) +!! integer (kind = kint), intent(in) :: istack_smp(0:np_smp) +!! integer (kind = kint), intent(in) :: num_points +!! integer (kind = kint), intent(in) :: iele_gauss(num_points) +!! real (kind=kreal), intent(in) :: xi_gauss(num_points,3) +!! real (kind=kreal), intent(in) :: v_org(numnod) +!! real (kind=kreal), intent(inout) :: vect(num_points) +!!@endverbatim +! + module sel_interpolate_scalar +! + use m_precision + use m_geometry_constants +! + implicit none +! +!------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------ +! + subroutine sel_sgl_interpolate_scalar_ele & + & (numnod, numele, nnod_4_ele, ie, v_org, iele_gauss, & + & xi_gauss, vect) +! + use interpolate_scalar_ele8 + use interpolate_scalar_ele20 + use interpolate_scalar_ele27 +! + integer (kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer (kind = kint), intent(in) :: ie(numele,nnod_4_ele) + integer (kind = kint), intent(in) :: iele_gauss + real (kind=kreal), intent(in) :: xi_gauss(3) + real (kind=kreal), intent(in) :: v_org(numnod) +! + real (kind=kreal), intent(inout) :: vect +! + if (nnod_4_ele .eq. num_t_linear) then + call single_interpolate_scalar_ele8(numnod, numele, ie, v_org, & + & iele_gauss, xi_gauss, vect) + else if(nnod_4_ele .eq. num_t_quad) then + call single_interpolate_scalar_ele27(numnod, numele, ie, v_org, & + & iele_gauss, xi_gauss, vect) + else if(nnod_4_ele .eq. num_t_lag) then + call single_interpolate_scalar_ele20(numnod, numele, ie, v_org, & + & iele_gauss, xi_gauss, vect) + end if +! + end subroutine sel_sgl_interpolate_scalar_ele +! +!------------------------------------------------------------------ +! + subroutine s_sel_interpolate_scalar_ele & + & (np_smp, numnod, numele, nnod_4_ele, ie, & + & v_org, istack_smp, num_points, iele_gauss, & + & xi_gauss, vect) +! + use interpolate_scalar_ele8 + use interpolate_scalar_ele20 + use interpolate_scalar_ele27 +! + integer (kind = kint), intent(in) :: np_smp + integer (kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer (kind = kint), intent(in) :: ie(numele,nnod_4_ele) + integer (kind = kint), intent(in) :: istack_smp(0:np_smp) + integer (kind = kint), intent(in) :: num_points + integer (kind = kint), intent(in) :: iele_gauss(num_points) + real (kind=kreal), intent(in) :: xi_gauss(num_points,3) + real (kind=kreal), intent(in) :: v_org(numnod) +! + real (kind=kreal), intent(inout) :: vect(num_points) +! + if (nnod_4_ele .eq. num_t_linear) then + call s_interpolate_scalar_ele8 & + & (np_smp, numnod, numele, ie, v_org, istack_smp, & + & num_points, iele_gauss, xi_gauss, vect) + else if(nnod_4_ele .eq. num_t_quad) then + call s_interpolate_scalar_ele27 & + & (np_smp, numnod, numele, ie, v_org, istack_smp, & + & num_points, iele_gauss, xi_gauss, vect) + else if(nnod_4_ele .eq. num_t_lag) then + call s_interpolate_scalar_ele20 & + & (np_smp, numnod, numele, ie, v_org, istack_smp, & + & num_points, iele_gauss, xi_gauss, vect) + end if +! + end subroutine s_sel_interpolate_scalar_ele +! +!------------------------------------------------------------------ +! + end module sel_interpolate_scalar diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/t_find_interpolate_in_ele.f90 b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/t_find_interpolate_in_ele.f90 new file mode 100644 index 00000000..4171b3fb --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/t_find_interpolate_in_ele.f90 @@ -0,0 +1,344 @@ +!>@file t_find_interpolate_in_ele.f90 +!!@brief module t_find_interpolate_in_ele +!! +!!@date Programmed by H.Matsui in Aug. 2011 +! +!>@brief find point in one element and return local coordinate +!! +!!@verbatim +!! subroutine alloc_work_4_interpolate(nnod_4_ele, itp_ele_work) +!! subroutine dealloc_work_4_interpolate(itp_ele_work) +!! type(cal_interpolate_coefs_work), intent(inout) :: itp_ele_work +!! +!! subroutine find_interpolate_in_ele(x_target, maxitr, eps_iter, & +!! & my_rank, iflag_message, error_level, & +!! & org_node, org_ele, jele, itp_ele_work, xi, ierr_inter) +!! real(kind=kreal), intent(in) :: x_target(3) +!! real(kind=kreal), intent(in) :: eps_iter +!! integer(kind = kint), intent(in) :: maxitr +!! type(node_data), intent(in) :: org_node +!! type(element_data), intent(in) :: org_ele +!! integer(kind = kint), intent(in) :: jele +!! integer, intent(in) :: my_rank +!! integer(kind = kint), intent(in) :: iflag_message +!! real(kind = kreal), intent(in) :: error_level +!! type(cal_interpolate_coefs_work), intent(inout) :: itp_ele_work +!! integer(kind = kint), intent(inout) :: ierr_inter +!! real(kind=kreal), intent(inout) :: xi(3) +!!@endverbatim +! + module t_find_interpolate_in_ele +! + use m_precision + use m_constants +! + implicit none +! + type cal_interpolate_coefs_work + real(kind=kreal), allocatable :: coefs_by_tet(:) + real(kind=kreal), allocatable :: x_local_ele(:,:) + real(kind=kreal) :: differ_tmp + real(kind=kreal) :: differ_res +! + integer(kind = kint) :: iflag_org_tmp + end type cal_interpolate_coefs_work +! + private :: adjust_to_corner, force_interpolate_in_element + private :: cal_3vector_4_tet_2nd +! private :: copy_position_2_2nd_local_ele + private :: check_solution_in_tet +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine alloc_work_4_interpolate(nnod_4_ele, itp_ele_work) +! + integer(kind = kint), intent(in) :: nnod_4_ele + type(cal_interpolate_coefs_work), intent(inout) :: itp_ele_work +! + allocate( itp_ele_work%coefs_by_tet(nnod_4_ele) ) + allocate( itp_ele_work%x_local_ele(nnod_4_ele,3) ) +! + itp_ele_work%coefs_by_tet = 0.0d0 + itp_ele_work%x_local_ele = 0.0d0 + itp_ele_work%differ_tmp = 0.0d0 + itp_ele_work%differ_res = 0.0d0 +! + end subroutine alloc_work_4_interpolate +! +! ---------------------------------------------------------------------- +! + subroutine dealloc_work_4_interpolate(itp_ele_work) +! + type(cal_interpolate_coefs_work), intent(inout) :: itp_ele_work +! + deallocate(itp_ele_work%coefs_by_tet) + deallocate(itp_ele_work%x_local_ele) +! + end subroutine dealloc_work_4_interpolate +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine find_interpolate_in_ele(x_target, maxitr, eps_iter, & + & my_rank, iflag_message, error_level, & + & org_node, org_ele, jele, itp_ele_work, xi, ierr_inter) +! + use m_connect_hexa_2_tetra + use cal_local_position_by_tetra + use modify_local_positions + use solver_33_array +! + use t_geometry_data + use t_interpolate_coefs_dest +! + real(kind=kreal), intent(in) :: x_target(3) + real(kind=kreal), intent(in) :: eps_iter + integer(kind = kint), intent(in) :: maxitr +! + type(node_data), intent(in) :: org_node + type(element_data), intent(in) :: org_ele + integer(kind = kint), intent(in) :: jele +! + integer, intent(in) :: my_rank + integer(kind = kint), intent(in) :: iflag_message + real(kind = kreal), intent(in) :: error_level +! + type(cal_interpolate_coefs_work), intent(inout) :: itp_ele_work + integer(kind = kint), intent(inout) :: ierr_inter + real(kind=kreal), intent(inout) :: xi(3) +! + real(kind=kreal) :: s_coef(3) + real(kind=kreal) :: v_tetra(3,3) + real(kind=kreal) :: v_target(3) + real(kind=kreal) :: ref_error +! + integer (kind = kint) :: itet, i +! +! + ierr_inter = 1 +! + call copy_position_2_2nd_local_ele(org_node, org_ele, & + & jele, itp_ele_work%x_local_ele) +! + do itet = 1, num_tetra + call cal_3vector_4_tet_2nd(org_ele%nnod_4_ele, itet, & + & v_target, v_tetra, x_target, itp_ele_work%x_local_ele) +! +! solve equations +! + call solve_33_array(s_coef, v_target, v_tetra) +! +! check solution +! + call check_solution_in_tet(ref_error, s_coef) +! +! satisfy the error level +! + if(abs(ref_error) .le. error_level) then +! + call init_coefs_on_tet(org_ele%nnod_4_ele, itet, & + & itp_ele_work%coefs_by_tet, s_coef) +! + call s_cal_local_position_by_tetra(org_ele%nnod_4_ele, xi, & + & itp_ele_work%coefs_by_tet) +! + if (iflag_message .eq. 1) then + do i = 1, org_ele%nnod_4_ele + write(my_rank+60,*) i, jele, & + & itp_ele_work%x_local_ele(i,1:3) + end do + write(my_rank+60,*) 's_coef', s_coef + end if +! +! improve solution +! + call s_modify_local_positions(maxitr, eps_iter, xi, x_target, & + & org_ele%nnod_4_ele, itp_ele_work%x_local_ele, & + & iflag_message, itp_ele_work%differ_res, ierr_inter) +! +! finish improvement +! + if(ierr_inter.gt.0 .and. ierr_inter.le.maxitr) then + call adjust_to_corner(eps_iter, xi) + return + else + if (iflag_message .eq. 1) then + write(my_rank+60,*) & + & 'improvement failed!!: jele, itet:', my_rank, & + & itp_ele_work%differ_tmp, itp_ele_work%differ_res, & + & jele, itet, xi + if (itp_ele_work%differ_res & + & .lt. itp_ele_work%differ_tmp) then + call force_interpolate_in_element(xi) + itp_ele_work%differ_tmp = itp_ele_work%differ_res + end if + end if + end if +! + end if + end do +! + end subroutine find_interpolate_in_ele +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine adjust_to_corner(epcilon, xi) +! + real(kind = kreal), intent(in) :: epcilon + real(kind = kreal), intent(inout) :: xi(3) +! + integer(kind = kint) :: nd +! +! + do nd = 1, 3 + if(abs(xi(nd) - one) .lt. epcilon) then + xi(nd) = one + else if(abs(xi(nd) + one) .lt. epcilon) then + xi(nd) = -one + end if + end do +! + end subroutine adjust_to_corner +! +!----------------------------------------------------------------------- +! + subroutine force_interpolate_in_element(xi) +! + real(kind = kreal), intent(inout) :: xi(3) +! + integer(kind = kint) :: nd +! + do nd = 1, 3 + if ( xi(nd) .gt. one) then + xi(nd) = one + else if ( xi(nd) .lt. -one) then + xi(nd) = -one + end if + end do +! + end subroutine force_interpolate_in_element +! +!----------------------------------------------------------------------- +! + subroutine init_coefs_on_tet(nnod_4_ele_2, itet, coefs_by_tet, s) +! + use m_constants + use m_connect_hexa_2_tetra +! + integer(kind = kint), intent(in) :: itet, nnod_4_ele_2 + real(kind = kreal), intent(in) :: s(3) + real(kind = kreal), intent(inout) :: coefs_by_tet(nnod_4_ele_2) +! + integer(kind = kint) :: i1, i2, i3, i4 +! +! + coefs_by_tet(1:nnod_4_ele_2) = zero +! + i1 = ie_tetra(1,itet) + i2 = ie_tetra(2,itet) + i3 = ie_tetra(3,itet) + i4 = ie_tetra(4,itet) +! + coefs_by_tet(i1) = one - ( s(1) + s(2) + s(3) ) + coefs_by_tet(i2) = s(1) + coefs_by_tet(i3) = s(2) + coefs_by_tet(i4) = s(3) +! + end subroutine init_coefs_on_tet +! +!----------------------------------------------------------------------- +! + subroutine cal_3vector_4_tet_2nd(nnod_4_ele_2, itet, & + & v_target, v_tetra, x_target, x_local) +! + use m_connect_hexa_2_tetra +! + integer(kind = kint), intent(in) :: itet, nnod_4_ele_2 + real(kind = kreal), intent(in) :: x_target(3) + real(kind = kreal), intent(in) :: x_local(nnod_4_ele_2,3) +! + real(kind = kreal), intent(inout) :: v_target(3) + real(kind = kreal), intent(inout) :: v_tetra(3,3) +! + integer(kind = kint) :: nd +! +! + do nd = 1, 3 +! + v_target(nd) = x_target(nd) & + & - x_local(ie_tetra(1,itet),nd) +! + v_tetra(nd,1) = x_local(ie_tetra(2,itet),nd) & + & - x_local(ie_tetra(1,itet),nd) + v_tetra(nd,2) = x_local(ie_tetra(3,itet),nd) & + & - x_local(ie_tetra(1,itet),nd) + v_tetra(nd,3) = x_local(ie_tetra(4,itet),nd) & + & - x_local(ie_tetra(1,itet),nd) + end do +! + end subroutine cal_3vector_4_tet_2nd +! +!----------------------------------------------------------------------- +! + subroutine copy_position_2_2nd_local_ele(new_node, new_ele, & + & iele, x_local) +! + use t_geometry_data +! + integer(kind = kint), intent(in) :: iele + type(node_data), intent(in) :: new_node + type(element_data), intent(in) :: new_ele +! + real(kind = kreal), intent(inout) & + & :: x_local(new_ele%nnod_4_ele,3) +! + integer(kind = kint) :: i, inod +! +! + do i = 1, new_ele%nnod_4_ele + inod = new_ele%ie(iele,i) + x_local(i,1:3) = new_node%xx(inod,1:3) + end do +! + end subroutine copy_position_2_2nd_local_ele +! +!----------------------------------------------------------------------- +! + subroutine check_solution_in_tet(ref_error, s_coef) +! + use m_constants +! + real(kind = kreal), intent(in) :: s_coef(3) + real(kind = kreal), intent(inout) :: ref_error +! + real(kind = kreal) :: sum_tmp + integer (kind = kint) :: nd +! +! + sum_tmp = s_coef(1) + s_coef(2) + s_coef(3) +! + ref_error = zero + do nd = 1, 3 + if ( s_coef(nd) .lt. zero) then + ref_error = ref_error - s_coef(nd) + else if ( s_coef(nd) .gt. one) then + ref_error = ref_error + s_coef(nd) - one + end if + end do +! + if ( sum_tmp .lt. zero) then + ref_error = ref_error - sum_tmp + else if ( sum_tmp .gt. one) then + ref_error = ref_error + sum_tmp - one + end if +! + end subroutine check_solution_in_tet +! +!----------------------------------------------------------------------- +! + end module t_find_interpolate_in_ele diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/t_interpolate_coefs_dest.f90 b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/t_interpolate_coefs_dest.f90 new file mode 100644 index 00000000..fbb3a3f6 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/t_interpolate_coefs_dest.f90 @@ -0,0 +1,141 @@ +!>@file t_interpolate_coefs_dest.f90 +!!@brief module t_interpolate_coefs_dest +!! +!!@author H. Matsui +!!@date Programmed by H. Matsui in Aug., 2006 +! +!> @brief Interpolation coefficients on target mesh +!!@verbatim +!! subroutine alloc_itp_coef_dest(itp_dest, coef_dest) +!! subroutine dealloc_itp_coef_stack(coef_dest) +!! subroutine dealloc_itp_coef_dest(coef_dest) +!! +!! subroutine check_table_in_org_2(id_file, itp_dest, coef_dest) +!!@endverbatim +! +! + module t_interpolate_coefs_dest +! + use m_precision + use t_interpolate_tbl_dest +! + implicit none +! +! +!> Structure of interpolation coefficients for target grid + type interpolate_coefs_dest +!> global node ID for target domain + integer(kind = kint_gl), allocatable :: inod_gl_dest(:) +!> local element ID to make interpolation + integer(kind = kint), allocatable :: iele_org_4_dest(:) +!> interpolation type ID + integer(kind = kint), allocatable :: itype_inter_dest(:) +!> Coordinate of target node in element coordinate + real(kind = kreal), allocatable :: coef_inter_dest(:,:) +! +!> end address to receive interpolated data including interpolate type + integer(kind = kint), allocatable & + & :: istack_nod_tbl_wtype_dest(:) + end type interpolate_coefs_dest +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine alloc_itp_coef_stack(num_org_pe, coef_dest) +! + integer(kind = kint), intent(in) :: num_org_pe + type(interpolate_coefs_dest), intent(inout) :: coef_dest +! +! + allocate(coef_dest%istack_nod_tbl_wtype_dest(0:4*num_org_pe) ) + coef_dest%istack_nod_tbl_wtype_dest = -1 +! + end subroutine alloc_itp_coef_stack +! +!----------------------------------------------------------------------- +! + subroutine alloc_itp_coef_dest(itp_dest, coef_dest) +! + type(interpolate_table_dest), intent(in) :: itp_dest + type(interpolate_coefs_dest), intent(inout) :: coef_dest +! +! + allocate(coef_dest%inod_gl_dest(itp_dest%ntot_table_dest) ) + allocate(coef_dest%iele_org_4_dest(itp_dest%ntot_table_dest) ) + allocate(coef_dest%itype_inter_dest(itp_dest%ntot_table_dest) ) + allocate(coef_dest%coef_inter_dest(itp_dest%ntot_table_dest,3) ) +! + if(itp_dest%ntot_table_dest .gt. 0) then + coef_dest%inod_gl_dest = 0 + coef_dest%iele_org_4_dest = 0 + coef_dest%itype_inter_dest = -1 + coef_dest%coef_inter_dest = 0.0d0 + end if +! + end subroutine alloc_itp_coef_dest +! +!----------------------------------------------------------------------- +! + subroutine dealloc_itp_coef_stack(coef_dest) +! + type(interpolate_coefs_dest), intent(inout) :: coef_dest +! +! + deallocate(coef_dest%istack_nod_tbl_wtype_dest) +! + end subroutine dealloc_itp_coef_stack +! +!----------------------------------------------------------------------- +! + subroutine dealloc_itp_coef_dest(coef_dest) +! + type(interpolate_coefs_dest), intent(inout) :: coef_dest +! +! + deallocate(coef_dest%inod_gl_dest, coef_dest%iele_org_4_dest) + deallocate(coef_dest%itype_inter_dest, coef_dest%coef_inter_dest) +! + end subroutine dealloc_itp_coef_dest +! +!----------------------------------------------------------------------- +! + subroutine check_table_in_org_2(id_file, itp_dest, coef_dest) +! + integer(kind = kint), intent(in) :: id_file + type(interpolate_table_dest), intent(inout) :: itp_dest + type(interpolate_coefs_dest), intent(inout) :: coef_dest +! + integer(kind = kint) :: inod +! + write(id_file,'(a)') '#' + write(id_file,'(a)') '# number of domain of target' + write(id_file,'(a)') '# domain IDs' + write(id_file,'(a)') '#' +! + write(id_file,'(i16)') itp_dest%num_org_domain + write(id_file,'(10i16)') & + & itp_dest%id_org_domain(1:itp_dest%num_org_domain) +! + write(id_file,'(a)') '#' + write(id_file,'(a)') & + & '# node, domain for original, belonged element' + write(id_file,'(a)') '# coefficients' + write(id_file,'(a)') '#' +! + write(id_file,'(10i16)') & + & itp_dest%istack_nod_tbl_dest(1:itp_dest%num_org_domain) + do inod = 1, itp_dest%ntot_table_dest + write(id_file,'(2i16,1p3E25.15e3)') & + & itp_dest%inod_dest_4_dest(inod), & + & coef_dest%iele_org_4_dest(inod), & + & coef_dest%coef_inter_dest(inod,1:3) + end do +! + end subroutine check_table_in_org_2 +! +!----------------------------------------------------------------------- +! + end module t_interpolate_coefs_dest diff --git a/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/t_interpolate_tbl_dest.f90 b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/t_interpolate_tbl_dest.f90 new file mode 100644 index 00000000..ac86b012 --- /dev/null +++ b/src/Fortran_libraries/PARALLEL_src/INTERPOLATE/t_interpolate_tbl_dest.f90 @@ -0,0 +1,136 @@ +!>@file t_interpolate_tbl_dest.f90 +!!@brief module t_interpolate_tbl_dest +!! +!!@author H. Matsui +!!@date Programmed by H. Matsui in Nov., 2008 +! +!> @brief Structure of interpolation table for target mesh +!! +!!@verbatim +!! subroutine set_num_org_domain(num_org_pe, tbl_dest) +!! subroutine alloc_type_itp_num_dest(tbl_dest) +!! subroutine alloc_itp_table_dest(tbl_dest) +!! subroutine alloc_type_zero_itp_tbl_dest(tbl_dest) +!! +!! subroutine dealloc_itp_num_dest(tbl_dest) +!! subroutine dealloc_itp_table_dest(tbl_dest) +!!@endverbatim +! + module t_interpolate_tbl_dest +! + use m_precision + use m_constants +! + implicit none +! +! +!> Structure of interpolation table for target grid + type interpolate_table_dest +! +!> number of subdomain to receive interpolated data + integer(kind = kint) :: num_org_domain +!> flag if original nodes have same prosess + integer(kind = kint) :: iflag_self_itp_recv +!> subdomain rank to receive interpolated data + integer(kind = kint), allocatable :: id_org_domain(:) +!> end address to receive interpolated data + integer(kind = kint), allocatable :: istack_nod_tbl_dest(:) +! +!> total number of interpolated node in target subdomain + integer(kind = kint) :: ntot_table_dest +!> local node ID to set interpolated data (import) + integer(kind = kint), allocatable :: inod_dest_4_dest(:) +!> Reverse ID to set interpolated data (import) + integer(kind = kint), allocatable :: irev_dest_4_dest(:) + end type interpolate_table_dest +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine set_num_org_domain(num_org_pe, tbl_dest) +! + integer(kind = kint), intent(in) :: num_org_pe + type(interpolate_table_dest), intent(inout) :: tbl_dest +! +! + tbl_dest%num_org_domain = num_org_pe +! + end subroutine set_num_org_domain +! +!----------------------------------------------------------------------- +! + subroutine alloc_itp_num_dest(tbl_dest) +! + type(interpolate_table_dest), intent(inout) :: tbl_dest +! +! + allocate(tbl_dest%id_org_domain(tbl_dest%num_org_domain)) + allocate(tbl_dest%istack_nod_tbl_dest(0:tbl_dest%num_org_domain)) +! + if (tbl_dest%num_org_domain .gt. 0) tbl_dest%id_org_domain = 0 + tbl_dest%istack_nod_tbl_dest = -1 +! + end subroutine alloc_itp_num_dest +! +!----------------------------------------------------------------------- +! + subroutine alloc_itp_table_dest(tbl_dest) +! + type(interpolate_table_dest), intent(inout) :: tbl_dest +! +! + allocate(tbl_dest%inod_dest_4_dest(tbl_dest%ntot_table_dest)) + allocate(tbl_dest%irev_dest_4_dest(tbl_dest%ntot_table_dest)) + if (tbl_dest%ntot_table_dest .gt. 0) then + tbl_dest%inod_dest_4_dest = 0 + tbl_dest%irev_dest_4_dest = 0 + end if +! + end subroutine alloc_itp_table_dest +! +!----------------------------------------------------------------------- +! + subroutine alloc_type_zero_itp_tbl_dest(tbl_dest) +! + type(interpolate_table_dest), intent(inout) :: tbl_dest +! +! + tbl_dest%ntot_table_dest = 0 + call set_num_org_domain(izero, tbl_dest) + call alloc_itp_num_dest(tbl_dest) + call alloc_itp_table_dest(tbl_dest) +! + end subroutine alloc_type_zero_itp_tbl_dest +! +!------------------------------------------------------------------ +!----------------------------------------------------------------------- +! + subroutine dealloc_itp_num_dest(tbl_dest) +! + type(interpolate_table_dest), intent(inout) :: tbl_dest +! +! + if(allocated(tbl_dest%id_org_domain) .eqv. .FALSE.) return + deallocate( tbl_dest%id_org_domain ) + deallocate( tbl_dest%istack_nod_tbl_dest) +! + end subroutine dealloc_itp_num_dest +! +!----------------------------------------------------------------------- +! + subroutine dealloc_itp_table_dest(tbl_dest) +! + type(interpolate_table_dest), intent(inout) :: tbl_dest +! +! + if(allocated(tbl_dest%inod_dest_4_dest) .eqv. .FALSE.) return + deallocate(tbl_dest%inod_dest_4_dest, tbl_dest%irev_dest_4_dest) +! + end subroutine dealloc_itp_table_dest +! +!----------------------------------------------------------------------- +! + end module t_interpolate_tbl_dest diff --git a/src/Fortran_libraries/PARALLEL_src/Makefile b/src/Fortran_libraries/PARALLEL_src/Makefile index f5af73d9..509f5be9 100644 --- a/src/Fortran_libraries/PARALLEL_src/Makefile +++ b/src/Fortran_libraries/PARALLEL_src/Makefile @@ -11,6 +11,7 @@ SUBDIRS = \ COMM_src \ MPI_IO \ MPI_ZLIB_IO \ +INTERPOLATE \ SPH_SHELL_src \ CONST_SPH_GRID @@ -56,9 +57,10 @@ lib_archve: mod_list: @echo MOD_PARALLEL= \\ >> $(MAKENAME) @echo \ - '$$(MOD_COMM)' \ - '$$(MOD_MPI_IO) $$(MOD_MPI_ZLIB_IO)' \ - '$$(MOD_COMM_SPH) $$(MOD_SPH_GRID)' >> $(MAKENAME) + '$$(MOD_COMM)' \ + '$$(MOD_MPI_IO) $$(MOD_MPI_ZLIB_IO)' \ + '$$(MOD_COMM_SPH) $$(MOD_SPH_GRID)' \ + '$$(MOD_INTERPOLATE)' >> $(MAKENAME) @for dir in $(SUBDIRS); do \ ( cd $${dir}; \ $(GMAKE) \ diff --git a/src/Fortran_libraries/SERIAL_src/BASE/Makefile.depends b/src/Fortran_libraries/SERIAL_src/BASE/Makefile.depends index 077e17f3..0bb84da8 100644 --- a/src/Fortran_libraries/SERIAL_src/BASE/Makefile.depends +++ b/src/Fortran_libraries/SERIAL_src/BASE/Makefile.depends @@ -1,3 +1,5 @@ +aitoff.o: $(BASEDIR)/aitoff.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< append_phys_data.o: $(BASEDIR)/append_phys_data.f90 m_precision.o m_machine_parameter.o t_phys_data.o compare_indices.o $(F90) -c $(F90OPTFLAGS) $< cal_add_smp.o: $(BASEDIR)/cal_add_smp.f90 m_precision.o @@ -80,6 +82,8 @@ primefac.o: $(BASEDIR)/primefac.f90 m_precision.o $(F90) -c $(F90OPTFLAGS) $< quicksort.o: $(BASEDIR)/quicksort.f90 m_precision.o m_constants.o isort_with_int.o i8sort_with_int.o dsort_with_int.o $(F90) -c $(F90OPTFLAGS) $< +small_mat_mat_product.o: $(BASEDIR)/small_mat_mat_product.f90 m_precision.o + $(F90) -c $(F90OPTFLAGS) $< solver_33_array.o: $(BASEDIR)/solver_33_array.f90 m_precision.o $(F90) -c $(F90OPTFLAGS) $< t_group_data.o: $(BASEDIR)/t_group_data.f90 m_precision.o @@ -90,4 +94,6 @@ t_time_data.o: $(BASEDIR)/t_time_data.f90 m_precision.o m_constants.o m_machine_ $(F90) -c $(F90OPTFLAGS) $< transfer_to_long_integers.o: $(BASEDIR)/transfer_to_long_integers.f90 m_precision.o $(F90) -c $(F90OPTFLAGS) $< +transform_mat_operations.o: $(BASEDIR)/transform_mat_operations.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< diff --git a/src/Fortran_libraries/SERIAL_src/BASE/aitoff.f90 b/src/Fortran_libraries/SERIAL_src/BASE/aitoff.f90 new file mode 100644 index 00000000..5f77f821 --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/BASE/aitoff.f90 @@ -0,0 +1,102 @@ +!>@file aitoff.f90 +!!@brief module aitoff +!! +!!@date Programmed by H.Matsui in March, 2009 +! +!>@brief Program for Aitoff projection +!! +!!@verbatim +!! subroutine s_aitoff(sin_t, cos_t, phi, xg, yg) +!! real(kind = kreal), intent(in) :: sin_t, cos_t, phi +!! real(kind = kreal), intent(inout) :: xg, yg +!! subroutine reverse_aitoff(xg, yg, theta, phi) +!! real(kind = kreal), intent(in) :: xg, yg +!! real(kind = kreal), intent(inout) :: theta, phi +!!************************************************* +!! map projection using the Hammer-Aitoff equal-area projection +!!* +!!* make grid data for surface mapping +!!* +!!************************************************* +!!* +!!* sin_t, cos_t : theta of spherical coordinate (rad) +!!* phi : phi of spherical coordinate (rad) +!!* +!!************************************************* +! + module aitoff +! + use m_precision + use m_constants +! + implicit none +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine s_aitoff(sin_t, cos_t, phi, xg, yg) +!* + real(kind = kreal), intent(in) :: sin_t, cos_t, phi + real(kind = kreal), intent(inout) :: xg, yg +! + real(kind = kreal) :: xl2, den +!* +! + xl2 = half * phi + den = sqrt( one + sin_t*sin(xl2) ) + xg = -real( two * sin_t * cos(xl2) / den) + yg = real( cos_t / den) +!* + end subroutine s_aitoff +! +! ---------------------------------------------------------------------- +! + subroutine reverse_aitoff(xg, yg, theta, phi) +!* + real(kind = kreal), intent(in) :: xg, yg + real(kind = kreal), intent(inout) :: theta, phi +! + real(kind = kreal) :: A, cosp, cost, sint, pi +!* +! + pi = two*two*atan(one) + theta = -one + phi = zero +! + A = one - half*half * xg*xg - yg*yg + if(A .le. zero) return +! + cost = yg * sqrt(A + one) + sint = sqrt(one - yg*yg * (A + one)) +! + if(sint .eq. zero) then + if(yg .gt. zero) then + theta = zero + phi = zero + else + theta = pi + phi = zero + end if + end if + if(cost .lt. -one .or. cost .gt. one) return + if(sint .lt. -one .or. sint .gt. one) return +! + cosp = A / sint + if(cosp .lt. -one) cosp = -one + if(cosp .gt. one) cosp = one +! + theta = acos(cost) + if(xg .le. zero) then + phi = two * acos(-cosp) - pi + else + phi = pi - two * acos(-cosp) + end if +! + end subroutine reverse_aitoff +! +! ---------------------------------------------------------------------- +! + end module aitoff diff --git a/src/Fortran_libraries/SERIAL_src/BASE/small_mat_mat_product.f90 b/src/Fortran_libraries/SERIAL_src/BASE/small_mat_mat_product.f90 new file mode 100644 index 00000000..ed70f363 --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/BASE/small_mat_mat_product.f90 @@ -0,0 +1,186 @@ +!>@file small_mat_mat_product.f90 +!! module small_mat_mat_product +!! +!!@author H. Matsui +!!@date Programmed in May, 2013 +!! +!>@brief Take matrix-matrix product for small matrices +!! +!!@verbatim +!! subroutine mat_2x2_product(a_left, a_right, a_prod) +!! subroutine mat_3x3_product(a_left, a_right, a_prod) +!! subroutine mat_4x4_product(a_left, a_right, a_prod) +!! subroutine mat_5x5_product(a_left, a_right, a_prod) +!! +!! subroutine prod_mat33_vec3(A, V, prod) +!! subroutine prod_mat44_vec3(A, V, prod) +!!@endverbatim +!! +!!@n @param a_left(n,n) input matrix on left (2x2 to 5x5) +!!@n @param a_right(n,n) input matrix on right (2x2 to 5x5) +!!@n @param a_prod(n,n) produced matrix (2x2 to 5x5) +! + module small_mat_mat_product +! + use m_precision +! + implicit none +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine mat_2x2_product(a_left, a_right, a_prod) +! + real(kind= kreal), intent(in) :: a_left(2,2) + real(kind= kreal), intent(in) :: a_right(2,2) + real(kind= kreal), intent(inout) :: a_prod(2,2) +! + integer(kind = kint) :: nd +! +! + do nd = 1, 2 + a_prod(1,nd) = a_left(1,1) * a_right(1,nd) & + + a_left(1,2) * a_right(2,nd) + a_prod(2,nd) = a_left(2,1) * a_right(1,nd) & + + a_left(2,2) * a_right(2,nd) + end do +! + end subroutine mat_2x2_product +! +! ----------------------------------------------------------------------- +! + subroutine mat_3x3_product(a_left, a_right, a_prod) +! + real(kind= kreal), intent(in) :: a_left(3,3) + real(kind= kreal), intent(in) :: a_right(3,3) + real(kind= kreal), intent(inout) :: a_prod(3,3) +! + integer(kind = kint) :: nd +! +! + do nd = 1, 3 + a_prod(1,nd) = a_left(1,1) * a_right(1,nd) & + + a_left(1,2) * a_right(2,nd) & + + a_left(1,3) * a_right(3,nd) + a_prod(2,nd) = a_left(2,1) * a_right(1,nd) & + + a_left(2,2) * a_right(2,nd) & + + a_left(2,3) * a_right(3,nd) + a_prod(3,nd) = a_left(3,1) * a_right(1,nd) & + + a_left(3,2) * a_right(2,nd) & + + a_left(3,3) * a_right(3,nd) + end do +! + end subroutine mat_3x3_product +! +! ----------------------------------------------------------------------- +! + subroutine mat_4x4_product(a_left, a_right, a_prod) +! + real(kind= kreal), intent(in) :: a_left(4,4) + real(kind= kreal), intent(in) :: a_right(4,4) + real(kind= kreal), intent(inout) :: a_prod(4,4) +! + integer(kind = kint) :: nd +! +! + do nd = 1, 4 + a_prod(1,nd) = a_left(1,1) * a_right(1,nd) & + + a_left(1,2) * a_right(2,nd) & + + a_left(1,3) * a_right(3,nd) & + + a_left(1,4) * a_right(4,nd) + a_prod(2,nd) = a_left(2,1) * a_right(1,nd) & + + a_left(2,2) * a_right(2,nd) & + + a_left(2,3) * a_right(3,nd) & + + a_left(2,4) * a_right(4,nd) + a_prod(3,nd) = a_left(3,1) * a_right(1,nd) & + + a_left(3,2) * a_right(2,nd) & + + a_left(3,3) * a_right(3,nd) & + + a_left(3,4) * a_right(4,nd) + a_prod(4,nd) = a_left(4,1) * a_right(1,nd) & + + a_left(4,2) * a_right(2,nd) & + + a_left(4,3) * a_right(3,nd) & + + a_left(4,4) * a_right(4,nd) + end do +! + end subroutine mat_4x4_product +! +! ----------------------------------------------------------------------- +! + subroutine mat_5x5_product(a_left, a_right, a_prod) +! + real(kind= kreal), intent(in) :: a_left(5,5) + real(kind= kreal), intent(in) :: a_right(5,5) + real(kind= kreal), intent(inout) :: a_prod(5,5) +! + integer(kind = kint) :: nd +! +! + do nd = 1, 5 + a_prod(1,nd) = a_left(1,1) * a_right(1,nd) & + + a_left(1,2) * a_right(2,nd) & + + a_left(1,3) * a_right(3,nd) & + + a_left(1,4) * a_right(4,nd) & + + a_left(1,5) * a_right(5,nd) + a_prod(2,nd) = a_left(2,1) * a_right(1,nd) & + + a_left(2,2) * a_right(2,nd) & + + a_left(2,3) * a_right(3,nd) & + + a_left(2,4) * a_right(4,nd) & + + a_left(2,5) * a_right(5,nd) + a_prod(3,nd) = a_left(3,1) * a_right(1,nd) & + + a_left(3,2) * a_right(2,nd) & + + a_left(3,3) * a_right(3,nd) & + + a_left(3,4) * a_right(4,nd) & + + a_left(3,5) * a_right(5,nd) + a_prod(4,nd) = a_left(4,1) * a_right(1,nd) & + + a_left(4,2) * a_right(2,nd) & + + a_left(4,3) * a_right(3,nd) & + + a_left(4,4) * a_right(4,nd) & + + a_left(4,5) * a_right(5,nd) + a_prod(5,nd) = a_left(5,1) * a_right(1,nd) & + + a_left(5,2) * a_right(2,nd) & + + a_left(5,3) * a_right(3,nd) & + + a_left(5,4) * a_right(4,nd) & + + a_left(5,5) * a_right(5,nd) + end do +! + end subroutine mat_5x5_product +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine prod_mat33_vec3(A, V, prod) +! + real (kind=kreal), intent(in) :: A(3,3) + real (kind=kreal), intent(in) :: V(3) +! + real (kind=kreal), intent(inout) :: prod(3) +! +! + prod(1) = A(1,1)*V(1) + A(1,2)*V(2) + A(1,3)*V(3) + prod(2) = A(2,1)*V(1) + A(2,2)*V(2) + A(2,3)*V(3) + prod(3) = A(3,1)*V(1) + A(3,2)*V(2) + A(3,3)*V(3) +! + end subroutine prod_mat33_vec3 +! +! ---------------------------------------------------------------------- +! + subroutine prod_mat44_vec3(A, V, prod) +! + real (kind=kreal), intent(in) :: A(4,4) + real (kind=kreal), intent(in) :: V(3) +! + real (kind=kreal), intent(inout) :: prod(3) +! +! + prod(1) = A(1,1)*V(1) + A(1,2)*V(2) + A(1,3)*V(3) + A(1,4) + prod(2) = A(2,1)*V(1) + A(2,2)*V(2) + A(2,3)*V(3) + A(2,4) + prod(3) = A(3,1)*V(1) + A(3,2)*V(2) + A(3,3)*V(3) + A(3,4) +! + end subroutine prod_mat44_vec3 +! +! ---------------------------------------------------------------------- +! + end module small_mat_mat_product diff --git a/src/Fortran_libraries/SERIAL_src/BASE/transform_mat_operations.f90 b/src/Fortran_libraries/SERIAL_src/BASE/transform_mat_operations.f90 new file mode 100644 index 00000000..5f6c08e2 --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/BASE/transform_mat_operations.f90 @@ -0,0 +1,499 @@ +!>@file transform_mat_operations.f90 +!! module transform_mat_operations +!! +!!@author H. Matsui +!!@date programmed by H.Matsui on ???? +!! +!>@brief Matrix operations for Affine transforms +!! +!!@verbatim +!! subroutine Kemo_viewmatrix(mat, scale, shift, rotation, lookat) +!! subroutine Kemo_rotaion_viewmatrix(mat, scale, shift, rotation, & +!! & lookat, rot_movie, iaxis_rot) +!! +!! subroutine Kemo_Unit(mat) +!! subroutine Kemo_Scale(mat, scale) +!! subroutine Kemo_Translate(mat, trans) +!! subroutine Kemo_Rotate(mat, angle_deg, axis) +!! +!! subroutine Kemo_Translate_mat(trans_mat, trans) +!! subroutine Kemo_Scale_mat(scale_mat, scale) +!! subroutine Kemo_Rotate_mat(rot_mat, angle_deg, axis) +!! +!! subroutine cal_matmat44(S, A, B) +!! +!! subroutine cal_matmat44_multi_smp(N, S, A, B) +!! N(i,j,N) = A(i,j,N)B(i,j,N) +!! subroutine cal_matcmat44_multi_smp(N, S, A, B) +!! N(i,j,N) = A(i,j,N)B(i,j) +!! subroutine cal_cmatmat44_multi_smp(N, S, A, B) +!! N(i,j,N) = A(i,j)B(i,j,N) +!! (!$omp parallel need befor using) +!!@endverbatim +! + module transform_mat_operations +! + use m_precision + use m_constants +! + implicit none +! + private :: Kemo_Unit_mat +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine Kemo_viewmatrix(mat, scale, shift, rotation, lookat) +! + real(kind = kreal), intent(in) :: scale(3), shift(3) + real(kind = kreal), intent(in) :: lookat(3), rotation(4) +! + real(kind = kreal), intent(inout) :: mat(4,4) +! + real(kind = kreal) :: opp_lookat(3) +! + opp_lookat(1:3) = -lookat(1:3) +! + call Kemo_Unit(mat) + call Kemo_Translate(mat, shift(1)) + call Kemo_Rotate(mat, rotation(1), rotation(2)) + call Kemo_Scale(mat, scale(1)) + call Kemo_Translate(mat, opp_lookat(1)) +! + end subroutine Kemo_viewmatrix +! +! --------------------------------------------------------------------- +! + subroutine Kemo_rotaion_viewmatrix(mat, scale, shift, rotation, & + & lookat, rot_movie, iaxis_rot) +! + real(kind = kreal), intent(in) :: scale(3), shift(3) + real(kind = kreal), intent(in) :: lookat(3), rotation(4) + real(kind = kreal), intent(in) :: rot_movie + integer(kind = kint), intent(in) :: iaxis_rot +! + real(kind = kreal), intent(inout) :: mat(4,4) +! + real(kind = kreal) :: opp_lookat(3), rotation_axis(3) +! + opp_lookat(1:3) = -lookat(1:3) + rotation_axis(1:3) = zero + rotation_axis(iaxis_rot) = one +! + call Kemo_Unit(mat) + call Kemo_Translate(mat, shift(1)) + call Kemo_Rotate(mat, rotation(1), rotation(2)) + call Kemo_Rotate(mat, rot_movie, rotation_axis(1)) + call Kemo_Scale(mat, scale(1)) + call Kemo_Translate(mat, opp_lookat(1)) +! + end subroutine Kemo_rotaion_viewmatrix +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine Kemo_Unit(mat) +! + real(kind = kreal), intent(inout) :: mat(4,4) +! +! + call Kemo_Unit_mat(mat) +! + end subroutine Kemo_Unit +! +! --------------------------------------------------------------------- +! + subroutine Kemo_Scale(mat, scale) +! + real(kind = kreal), intent(in) :: scale(3) + real(kind = kreal), intent(inout) :: mat(4,4) +! + real(kind = kreal) :: scale_mat(4,4), mat_tmp(4,4) +! +! + mat_tmp(1:4,1:4) = mat(1:4,1:4) +! + call Kemo_Scale_mat(scale_mat, scale) + call cal_matmat44(mat(1,1), scale_mat(1,1), mat_tmp(1,1)) +! + end subroutine Kemo_Scale +! +! --------------------------------------------------------------------- +! + subroutine Kemo_Translate(mat, trans) +! + real(kind = kreal), intent(in) :: trans(3) + real(kind = kreal), intent(inout) :: mat(4,4) +! + real(kind = kreal) :: trans_mat(4,4), mat_tmp(4,4) +! +! + mat_tmp(1:4,1:4) = mat(1:4,1:4) +! + call Kemo_Translate_mat(trans_mat, trans) + call cal_matmat44(mat(1,1), trans_mat(1,1), mat_tmp(1,1)) +! + end subroutine Kemo_Translate +! +! --------------------------------------------------------------------- +! + subroutine Kemo_Rotate(mat, angle_deg, axis) +! + real(kind = kreal), intent(in) :: angle_deg + real(kind = kreal), intent(in) :: axis(3) + real(kind = kreal), intent(inout) :: mat(4,4) +! + real(kind = kreal) :: rot_mat(4,4), mat_tmp(4,4) +! +! + mat_tmp(1:4,1:4) = mat(1:4,1:4) +! + call Kemo_Rotate_mat(rot_mat, angle_deg, axis) + call cal_matmat44(mat(1,1), rot_mat(1,1), mat_tmp(1,1)) +! + end subroutine Kemo_Rotate +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine Kemo_Rotate_mat(rot_mat, angle_deg, axis) +! + real(kind = kreal), intent(in) :: angle_deg + real(kind = kreal), intent(in) :: axis(3) + real(kind = kreal), intent(inout) :: rot_mat(4,4) +! + real(kind = kreal) :: c_agl, s_agl, angle, pi + real(kind = kreal) :: axs1(3), saxis +! +! + pi = four * atan(one) + angle = angle_deg * pi / 180.0 + c_agl = cos(angle) + s_agl = sin(angle) + saxis = sqrt(axis(1)*axis(1) + axis(2)*axis(2) + axis(3)*axis(3)) + if(saxis .eq. 0.0d0) then + axs1(1:2) = 0.0d0 + axs1(3) = 1.0d0 + else + axs1(1:3) = axis(1:3) / saxis + end if +! + rot_mat(1,1) = axs1(1)*axs1(1) * (one - c_agl) + c_agl + rot_mat(1,2) = axs1(1)*axs1(2) * (one - c_agl) - axs1(3) * s_agl + rot_mat(1,3) = axs1(1)*axs1(3) * (one - c_agl) + axs1(2) * s_agl + rot_mat(1,4) = zero +! + rot_mat(2,1) = axs1(2)*axs1(1) * (one - c_agl) + axs1(3) * s_agl + rot_mat(2,2) = axs1(2)*axs1(2) * (one - c_agl) + c_agl + rot_mat(2,3) = axs1(2)*axs1(3) * (one - c_agl) - axs1(1) * s_agl + rot_mat(2,4) = zero +! + rot_mat(3,1) = axs1(3)*axs1(1) * (one - c_agl) - axs1(2) * s_agl + rot_mat(3,2) = axs1(3)*axs1(2) * (one - c_agl) + axs1(1) * s_agl + rot_mat(3,3) = axs1(3)*axs1(3) * (one - c_agl) + c_agl + rot_mat(3,4) = zero +! + rot_mat(4,1) = zero + rot_mat(4,2) = zero + rot_mat(4,3) = zero + rot_mat(4,4) = one +! + end subroutine Kemo_Rotate_mat +! +! --------------------------------------------------------------------- +! + subroutine Kemo_Translate_mat(trans_mat, trans) +! + real(kind = kreal), intent(in) :: trans(3) + real(kind = kreal), intent(inout) :: trans_mat(4,4) +! +! + trans_mat(1,1) = one + trans_mat(1,2) = zero + trans_mat(1,3) = zero + trans_mat(1,4) = trans(1) +! + trans_mat(2,1) = zero + trans_mat(2,2) = one + trans_mat(2,3) = zero + trans_mat(2,4) = trans(2) +! + trans_mat(3,1) = zero + trans_mat(3,2) = zero + trans_mat(3,3) = one + trans_mat(3,4) = trans(3) +! + trans_mat(4,1) = zero + trans_mat(4,2) = zero + trans_mat(4,3) = zero + trans_mat(4,4) = one +! + end subroutine Kemo_Translate_mat +! +! --------------------------------------------------------------------- +! + subroutine Kemo_Scale_mat(scale_mat, scale) +! + real(kind = kreal), intent(in) :: scale(3) + real(kind = kreal), intent(inout) :: scale_mat(4,4) +! +! + scale_mat(1,1) = scale(1) + scale_mat(1,2) = zero + scale_mat(1,3) = zero + scale_mat(1,4) = zero +! + scale_mat(2,1) = zero + scale_mat(2,2) = scale(2) + scale_mat(2,3) = zero + scale_mat(2,4) = zero +! + scale_mat(3,1) = zero + scale_mat(3,2) = zero + scale_mat(3,3) = scale(3) + scale_mat(3,4) = zero +! + scale_mat(4,1) = zero + scale_mat(4,2) = zero + scale_mat(4,3) = zero + scale_mat(4,4) = one +! + end subroutine Kemo_Scale_mat +! +! --------------------------------------------------------------------- +! + subroutine Kemo_Unit_mat(unit_mat) +! + real(kind = kreal), intent(inout) :: unit_mat(4,4) +! +! + unit_mat(1,1) = one + unit_mat(1,2) = zero + unit_mat(1,3) = zero + unit_mat(1,4) = zero +! + unit_mat(2,1) = zero + unit_mat(2,2) = one + unit_mat(2,3) = zero + unit_mat(2,4) = zero +! + unit_mat(3,1) = zero + unit_mat(3,2) = zero + unit_mat(3,3) = one + unit_mat(3,4) = zero +! + unit_mat(4,1) = zero + unit_mat(4,2) = zero + unit_mat(4,3) = zero + unit_mat(4,4) = one +! + end subroutine Kemo_Unit_mat +! +! --------------------------------------------------------------------- +! + subroutine cal_matmat44(S, A, B) +! + real(kind = kreal), intent(in) :: B(4,4), A(4,4) + real(kind = kreal), intent(inout) :: S(4,4) +! +! + S(1,1) = A(1,1) * B(1,1) + A(1,2) * B(2,1) & + & + A(1,3) * B(3,1) + A(1,4) * B(4,1) + S(2,1) = A(2,1) * B(1,1) + A(2,2) * B(2,1) & + & + A(2,3) * B(3,1) + A(2,4) * B(4,1) + S(3,1) = A(3,1) * B(1,1) + A(3,2) * B(2,1) & + & + A(3,3) * B(3,1) + A(3,4) * B(4,1) + S(4,1) = A(4,1) * B(1,1) + A(4,2) * B(2,1) & + & + A(4,3) * B(3,1) + A(4,4) * B(4,1) + + S(1,2) = A(1,1) * B(1,2) + A(1,2) * B(2,2) & + & + A(1,3) * B(3,2) + A(1,4) * B(4,2) + S(2,2) = A(2,1) * B(1,2) + A(2,2) * B(2,2) & + & + A(2,3) * B(3,2) + A(2,4) * B(4,2) + S(3,2) = A(3,1) * B(1,2) + A(3,2) * B(2,2) & + & + A(3,3) * B(3,2) + A(3,4) * B(4,2) + S(4,2) = A(4,1) * B(1,2) + A(4,2) * B(2,2) & + & + A(4,3) * B(3,2) + A(4,4) * B(4,2) + + S(1,3) = A(1,1) * B(1,3) + A(1,2) * B(2,3) & + & + A(1,3) * B(3,3) + A(1,4) * B(4,3) + S(2,3) = A(2,1) * B(1,3) + A(2,2) * B(2,3) & + & + A(2,3) * B(3,3) + A(2,4) * B(4,3) + S(3,3) = A(3,1) * B(1,3) + A(3,2) * B(2,3) & + & + A(3,3) * B(3,3) + A(3,4) * B(4,3) + S(4,3) = A(4,1) * B(1,3) + A(4,2) * B(2,3) & + & + A(4,3) * B(3,3) + A(4,4) * B(4,3) + + S(1,4) = A(1,1) * B(1,4) + A(1,2) * B(2,4) & + & + A(1,3) * B(3,4) + A(1,4) * B(4,4) + S(2,4) = A(2,1) * B(1,4) + A(2,2) * B(2,4) & + & + A(2,3) * B(3,4) + A(2,4) * B(4,4) + S(3,4) = A(3,1) * B(1,4) + A(3,2) * B(2,4) & + & + A(3,3) * B(3,4) + A(3,4) * B(4,4) + S(4,4) = A(4,1) * B(1,4) + A(4,2) * B(2,4) & + & + A(4,3) * B(3,4) + A(4,4) * B(4,4) +! + end subroutine cal_matmat44 +! +! --------------------------------------------------------------------- +! + subroutine cal_matmat44_multi_smp(N, S, A, B) +! + integer(kind = kint), intent(in) :: N + real(kind = kreal), intent(in) :: B(4,4,N), A(4,4,N) + real(kind = kreal), intent(inout) :: S(4,4,N) + integer(kind = kint) :: i +! +! +!$omp do + do i = 1, N + S(1,1,i) = A(1,1,i) * B(1,1,i) + A(1,2,i) * B(2,1,i) & + & + A(1,3,i) * B(3,1,i) + A(1,4,i) * B(4,1,i) + S(2,1,i) = A(2,1,i) * B(1,1,i) + A(2,2,i) * B(2,1,i) & + & + A(2,3,i) * B(3,1,i) + A(2,4,i) * B(4,1,i) + S(3,1,i) = A(3,1,i) * B(1,1,i) + A(3,2,i) * B(2,1,i) & + & + A(3,3,i) * B(3,1,i) + A(3,4,i) * B(4,1,i) + S(4,1,i) = A(4,1,i) * B(1,1,i) + A(4,2,i) * B(2,1,i) & + & + A(4,3,i) * B(3,1,i) + A(4,4,i) * B(4,1,i) + + S(1,2,i) = A(1,1,i) * B(1,2,i) + A(1,2,i) * B(2,2,i) & + & + A(1,3,i) * B(3,2,i) + A(1,4,i) * B(4,2,i) + S(2,2,i) = A(2,1,i) * B(1,2,i) + A(2,2,i) * B(2,2,i) & + & + A(2,3,i) * B(3,2,i) + A(2,4,i) * B(4,2,i) + S(3,2,i) = A(3,1,i) * B(1,2,i) + A(3,2,i) * B(2,2,i) & + & + A(3,3,i) * B(3,2,i) + A(3,4,i) * B(4,2,i) + S(4,2,i) = A(4,1,i) * B(1,2,i) + A(4,2,i) * B(2,2,i) & + & + A(4,3,i) * B(3,2,i) + A(4,4,i) * B(4,2,i) + + S(1,3,i) = A(1,1,i) * B(1,3,i) + A(1,2,i) * B(2,3,i) & + & + A(1,3,i) * B(3,3,i) + A(1,4,i) * B(4,3,i) + S(2,3,i) = A(2,1,i) * B(1,3,i) + A(2,2,i) * B(2,3,i) & + & + A(2,3,i) * B(3,3,i) + A(2,4,i) * B(4,3,i) + S(3,3,i) = A(3,1,i) * B(1,3,i) + A(3,2,i) * B(2,3,i) & + & + A(3,3,i) * B(3,3,i) + A(3,4,i) * B(4,3,i) + S(4,3,i) = A(4,1,i) * B(1,3,i) + A(4,2,i) * B(2,3,i) & + & + A(4,3,i) * B(3,3,i) + A(4,4,i) * B(4,3,i) + + S(1,4,i) = A(1,1,i) * B(1,4,i) + A(1,2,i) * B(2,4,i) & + & + A(1,3,i) * B(3,4,i) + A(1,4,i) * B(4,4,i) + S(2,4,i) = A(2,1,i) * B(1,4,i) + A(2,2,i) * B(2,4,i) & + & + A(2,3,i) * B(3,4,i) + A(2,4,i) * B(4,4,i) + S(3,4,i) = A(3,1,i) * B(1,4,i) + A(3,2,i) * B(2,4,i) & + & + A(3,3,i) * B(3,4,i) + A(3,4,i) * B(4,4,i) + S(4,4,i) = A(4,1,i) * B(1,4,i) + A(4,2,i) * B(2,4,i) & + & + A(4,3,i) * B(3,4,i) + A(4,4,i) * B(4,4,i) + end do +!$omp end do nowait +! + end subroutine cal_matmat44_multi_smp +! +! --------------------------------------------------------------------- +! + subroutine cal_matcmat44_multi_smp(N, S, A, B) +! + integer(kind = kint), intent(in) :: N + real(kind = kreal), intent(in) :: B(4,4), A(4,4,N) + real(kind = kreal), intent(inout) :: S(4,4,N) + integer(kind = kint) :: i +! +! +!$omp do + do i = 1, N + S(1,1,i) = A(1,1,i) * B(1,1) + A(1,2,i) * B(2,1) & + & + A(1,3,i) * B(3,1) + A(1,4,i) * B(4,1) + S(2,1,i) = A(2,1,i) * B(1,1) + A(2,2,i) * B(2,1) & + & + A(2,3,i) * B(3,1) + A(2,4,i) * B(4,1) + S(3,1,i) = A(3,1,i) * B(1,1) + A(3,2,i) * B(2,1) & + & + A(3,3,i) * B(3,1) + A(3,4,i) * B(4,1) + S(4,1,i) = A(4,1,i) * B(1,1) + A(4,2,i) * B(2,1) & + & + A(4,3,i) * B(3,1) + A(4,4,i) * B(4,1) + + S(1,2,i) = A(1,1,i) * B(1,2) + A(1,2,i) * B(2,2) & + & + A(1,3,i) * B(3,2) + A(1,4,i) * B(4,2) + S(2,2,i) = A(2,1,i) * B(1,2) + A(2,2,i) * B(2,2) & + & + A(2,3,i) * B(3,2) + A(2,4,i) * B(4,2) + S(3,2,i) = A(3,1,i) * B(1,2) + A(3,2,i) * B(2,2) & + & + A(3,3,i) * B(3,2) + A(3,4,i) * B(4,2) + S(4,2,i) = A(4,1,i) * B(1,2) + A(4,2,i) * B(2,2) & + & + A(4,3,i) * B(3,2) + A(4,4,i) * B(4,2) + + S(1,3,i) = A(1,1,i) * B(1,3) + A(1,2,i) * B(2,3) & + & + A(1,3,i) * B(3,3) + A(1,4,i) * B(4,3) + S(2,3,i) = A(2,1,i) * B(1,3) + A(2,2,i) * B(2,3) & + & + A(2,3,i) * B(3,3) + A(2,4,i) * B(4,3) + S(3,3,i) = A(3,1,i) * B(1,3) + A(3,2,i) * B(2,3) & + & + A(3,3,i) * B(3,3) + A(3,4,i) * B(4,3) + S(4,3,i) = A(4,1,i) * B(1,3) + A(4,2,i) * B(2,3) & + & + A(4,3,i) * B(3,3) + A(4,4,i) * B(4,3) + + S(1,4,i) = A(1,1,i) * B(1,4) + A(1,2,i) * B(2,4) & + & + A(1,3,i) * B(3,4) + A(1,4,i) * B(4,4) + S(2,4,i) = A(2,1,i) * B(1,4) + A(2,2,i) * B(2,4) & + & + A(2,3,i) * B(3,4) + A(2,4,i) * B(4,4) + S(3,4,i) = A(3,1,i) * B(1,4) + A(3,2,i) * B(2,4) & + & + A(3,3,i) * B(3,4) + A(3,4,i) * B(4,4) + S(4,4,i) = A(4,1,i) * B(1,4) + A(4,2,i) * B(2,4) & + & + A(4,3,i) * B(3,4) + A(4,4,i) * B(4,4) + end do +!$omp end do nowait +! + end subroutine cal_matcmat44_multi_smp +! +! --------------------------------------------------------------------- +! + subroutine cal_cmatmat44_multi_smp(N, S, A, B) +! + integer(kind = kint), intent(in) :: N + real(kind = kreal), intent(in) :: B(4,4,N), A(4,4) + real(kind = kreal), intent(inout) :: S(4,4,N) + integer(kind = kint) :: i +! +! +!$omp do + do i = 1, N + S(1,1,i) = A(1,1) * B(1,1,i) + A(1,2) * B(2,1,i) & + & + A(1,3) * B(3,1,i) + A(1,4) * B(4,1,i) + S(2,1,i) = A(2,1) * B(1,1,i) + A(2,2) * B(2,1,i) & + & + A(2,3) * B(3,1,i) + A(2,4) * B(4,1,i) + S(3,1,i) = A(3,1) * B(1,1,i) + A(3,2) * B(2,1,i) & + & + A(3,3) * B(3,1,i) + A(3,4) * B(4,1,i) + S(4,1,i) = A(4,1) * B(1,1,i) + A(4,2) * B(2,1,i) & + & + A(4,3) * B(3,1,i) + A(4,4) * B(4,1,i) + + S(1,2,i) = A(1,1) * B(1,2,i) + A(1,2) * B(2,2,i) & + & + A(1,3) * B(3,2,i) + A(1,4) * B(4,2,i) + S(2,2,i) = A(2,1) * B(1,2,i) + A(2,2) * B(2,2,i) & + & + A(2,3) * B(3,2,i) + A(2,4) * B(4,2,i) + S(3,2,i) = A(3,1) * B(1,2,i) + A(3,2) * B(2,2,i) & + & + A(3,3) * B(3,2,i) + A(3,4) * B(4,2,i) + S(4,2,i) = A(4,1) * B(1,2,i) + A(4,2) * B(2,2,i) & + & + A(4,3) * B(3,2,i) + A(4,4) * B(4,2,i) + + S(1,3,i) = A(1,1) * B(1,3,i) + A(1,2) * B(2,3,i) & + & + A(1,3) * B(3,3,i) + A(1,4) * B(4,3,i) + S(2,3,i) = A(2,1) * B(1,3,i) + A(2,2) * B(2,3,i) & + & + A(2,3) * B(3,3,i) + A(2,4) * B(4,3,i) + S(3,3,i) = A(3,1) * B(1,3,i) + A(3,2) * B(2,3,i) & + & + A(3,3) * B(3,3,i) + A(3,4) * B(4,3,i) + S(4,3,i) = A(4,1) * B(1,3,i) + A(4,2) * B(2,3,i) & + & + A(4,3) * B(3,3,i) + A(4,4) * B(4,3,i) + + S(1,4,i) = A(1,1) * B(1,4,i) + A(1,2) * B(2,4,i) & + & + A(1,3) * B(3,4,i) + A(1,4) * B(4,4,i) + S(2,4,i) = A(2,1) * B(1,4,i) + A(2,2) * B(2,4,i) & + & + A(2,3) * B(3,4,i) + A(2,4) * B(4,4,i) + S(3,4,i) = A(3,1) * B(1,4,i) + A(3,2) * B(2,4,i) & + & + A(3,3) * B(3,4,i) + A(3,4) * B(4,4,i) + S(4,4,i) = A(4,1) * B(1,4,i) + A(4,2) * B(2,4,i) & + & + A(4,3) * B(3,4,i) + A(4,4) * B(4,4,i) + end do +!$omp end do nowait +! + end subroutine cal_cmatmat44_multi_smp +! +! --------------------------------------------------------------------- +! + end module transform_mat_operations diff --git a/src/Fortran_libraries/SERIAL_src/Fortran2003/Makefile.depends b/src/Fortran_libraries/SERIAL_src/Fortran2003/Makefile.depends index 7314f0b2..64da7e7f 100644 --- a/src/Fortran_libraries/SERIAL_src/Fortran2003/Makefile.depends +++ b/src/Fortran_libraries/SERIAL_src/Fortran2003/Makefile.depends @@ -12,4 +12,6 @@ t_binary_IO_buffer.o: $(F2003DIR)/t_binary_IO_buffer.f90 m_precision.o $(F90) -c $(F90OPTFLAGS) $< t_buffer_4_gzip.o: $(F2003DIR)/t_buffer_4_gzip.f90 m_precision.o $(F90) -c $(F90OPTFLAGS) $< +t_png_file_access.o: $(F2003DIR)/t_png_file_access.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< diff --git a/src/Fortran_libraries/SERIAL_src/Fortran2003/t_png_file_access.f90 b/src/Fortran_libraries/SERIAL_src/Fortran2003/t_png_file_access.f90 new file mode 100644 index 00000000..5297cf3c --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/Fortran2003/t_png_file_access.f90 @@ -0,0 +1,303 @@ +!> @file t_png_file_access.f90 +!! module t_png_file_access +!! +!! @author H. Matsui +!! @date Written in June, 2009 +!! +!> @brief routines for libpng access +!! +!!@verbatim +!! subroutine write_png_rgb_f & +!! & (img_head, npix_x, npix_y, cimage, png_buf) +!! subroutine write_png_rgba_f & +!! & (img_head, npix_x, npix_y, cimage, png_buf) +!! type(buffer_4_png), intent(inout) :: png_buf +!! +!! subroutine read_png_file_f(img_head, npix_x, npix_y, png_buf) +!! subroutine copy_rgb_from_png_f(npix_x, npix_y, cimage, png_buf) +!! subroutine copy_rgba_from_png_f(npix_x, npix_y, cimage, png_buf) +!! subroutine copy_grayscale_from_png_f & +!! & (npix_x, npix_y, cimage, png_buf) +!! subroutine copy_grayalpha_from_png_f & +!! & (npix_x, npix_y, cimage, png_buf) +!! type(buffer_4_png), intent(inout) :: png_buf +!!@endverbatim +! + module t_png_file_access +! + use ISO_C_BINDING + use m_precision + use m_constants +! + implicit none +! +!> Integer flag for rgb image + integer(C_int), parameter :: iflag_rgb = 0 +!> Integer flag for rgba image + integer(C_int), parameter :: iflag_rgba = 1 +!> Integer flag for grayscale with alpha image + integer(C_int), parameter :: iflag_ba = 11 +!> Integer flag for grayscale image + integer(C_int), parameter :: iflag_bw = 10 +! + type buffer_4_png +!> pointer for file prefix + character(kchara,C_char) :: fhead_p +! +!> integer flag to detect rgba + integer(C_int) :: iflag_cmode +!> horizontal pixel size + integer(C_int) :: npix4_x +!> vertical pixel size + integer(C_int) :: npix4_y +!> pointer for image data + character(C_char), pointer :: cimage_p(:,:) + end type buffer_4_png +! + private :: link_to_image_data_4_png, get_image_size_from_png +! +! ----------------- +! + interface +! +! ----------------- + subroutine write_png_rgba_c(file_head, num_x, num_y, cimage) & + & BIND(C, name = 'write_png_rgba_c') + use ISO_C_BINDING +! + character(C_char), intent(in) :: file_head(*) + integer(C_int), intent(in) :: num_x, num_y + type(C_ptr), value, intent(in) :: cimage + end subroutine write_png_rgba_c +! ----------------- + subroutine write_png_rgb_c(file_head, num_x, num_y, cimage) & + & BIND(C, name = 'write_png_rgb_c') + use ISO_C_BINDING +! + character(C_char), intent(in) :: file_head(*) + integer(C_int), intent(in) :: num_x, num_y + type(C_ptr), value, intent(in) :: cimage + end subroutine write_png_rgb_c +! ----------------- +! + subroutine read_png_file_c(file_head, num_x, num_y, iflag_rgba) & + & BIND(C, name = 'read_png_file_c') + use ISO_C_BINDING +! + character(C_char), intent(in) :: file_head(*) + integer(C_int), intent(inout) :: num_x, num_y + integer(C_int), intent(inout) :: iflag_rgba + end subroutine read_png_file_c +! +! ----------------- + subroutine copy_rgb_from_png_c & + & (num_x, num_y, iflag_rgba, cimage) & + & BIND(C, name = 'copy_rgb_from_png_c') + use ISO_C_BINDING +! + integer(C_int), value :: num_x, num_y + integer(C_int), value :: iflag_rgba + type(C_ptr), value, intent(in) :: cimage + end subroutine copy_rgb_from_png_c +! ----------------- + subroutine copy_rgba_from_png_c & + & (num_x, num_y, iflag_rgba, cimage) & + & BIND(C, name = 'copy_rgba_from_png_c') + use ISO_C_BINDING +! + integer(C_int), value :: num_x, num_y + integer(C_int), value :: iflag_rgba + type(C_ptr), value, intent(in) :: cimage + end subroutine copy_rgba_from_png_c +! ----------------- + subroutine copy_grayscale_from_png_c & + & (num_x, num_y, iflag_rgba, cimage) & + & BIND(C, name = 'copy_grayscale_from_png_c') + use ISO_C_BINDING +! + integer(C_int), value :: num_x, num_y + integer(C_int), value :: iflag_rgba + type(C_ptr), value, intent(in) :: cimage + end subroutine copy_grayscale_from_png_c +! ----------------- + subroutine copy_grayalpha_from_png_c & + & (num_x, num_y, iflag_rgba, cimage) & + & BIND(C, name = 'copy_grayalpha_from_png_c') + use ISO_C_BINDING +! + integer(C_int), value :: num_x, num_y + integer(C_int), value :: iflag_rgba + type(C_ptr), value, intent(in) :: cimage + end subroutine copy_grayalpha_from_png_c +! ----------------- + end interface +! +!------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------ +! + subroutine write_png_rgb_f & + & (img_head, npix_x, npix_y, cimage, png_buf) +! + integer(kind = kint), intent(in) :: npix_x, npix_y + character(len=kchara), intent(in) :: img_head + character(len = 1), intent(in) :: cimage(3,npix_x*npix_y) +! + type(buffer_4_png), intent(inout) :: png_buf +! +! + write(png_buf%fhead_p, '(a,a1)') trim(img_head), CHAR(0) + call link_to_image_data_4_png & + & (ifour, npix_x, npix_y, cimage, png_buf) + call write_png_rgb_c(png_buf%fhead_p, & + & png_buf%npix4_x, png_buf%npix4_y, & + & C_LOC(png_buf%cimage_p(1,1))) + nullify(png_buf%cimage_p) +! + end subroutine write_png_rgb_f +! +!------------------------------------------------------------------ +! + subroutine write_png_rgba_f & + & (img_head, npix_x, npix_y, cimage, png_buf) +! + integer(kind = kint), intent(in) :: npix_x, npix_y + character(len=kchara), intent(in) :: img_head + character(len = 1), intent(in) :: cimage(4,npix_x*npix_y) +! + type(buffer_4_png), intent(inout) :: png_buf +! +! + write(png_buf%fhead_p, '(a,a1)') trim(img_head), CHAR(0) + call link_to_image_data_4_png & + & (ifour, npix_x, npix_y, cimage, png_buf) + call write_png_rgba_c(png_buf%fhead_p, & + & png_buf%npix4_x, png_buf%npix4_y, & + & C_LOC(png_buf%cimage_p(1,1))) + nullify(png_buf%cimage_p) +! + end subroutine write_png_rgba_f +! +!------------------------------------------------------------------ +!------------------------------------------------------------------ +! + subroutine read_png_file_f(img_head, npix_x, npix_y, png_buf) +! + character(len=kchara), intent(in) :: img_head + integer(kind = kint), intent(inout) :: npix_x, npix_y + type(buffer_4_png), intent(inout) :: png_buf +! +! + write(png_buf%fhead_p, '(a,a1)') trim(img_head), CHAR(0) + call read_png_file_c(png_buf%fhead_p, & + & png_buf%npix4_x, png_buf%npix4_y, png_buf%iflag_cmode) + call get_image_size_from_png(png_buf, npix_x, npix_y) +! + end subroutine read_png_file_f +! +!------------------------------------------------------------------ +!------------------------------------------------------------------ +! + subroutine copy_rgb_from_png_f(npix_x, npix_y, cimage, png_buf) +! + integer(kind = kint), intent(in) :: npix_x, npix_y + character(len = 1), intent(inout) :: cimage(3,npix_x*npix_y) + type(buffer_4_png), intent(inout) :: png_buf +! +! + call link_to_image_data_4_png & + & (ithree, npix_x, npix_y, cimage, png_buf) + call copy_rgb_from_png_c(png_buf%npix4_x, png_buf%npix4_y, & + & png_buf%iflag_cmode, C_LOC(png_buf%cimage_p(1,1))) + nullify(png_buf%cimage_p) +! + end subroutine copy_rgb_from_png_f +! +!------------------------------------------------------------------ +! + subroutine copy_rgba_from_png_f(npix_x, npix_y, cimage, png_buf) +! + integer(kind = kint), intent(in) :: npix_x, npix_y + character(len = 1), intent(inout) :: cimage(4,npix_x*npix_y) + type(buffer_4_png), intent(inout) :: png_buf +! +! + call link_to_image_data_4_png & + & (ifour, npix_x, npix_y, cimage, png_buf) + call copy_rgba_from_png_c(png_buf%npix4_x, png_buf%npix4_y, & + & png_buf%iflag_cmode, C_LOC(png_buf%cimage_p(1,1))) + nullify(png_buf%cimage_p) +! + end subroutine copy_rgba_from_png_f +! +!------------------------------------------------------------------ +! + subroutine copy_grayscale_from_png_f & + & (npix_x, npix_y, cimage, png_buf) +! + integer(kind = kint), intent(in) :: npix_x, npix_y + character(len = 1), intent(inout) :: cimage(1,npix_x*npix_y) + type(buffer_4_png), intent(inout) :: png_buf +! +! + call link_to_image_data_4_png & + & (ione, npix_x, npix_y, cimage, png_buf) + call copy_grayscale_from_png_c(png_buf%npix4_x, png_buf%npix4_y, & + & png_buf%iflag_cmode, C_LOC(png_buf%cimage_p(1,1))) + nullify(png_buf%cimage_p) +! + end subroutine copy_grayscale_from_png_f +! +!------------------------------------------------------------------ +! + subroutine copy_grayalpha_from_png_f & + & (npix_x, npix_y, cimage, png_buf) +! + integer(kind = kint), intent(in) :: npix_x, npix_y + character(len = 1), intent(inout) :: cimage(2,npix_x*npix_y) + type(buffer_4_png), intent(inout) :: png_buf +! +! + call link_to_image_data_4_png & + & (itwo, npix_x, npix_y, cimage, png_buf) + call copy_grayalpha_from_png_c(png_buf%npix4_x, png_buf%npix4_y, & + & png_buf%iflag_cmode, C_LOC(png_buf%cimage_p(1,1))) + nullify(png_buf%cimage_p) +! + end subroutine copy_grayalpha_from_png_f +! +!------------------------------------------------------------------ +!------------------------------------------------------------------ +! + subroutine link_to_image_data_4_png & + & (ncolor, npix_x, npix_y, cimage, png_buf) +! + integer(kind = kint), intent(in) :: ncolor, npix_x, npix_y + character(len = 1), target, intent(in) & + & :: cimage(ncolor,npix_x*npix_y) +! + type(buffer_4_png), intent(inout) :: png_buf +! + png_buf%npix4_x = int(npix_x,KIND(png_buf%npix4_x)) + png_buf%npix4_y = int(npix_y,KIND(png_buf%npix4_y)) + png_buf%cimage_p => cimage +! + end subroutine link_to_image_data_4_png +! +!------------------------------------------------------------------ +! + subroutine get_image_size_from_png(png_buf, npix_x, npix_y) +! + type(buffer_4_png), intent(in) :: png_buf + integer(kind = kint), intent(inout) :: npix_x, npix_y +! + npix_x = int(png_buf%npix4_x,KIND(npix_x)) + npix_y = int(png_buf%npix4_y,KIND(npix_y)) +! + end subroutine get_image_size_from_png +! +!------------------------------------------------------------------ +! + end module t_png_file_access diff --git a/src/Fortran_libraries/SERIAL_src/IO/Makefile.depends b/src/Fortran_libraries/SERIAL_src/IO/Makefile.depends index 0806f2dc..5d851996 100644 --- a/src/Fortran_libraries/SERIAL_src/IO/Makefile.depends +++ b/src/Fortran_libraries/SERIAL_src/IO/Makefile.depends @@ -112,6 +112,8 @@ node_geometry_IO.o: $(IO_DIR)/node_geometry_IO.f90 m_precision.o t_geometry_data $(F90) -c $(F90OPTFLAGS) $< node_geometry_IO_b.o: $(IO_DIR)/node_geometry_IO_b.f90 m_precision.o m_constants.o m_phys_constants.o t_geometry_data.o t_read_mesh_data.o t_surf_edge_IO.o t_binary_IO_buffer.o binary_IO.o transfer_to_long_integers.o $(F90) -c $(F90OPTFLAGS) $< +number_to_bit.o: $(IO_DIR)/number_to_bit.f90 m_precision.o + $(F90) -c $(F90OPTFLAGS) $< output_sph_pwr_layer_file.o: $(IO_DIR)/output_sph_pwr_layer_file.f90 m_precision.o m_constants.o t_time_data.o t_spheric_parameter.o t_rms_4_sph_spectr.o t_sph_volume_mean_square.o t_energy_label_parameters.o sph_mean_spectr_header_IO.o set_parallel_file_name.o t_read_sph_spectra.o t_buffer_4_gzip.o gz_open_sph_layer_mntr_file.o gz_layer_mean_monitor_IO.o sph_power_spectr_data_text.o gz_layer_spectr_monitor_IO.o $(F90) -c $(F90OPTFLAGS) $< output_sph_pwr_volume_file.o: $(IO_DIR)/output_sph_pwr_volume_file.f90 m_precision.o m_constants.o t_time_data.o t_spheric_parameter.o t_rms_4_sph_spectr.o t_sph_volume_mean_square.o t_energy_label_parameters.o sph_mean_spectr_header_IO.o m_base_field_labels.o set_parallel_file_name.o skip_comment_f.o t_read_sph_spectra.o t_buffer_4_gzip.o gz_open_sph_vol_mntr_file.o gz_volume_spectr_monitor_IO.o sph_monitor_data_text.o select_gz_stream_file_IO.o @@ -322,6 +324,8 @@ vtk_data_to_buffer.o: $(IO_DIR)/vtk_data_to_buffer.f90 m_precision.o m_constants $(F90) -c $(F90OPTFLAGS) $< vtk_file_IO.o: $(IO_DIR)/vtk_file_IO.f90 m_precision.o m_constants.o m_machine_parameter.o udt_to_VTK_data_IO.o t_ucd_data.o set_parallel_file_name.o set_ucd_file_names.o set_ucd_extensions.o $(F90) -c $(F90OPTFLAGS) $< +write_bmp_image.o: $(IO_DIR)/write_bmp_image.f90 m_precision.o number_to_bit.o + $(F90) -c $(F90OPTFLAGS) $< write_control_elements.o: $(IO_DIR)/write_control_elements.f90 m_precision.o m_machine_parameter.o write_control_items.o $(F90) -c $(F90OPTFLAGS) $< write_control_items.o: $(IO_DIR)/write_control_items.f90 m_precision.o diff --git a/src/Fortran_libraries/SERIAL_src/IO/number_to_bit.f90 b/src/Fortran_libraries/SERIAL_src/IO/number_to_bit.f90 new file mode 100644 index 00000000..086a2466 --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/IO/number_to_bit.f90 @@ -0,0 +1,266 @@ +!>@file number_to_bit.f90 +!!@brief module number_to_bit +! +!>@brief convert number to 8-bit characters for both endians +!!@date Programmed by H. Matsui on Sep., 2021 +!! +!!@verbatim +!! character(len=4) function num2bit4_little(inum) +!! character(len=2) function num2bit2_little(inum) +!! integer, intent(in) :: inum +!! integer(kind = kint) function bit4_to_int_little(a) +!! character(len = 1), intent(in) :: a(4) +!! integer(kind = kint) function bit2_to_int_little(a) +!! character(len = 1), intent(in) :: a(2) +!! +!! character(len=4) function num2bit4_big(inum) +!! character(len=2) function num2bit2_big(inum) +!! integer, intent(in) :: inum +!! integer(kind = kint) function bit4_to_int_big(a) +!! character(len = 1), intent(in) :: a(4) +!! integer(kind = kint) function bit2_to_int_big(a) +!! character(len = 1), intent(in) :: a(2) +!! +!! subroutine crc32_4_png(ilength, cbuf, i_crc) +!! integer(kind = 4), intent(in) :: ilength +!! character(len = 1), intent(in) :: cbuf(ilength) +!! integer(kind = 4), intent(inout) :: i_crc +!!@endverbatim +! + module number_to_bit +! + use m_precision +! + implicit none +! +!------------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------------ +! + character(len=4) function num2bit4_little(inum) +! + integer, intent(in) :: inum +! + integer :: itmp1, itmp2 +! + if(inum .lt. 0) then + itmp1 = inum + 2147483647 + 1 + itmp2 = itmp1 / 256**3 + num2bit4_little(4:4) = char(itmp2+128) + else + itmp1 = inum + itmp2 = itmp1 / 256**3 + num2bit4_little(4:4) = char(itmp2) + end if +! + itmp1 =-itmp2 * 256**3 +itmp1 + itmp2 = itmp1 / 256**2 + num2bit4_little(3:3) = char(itmp2) + itmp1 =-itmp2 * 256**2 +itmp1 + itmp2 = itmp1 / 256 + num2bit4_little(2:2) = char(itmp2) + itmp1 =-itmp2 * 256 +itmp1 + num2bit4_little(1:1) = char(itmp1) +! + end function num2bit4_little +! +!------------------------------------------------------------------------ +! + character(len=2) function num2bit2_little(inum) +! + integer, intent(in) :: inum +! + integer itmp1, itmp2 +! + if(inum .lt. 0) then + itmp1 = inum + 32767 + 1 + itmp2 = itmp1 / 256 + num2bit2_little(2:2) = char(itmp2+128) + else + itmp1 = inum + itmp2 = itmp1 / 256 + num2bit2_little(2:2) = char(itmp2) + end if +! + itmp1 =-itmp2 * 256 + itmp1 + num2bit2_little(1:1) = char(itmp1) +! + end function num2bit2_little +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + integer(kind = kint) function bit4_to_int_little(a) +! + character(len = 1), intent(in) :: a(4) + integer(kind = kint) :: i +! + i = iachar(a(1)) + 256*iachar(a(2)) + 65536 * iachar(a(3)) + if(iachar(a(4)) .ge. 128) then + i = i + 16777216 * (iachar(a(4)) - 128) - 2147483647 - 1 + else + i = i + 16777216 * iachar(a(4)) + end if + bit4_to_int_little = i +! + end function bit4_to_int_little +! +!------------------------------------------------------------------------ +! + integer(kind = kint) function bit2_to_int_little(a) +! + character(len = 1), intent(in) :: a(2) + integer(kind = kint) :: i +! + if(iachar(a(2)) .ge. 128) then + i = iachar(a(1)) + 256 * (iachar(a(2)) - 128) - 65535 - 1 + else + i = iachar(a(1)) + 256 * iachar(a(2)) + end if + bit2_to_int_little = i +! + end function bit2_to_int_little +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + character(len=4) function num2bit4_big(inum) +! + integer, intent(in) :: inum +! + integer :: itmp1, itmp2 +! +! + if(inum .lt. 0) then + itmp1 = inum + 2147483647 + 1 + itmp2 = itmp1 / 256**3 + num2bit4_big(1:1) = char(itmp2+128) + else + itmp1 = inum + itmp2 = itmp1 / 256**3 + num2bit4_big(1:1) = char(itmp2) + end if +! + itmp1 =-itmp2 * 256**3 +itmp1 + itmp2 = itmp1 / 256**2 + num2bit4_big(2:2) = char(itmp2) + itmp1 =-itmp2 * 256**2 +itmp1 + itmp2 = itmp1 / 256 + num2bit4_big(3:3) = char(itmp2) + itmp1 =-itmp2 * 256 +itmp1 + num2bit4_big(4:4) = char(itmp1) +! + end function num2bit4_big +! +!------------------------------------------------------------------------ +! + character(len=2) function num2bit2_big(inum) +! + integer, intent(in) :: inum +! + integer :: itmp1, itmp2 +! +! + if(inum .lt. 0) then + itmp1 = inum + 32767 + 1 + itmp2 = itmp1 / 256 + num2bit2_big(1:1) = char(itmp2+128) + else + itmp1 = inum + itmp2 = itmp1 / 256 + num2bit2_big(1:1) = char(itmp2) + end if +! + itmp1 =-itmp2 * 256 +itmp1 + num2bit2_big(2:2) = char(itmp1) +! + end function num2bit2_big +! +!------------------------------------------------------------------------ +! + integer(kind = kint) function bit4_to_int_big(a) +! + character(len = 1), intent(in) :: a(4) + integer(kind = kint) :: i +! + i = iachar(a(4)) + 256*iachar(a(3)) + 65536 * iachar(a(2)) + if(iachar(a(1)) .ge. 128) then + i = i + 16777216 * (iachar(a(1)) - 128) - 2147483647 - 1 + else + i = i + 16777216 * iachar(a(1)) + end if + bit4_to_int_big = i +! + end function bit4_to_int_big +! +!------------------------------------------------------------------------ +! + integer(kind = kint) function bit2_to_int_big(a) +! + character(len = 1), intent(in) :: a(2) + integer(kind = kint) :: i +! + if(iachar(a(1)) .ge. 128) then + i = iachar(a(2)) + 256 * (iachar(a(2)) - 128) - 65535 - 1 + else + i = iachar(a(2)) + 256 * iachar(a(2)) + end if + bit2_to_int_big = i +! + end function bit2_to_int_big +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + subroutine crc32_4_png(ilength, cbuf, i_crc) +! + integer(kind = 4), intent(in) :: ilength + character(len = 1), intent(in) :: cbuf(ilength) + integer(kind = 4), intent(inout) :: i_crc +! + integer(kind = 4), parameter :: crc_init = -1 + integer(kind = 4), parameter :: crc_magic = -306674912 +! +! Failed definetion +! integer(kind = 4), parameter :: crc_init = Z'FFFFFFFF' +! integer(kind = 8), parameter :: crc_init = 4294967295 +! integer(kind = 8), parameter :: crc_init = 3 * 1431655765 +! integer(kind = 4), parameter :: crc_magic = Z'EDB88320' +! integer(kind = 8), parameter :: crc_magic = 3988292384 +! integer(kind = 8), parameter :: crc_magic = 2 * 1994146192 +! + integer(kind = 4) :: i_table(0:255) +! + integer(kind = 4) :: i_tmp, i_b + integer(kind = 4) :: i1, i3 + integer(kind = 4) :: i, j +! +! + do i = 0, 255 + i_tmp = i + do j = 0, 7 + i_b = iand(i_tmp,1) +! write(*,*) i,j,i_b, i_tmp + i_tmp = ishft(i_tmp,-1) + if(i_b .gt. 0) i_tmp = ieor(i_tmp,crc_magic) + end do + i_table(i) = i_tmp + end do +! + i_crc = not(i_crc) + do i = 1, ilength + i1 = iachar(cbuf(i)) + i3 = iand(ieor(i_crc,i1),255) + i_crc = ieor(i_table(i3), ishft(i_crc,-8)) +! write(*,*) i, i_crc + end do + i_crc = not(i_crc) +! write(*,*) crc32_4_png +! + end subroutine crc32_4_png +! +!------------------------------------------------------------------------ +! + end module number_to_bit diff --git a/src/Fortran_libraries/SERIAL_src/IO/write_bmp_image.f90 b/src/Fortran_libraries/SERIAL_src/IO/write_bmp_image.f90 new file mode 100644 index 00000000..c0a70e4f --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/IO/write_bmp_image.f90 @@ -0,0 +1,287 @@ +!>@file write_bmp_image.f90 +!!@brief module write_bmp_image +! +!> @brief FORTRAN 77 program to make PPM / BMP +!> by K. Hayashi +!! Modified by H. Matsui on June, 2009 +!! +!!@verbatim +!! subroutine pixout_ppm_p3(fhead, npixel_x, npixel_y, rgb) +!! subroutine pixout_ppm_p6(fhead, npixel_x, npixel_y, rgb) +!! subroutine pixout_BMP(fhead, npixel_x, npixel_y, rgb) +!! +!! character(len=kchara) function add_bmp_suffix(file_header) +!! character(len=kchara), intent(in) :: file_header +!! character(len=kchara), intent(in) :: fhead +!! integer, intent(in) :: ihpixf, jvpixf +!! +!! character(len=54) function BMP_header(ihpixf, jvpixf) +!! integer, intent(in) :: ihpixf, jvpixf +!! RGB data array +!! character(len=1), intent(in) :: rgb(3,ihpixf,jvpixf) +!! +!! subroutine cvt_8bit_cl_int_2_chara(ihpixf, jvpixf, icl_tbl, rgb) +!! integer, intent(in) :: icl_tbl(3,ihpixf,jvpixf) +!! +!!* -------------------------------------------- +!!* +!!* Notes +!!* o With a parameter ipixout set at 1, 2 or others, +!!* this subroutine will generate PPM-P6(binary), PPM-P3(text), +!!* or BMP(24bit depth without color table). +!!* +!!* o Some parts follow DEC-FORTRAN that had been defacto-standard long ago. +!!* Some compilers today may not accept if "ipixout" is not 2. +!!* +!!* o g77 (ver. 3.3.3) works for all three choices. +!!* o Recent intel compiler (ver. 9 or so) works for all three choices. +!!* +!!* -------------------------------------------- +!!@endverbatim +! + module write_bmp_image +! + use m_precision +! + implicit none +! + private :: add_ppm_suffix +! +!------------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------------ +! + subroutine pixout_ppm_p3(fhead, npixel_x, npixel_y, rgb) +! +!* interface arg. + character(len=kchara), intent(in) :: fhead + integer(kind = kint), intent(in) :: npixel_x, npixel_y +! RGB data array + character(len=1), intent(in) :: rgb(3,npixel_x,npixel_y) +!* local + integer, parameter :: id_img = 16 + character(len=kchara) :: fname + integer i, j, k, ihpixf, jvpixf + integer itmp, icnt +! +! + + ihpixf = int(npixel_x) + jvpixf = int(npixel_y) +! +!* PPM P3 ! rather "safer" choice for many Fortran compiler(s). + + fname = add_ppm_suffix(fhead) + open(unit=id_img,file=fname,status='unknown') + write(*,*) 'Now writing PPM (P3) file : ', fname +!* header + write(id_img,'(A)') 'P3' + write(id_img,'(2(1x,i4),'' 255 '')') ihpixf, jvpixf + icnt = 0 +! here, j (vertical address) runs from top to bottom. +!* image data + do j = jvpixf, 1, -1 + do i = 1, ihpixf, 1 + do k = 1, 3 + itmp = ichar(rgb(k,i,j)) + icnt = icnt + 4 + if (icnt .LT. 60) then +! mind "$" is not standard. + write(id_img,fmt='(1x,i3,$)') itmp + else + write(id_img,fmt='(1x,i3)') itmp + icnt = 0 + endif + end do + end do + end do + write(id_img,'(A)') ' ' + close(id_img) +! + end subroutine pixout_ppm_p3 +! +!------------------------------------------------------------------------ +! + subroutine pixout_ppm_p6(fhead, npixel_x, npixel_y, rgb) +! +!* interface arg. + character(len=kchara), intent(in) :: fhead + integer(kind = kint), intent(in) :: npixel_x, npixel_y +! RGB data array + character(len=1), intent(in) :: rgb(3,npixel_x,npixel_y) +! +!* local + integer, parameter :: id_img = 16 + character(len=kchara) :: fname + integer i, j, ihpixf, jvpixf + integer itmp + character(len=14) :: frmtstr +! +! + ihpixf = int(npixel_x) + jvpixf = int(npixel_y) +! +!* PPM P6 + fname = add_ppm_suffix(fhead) + open(unit=id_img,file=fname,status='unknown') + write(*,*) 'Now writing PPM (P6) file : ', fname +!* header + write(id_img,'(''P6'', 2(1x,i4),'' 255 '',$)') ihpixf, jvpixf +!* image data + itmp = ihpixf * jvpixf * 3 +! make output "format" + write(frmtstr,'(''('',i8.8,''A,$)'')') itmp + write(id_img,fmt=frmtstr) & + & ((rgb(1:3,i,j),i=1,ihpixf),j=jvpixf,1,-1) +! some compiler may not accept this line. +! here, j (vertical address) runs from top to bottom. + close(id_img) +! + end subroutine pixout_ppm_p6 +! +!------------------------------------------------------------------------ +! + subroutine pixout_BMP(fhead, npixel_x, npixel_y, rgb) +!* interface arg. + character(len=kchara), intent(in) :: fhead + integer(kind = kint), intent(in) :: npixel_x, npixel_y +! RGB data array + character(len=1), intent(in) :: rgb(3,npixel_x,npixel_y) +!* local + integer, parameter :: id_img = 16 + character(len=kchara) :: fname + integer :: i, j, ihpixf, jvpixf + integer :: itmp + character(len=14) :: frmtstr +! + ihpixf = int(npixel_x) + jvpixf = int(npixel_y) +! +!* BMP (24bit depth)... this part works only when width is multiple of 4. + + if (mod(ihpixf, 4) .NE. 0) then + write(*,*) 'width must be multiple of 4' + stop + endif +! + fname = add_bmp_suffix(fhead) +! open(unit=id_img,file=fname,status='unknown') +! write(id_img,'(a)') +! close(id_img) +! + open(unit=id_img,file=fname,status='unknown') + write(*,*) 'Now writing BMP(24bit) file : ', trim(fname) +!* writing header part + write(id_img,'(a54)',ADVANCE='NO') BMP_header(ihpixf, jvpixf) +!* image data + itmp = ihpixf * jvpixf * 3 + write(frmtstr,'(''('',i8.8,''A,$)'')') itmp + write(id_img,fmt=frmtstr) & + & ((rgb(3:1:-1,i,j),i=1,ihpixf),j=1,jvpixf) +! writing in BGR order, not RGB. + close(id_img) +! + end subroutine pixout_BMP +! +!------------------------------------------------------------------------ +! + character(len=54) function BMP_header(ihpixf, jvpixf) +! + use number_to_bit +! +!* interface arg. + integer, intent(in) :: ihpixf, jvpixf + character(len=54) :: headmsw +!* local + integer :: itmp + character(len=4) :: byt4 + character(len=2) :: byt2 +! +! +!* header 1 (file header ; 1--14 byte) + headmsw( 1: 2) = 'BM' ! declaring this is BMP file + itmp = 54 + ihpixf * jvpixf * 3 ! total file size = header + data + headmsw( 3: 6) = num2bit4_little(itmp) + itmp = 0 ! may be 0 + headmsw( 7: 8) = num2bit2_little(itmp) + itmp = 0 ! may be 0 + headmsw( 9:10) = num2bit2_little(itmp) + itmp = 54 ! must be 54 : total length of header + headmsw(11:14) = num2bit4_little(itmp) +!* header 2 (bit-map header ; 13--54 byte) + itmp = 40 ! must be 40 : length of bit-map header + headmsw(15:18) = num2bit4_little(itmp) + itmp = ihpixf ! width + headmsw(19:22) = num2bit4_little(itmp) + itmp = jvpixf ! height + headmsw(23:26) = num2bit4_little(itmp) + itmp = 1 ! must be 1 + headmsw(27:28) = num2bit2_little(itmp) + itmp = 24 ! must be 24 : color depth in bit. + headmsw(29:30) = num2bit2_little(itmp) + itmp = 0 ! may be 0 : compression method index + headmsw(31:34) = num2bit4_little(itmp) + itmp = 0 ! may be 0 : file size if compressed + headmsw(35:38) = num2bit4_little(itmp) + itmp = 0 ! arbit. : pixel per meter, horizontal + headmsw(39:42) = num2bit4_little(itmp) + itmp = 0 ! arbit. : pixel per meter, vertical + headmsw(43:46) = num2bit4_little(itmp) + itmp = 0 ! may be 0 here : num. of color used + headmsw(47:50) = num2bit4_little(itmp) + itmp = 0 ! may be 0 here : num. of important color + headmsw(51:54) = num2bit4_little(itmp) +! + BMP_header(1:54) = headmsw(1:54) +! + end function BMP_header +! +!------------------------------------------------------------------------ +!----------------------------------------------------------------------- +! + character(len=kchara) function add_ppm_suffix(file_header) +! + character(len=kchara), intent(in) :: file_header +! + write(add_ppm_suffix,1011) trim(file_header) + 1011 format (a,".ppm") +! + end function add_ppm_suffix +! +!----------------------------------------------------------------------- +! + character(len=kchara) function add_bmp_suffix(file_header) +! + character(len=kchara), intent(in) :: file_header +! + write(add_bmp_suffix,1011) trim(file_header) + 1011 format (a,".bmp") +! + end function add_bmp_suffix +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cvt_8bit_cl_int_2_chara(ihpixf, jvpixf, icl_tbl, rgb) +! + integer, intent(in) :: ihpixf, jvpixf + integer, intent(in) :: icl_tbl(3,ihpixf,jvpixf) +! RGB data array + character(len=1), intent(inout) :: rgb(3,ihpixf,jvpixf) +! + integer :: j +! +! + do j = 1, jvpixf + rgb(1,1:ihpixf,j) = char( icl_tbl(1,1:ihpixf,j) ) + rgb(2,1:ihpixf,j) = char( icl_tbl(2,1:ihpixf,j) ) + rgb(3,1:ihpixf,j) = char( icl_tbl(3,1:ihpixf,j) ) + end do +! + end subroutine cvt_8bit_cl_int_2_chara +! +!----------------------------------------------------------------------- +! + end module write_bmp_image diff --git a/src/Fortran_libraries/SERIAL_src/IO_ZLIB/Makefile.depends b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/Makefile.depends index f2d2cdf2..2d2ccbe6 100644 --- a/src/Fortran_libraries/SERIAL_src/IO_ZLIB/Makefile.depends +++ b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/Makefile.depends @@ -1,7 +1,11 @@ cal_buoyancies_sph_MHD.o: $(ZLIB_IO_DIR)/cal_buoyancies_sph_MHD.f90 m_precision.o m_machine_parameter.o m_constants.o t_phys_address.o $(F90) -c $(F90OPTFLAGS) $< +calypso_png_file_IO.o: $(ZLIB_IO_DIR)/calypso_png_file_IO.f90 m_precision.o m_png_file_IO.o t_buffer_4_gzip.o gzip_defleate.o number_to_bit.o filtering_rgba_png_line.o byte_swap_f.o transfer_to_long_integers.o gzip_infleate.o + $(F90) -c $(F90OPTFLAGS) $< data_convert_by_zlib.o: $(ZLIB_IO_DIR)/data_convert_by_zlib.f90 m_precision.o m_constants.o m_machine_parameter.o t_buffer_4_gzip.o transfer_to_long_integers.o gzip_defleate.o binary_IO.o gzip_infleate.o $(F90) -c $(F90OPTFLAGS) $< +filtering_rgba_png_line.o: $(ZLIB_IO_DIR)/filtering_rgba_png_line.f90 m_precision.o line_rgba_filtering_4_png.o transfer_to_long_integers.o + $(F90) -c $(F90OPTFLAGS) $< gz_binary_IO.o: $(ZLIB_IO_DIR)/gz_binary_IO.f90 m_precision.o m_constants.o m_machine_parameter.o m_error_IDs.o t_buffer_4_gzip.o binary_IO.o set_parallel_file_name.o skip_gz_comment.o gzip_file_access.o transfer_to_long_integers.o $(F90) -c $(F90OPTFLAGS) $< gz_comm_table_IO.o: $(ZLIB_IO_DIR)/gz_comm_table_IO.f90 m_precision.o t_geometry_data.o t_read_mesh_data.o t_comm_table.o t_surf_edge_IO.o t_buffer_4_gzip.o m_fem_surface_labels.o m_fem_mesh_labels.o gz_domain_data_IO.o gzip_file_access.o @@ -104,6 +108,12 @@ init_reference_scalar.o: $(ZLIB_IO_DIR)/init_reference_scalar.f90 m_precision.o $(F90) -c $(F90OPTFLAGS) $< input_old_file_sel_4_zlib.o: $(ZLIB_IO_DIR)/input_old_file_sel_4_zlib.F90 m_precision.o m_file_format_switch.o t_file_IO_parameter.o t_time_data.o t_field_data_IO.o gz_rst_data_IO_by_fld.o gz_field_file_IO.o field_file_IO.o set_field_file_names.o rst_data_IO_by_fld.o set_parallel_file_name.o $(F90) -c $(F90OPTFLAGS) $(F90CPPFLAGS) $< +line_rgba_filtering_4_png.o: $(ZLIB_IO_DIR)/line_rgba_filtering_4_png.f90 m_precision.o + $(F90) -c $(F90OPTFLAGS) $< +m_png_file_IO.o: $(ZLIB_IO_DIR)/m_png_file_IO.f90 m_precision.o number_to_bit.o transfer_to_long_integers.o byte_swap_f.o + $(F90) -c $(F90OPTFLAGS) $< +output_image_sel_4_png.o: $(ZLIB_IO_DIR)/output_image_sel_4_png.F90 m_precision.o m_constants.o t_png_file_access.o write_bmp_image.o calypso_png_file_IO.o + $(F90) -c $(F90OPTFLAGS) $(F90CPPFLAGS) $< sel_gz_read_sph_mtr_header.o: $(ZLIB_IO_DIR)/sel_gz_read_sph_mtr_header.f90 m_precision.o m_constants.o m_machine_parameter.o t_read_sph_spectra.o t_buffer_4_gzip.o select_gz_stream_file_IO.o $(F90) -c $(F90OPTFLAGS) $< skip_gz_comment.o: $(ZLIB_IO_DIR)/skip_gz_comment.f90 m_precision.o m_constants.o m_file_format_switch.o t_buffer_4_gzip.o gzip_file_access.o diff --git a/src/Fortran_libraries/SERIAL_src/IO_ZLIB/calypso_png_file_IO.f90 b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/calypso_png_file_IO.f90 new file mode 100644 index 00000000..b081cbd3 --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/calypso_png_file_IO.f90 @@ -0,0 +1,301 @@ +!>@file calypso_png_file_IO.f90 +!! module calypso_png_file_IO +!! +!! @author H. Matsui +!! @date Programmed in Oct., 2021 +!! +!! +!>@brief PNG image IO +!! +!!@verbatim +!! subroutine calypso_write_png & +!! & (file_prefix, n_rgb, npix_x, npix_y, rgb) +!! subroutine calypso_write_nofilter_png & +!! & (file_prefix, n_rgb, npix_x, npix_y, rgb) +!! character(len = kchara), intent(in) :: file_prefix +!! integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y +!! character(len = 1), intent(in) :: rgb(n_rgb*npix_x*npix_y) +!! +!! subroutine calypso_read_png_size(file_prefix, & +!! & flag_little_endian, n_rgb, npix_x, npix_y) +!! character(len = kchara), intent(in) :: file_prefix +!! integer(kind = 4), intent(in) :: n_rgb +!! integer(kind = 4), intent(inout) :: npix_x, npix_y +!! logical, intent(inout) :: flag_little_endian +!! subroutine calypso_read_png_data & +!! & (flag_little_endian, n_rgb, npix_x, npix_y, rgb) +!! logical, intent(in) :: flag_little_endian +!! integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y +!! character(len = 1), intent(inout) :: rgb(n_rgb*npix_x*npix_y) +!!@endverbatim +!! + module calypso_png_file_IO +! + use m_precision + use m_png_file_IO + use t_buffer_4_gzip +! + implicit none +! + integer(kind = 4), parameter, private :: id_png = 16 +! + private :: add_png_extension +! +!----------------------------------------------------------------------- +! + contains +! +!------------------------------------------------------------------------ +! + subroutine calypso_write_png & + & (file_prefix, n_rgb, npix_x, npix_y, rgb) +! + use gzip_defleate + use number_to_bit + use filtering_rgba_png_line +! + character(len = kchara), intent(in) :: file_prefix + integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y + character(len = 1), intent(in) :: rgb(n_rgb*npix_x*npix_y) +! + type(buffer_4_gzip) :: zbuf + character(len = kchara) :: file_name + character(len = 1), allocatable :: png_rgb(:) + integer(kind = kint) :: ntot_png_img + integer(kind = 4) :: i_crc + integer(kind = 4) :: date_time(8) + character(len=10) :: dt_c(3) +! +! + call date_and_time(dt_c(1), dt_c(2), dt_c(3), date_time) +! + ntot_png_img = 3*(npix_x+1)*npix_y + zbuf%ilen_gz = int(real(ntot_png_img)*1.01+24,KIND(zbuf%ilen_gz)) + call alloc_zip_buffer(zbuf) + allocate(png_rgb(ntot_png_img)) +! + call filter_png_image(3, npix_x, npix_y, rgb, png_rgb) +! + zbuf%ilen_gzipped = 0 + call zlib_defleat_char_once(ntot_png_img, png_rgb, & + & int(zbuf%ilen_gz), zbuf, zbuf%gzip_buf(1)) + deallocate(png_rgb) +! + file_name = add_png_extension(file_prefix) + write(*,*) 'Write PNG image: ', trim(file_name), & + & zbuf%ilen_gzipped, 'Byte image data' + open(id_png, file=file_name, access='STREAM') + call write_PNG_header_f(id_png, date_time, n_rgb, npix_x, npix_y) +! + i_crc = 0 + write(id_png) num2bit4_big(int(zbuf%ilen_gzipped)) + write(id_png) iDAT_HEADER + call crc32_4_png(len(iDAT_HEADER), iDAT_HEADER, i_crc) + write(id_png) zbuf%gzip_buf(1:zbuf%ilen_gzipped) + call crc32_4_png(int(zbuf%ilen_gzipped), zbuf%gzip_buf(1), i_crc) + write(id_png) num2bit4_big(i_crc) + call dealloc_zip_buffer(zbuf) +! + i_crc = 0 + write(id_png) num2bit4_big(len(iEND_HEADER)) + write(id_png) iEND_HEADER + call crc32_4_png(len(iEND_HEADER), iEND_HEADER, i_crc) + write(id_png) num2bit4_big(i_crc) + close(id_png) +! + end subroutine calypso_write_png +! +!------------------------------------------------------------------------ +! + subroutine calypso_write_nofilter_png & + & (file_prefix, n_rgb, npix_x, npix_y, rgb) +! + use gzip_defleate + use number_to_bit + use filtering_rgba_png_line +! + character(len = kchara), intent(in) :: file_prefix + integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y + character(len = 1), intent(in) :: rgb(n_rgb*npix_x*npix_y) +! + type(buffer_4_gzip) :: zbuf + character(len = kchara) :: file_name + character(len = 1), allocatable :: png_rgb(:) + integer(kind = kint) :: ntot_png_img + integer(kind = 4) :: i_crc + integer(kind = 4) :: date_time(8) + character(len=10) :: dt_c(3) +! +! + call date_and_time(dt_c(1), dt_c(2), dt_c(3), date_time) +! + ntot_png_img = 3*(npix_x+1)*npix_y + zbuf%ilen_gz = int(real(ntot_png_img)*1.01+24,KIND(zbuf%ilen_gz)) + call alloc_zip_buffer(zbuf) + allocate(png_rgb(ntot_png_img)) +! + call no_filter_png_image(3, npix_x, npix_y, rgb, png_rgb) +! + zbuf%ilen_gzipped = 0 + call zlib_defleat_char_once(ntot_png_img, png_rgb, & + & int(zbuf%ilen_gz), zbuf, zbuf%gzip_buf(1)) + deallocate(png_rgb) +! + file_name = add_png_extension(file_prefix) + write(*,*) 'Write PNG image: ', trim(file_name), & + & zbuf%ilen_gzipped, 'Byte image data' + open(id_png, file=file_name, access='STREAM') + call write_PNG_header_f(id_png, date_time, n_rgb, npix_x, npix_y) +! + i_crc = 0 + write(id_png) num2bit4_big(int(zbuf%ilen_gzipped)) + write(id_png) iDAT_HEADER + call crc32_4_png(len(iDAT_HEADER), iDAT_HEADER, i_crc) + write(id_png) zbuf%gzip_buf(1:zbuf%ilen_gzipped) + call crc32_4_png(int(zbuf%ilen_gzipped), zbuf%gzip_buf(1), i_crc) + write(id_png) num2bit4_big(i_crc) + call dealloc_zip_buffer(zbuf) +! + i_crc = 0 + write(id_png) num2bit4_big(len(iEND_HEADER)) + write(id_png) iEND_HEADER + call crc32_4_png(len(iEND_HEADER), iEND_HEADER, i_crc) + write(id_png) num2bit4_big(i_crc) + close(id_png) +! + end subroutine calypso_write_nofilter_png +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + subroutine calypso_read_png_size(file_prefix, & + & flag_little_endian, n_rgb, npix_x, npix_y) +! + use byte_swap_f + use number_to_bit + use transfer_to_long_integers +! + character(len = kchara), intent(in) :: file_prefix + integer(kind = 4), intent(inout) :: n_rgb, npix_x, npix_y + logical, intent(inout) :: flag_little_endian +! + character(len = kchara) :: file_name +! +! + file_name = add_png_extension(file_prefix) + write(*,*) 'Read PNG image: ', trim(file_name) + open(id_png, file=file_name, STATUS = 'old', access='STREAM') + call read_PNG_header_f(id_png, flag_little_endian, & + & n_rgb, npix_x, npix_y) +! + end subroutine calypso_read_png_size +! +!------------------------------------------------------------------------ +! + subroutine calypso_read_png_data & + & (flag_little_endian, n_rgb, npix_x, npix_y, rgb) +! + use gzip_infleate + use byte_swap_f + use number_to_bit + use transfer_to_long_integers + use filtering_rgba_png_line +! + logical, intent(in) :: flag_little_endian + integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y + character(len = 1), intent(inout) :: rgb(n_rgb*npix_x*npix_y) +! + type(buffer_4_gzip) :: zbuf + character(len = 1), allocatable :: gzipbuf(:) + character(len = 1), allocatable :: gzipbuf_tmp(:) + character(len = 1), allocatable :: png_rgb(:) + character(len = 32767) :: readbuf + integer(kind = 4) :: i_crc, ilength + integer(kind = 4) :: ntot_lenbuf, norg_lenbuf + integer(kind = 4) :: int_read(1) + integer(kind = 4) :: iy, icou +! +! + icou = 0 + ntot_lenbuf = 0 + allocate(gzipbuf(ntot_lenbuf)) + do + icou = icou + 1 + i_crc = 0 + read(id_png) int_read(1:1) + if(flag_little_endian) call byte_swap_int4_f(cast_long(1), & + & int_read) + ilength = int_read(1) +! + read(id_png) readbuf(1:4) + call crc32_4_png(len(readbuf(1:4)), readbuf(1:4), i_crc) +! + if(readbuf(1:4) .eq. iEND_HEADER) then +! write(*,*) icou, 'exit loop' + exit + else if(readbuf(1:4) .ne. iDAT_HEADER) then + write(*,*) icou, 'Something wrong' + exit +! else +! write(*,*) icou, 'read data', ilength, ' byte' + end if +! + read(id_png) readbuf(1:ilength) + call crc32_4_png(ilength, readbuf(1:ilength), i_crc) +! + read(id_png) int_read(1:1) + if(flag_little_endian) call byte_swap_int4_f(cast_long(1), & + & int_read) + if(int_read(1) .ne. i_crc) write(*,*) 'Fail at CRC' +! write(*,*) 'crc32', int_read(1), i_crc +! + allocate(gzipbuf_tmp(ntot_lenbuf)) + if(ntot_lenbuf .gt. 0) gzipbuf_tmp(1:ntot_lenbuf) & + & = gzipbuf(1:ntot_lenbuf) + deallocate(gzipbuf) +! + norg_lenbuf = ntot_lenbuf + ntot_lenbuf = ntot_lenbuf + ilength + allocate(gzipbuf(ntot_lenbuf)) + gzipbuf(1:norg_lenbuf) = gzipbuf_tmp(1:norg_lenbuf) + deallocate(gzipbuf_tmp) +! + do iy = 1, ilength + gzipbuf(iy+norg_lenbuf) = readbuf(iy:iy) + end do + end do +! + read(id_png) int_read(1:1) + if(flag_little_endian) call byte_swap_int4_f(cast_long(1), & + & int_read) + if(int_read(1) .ne. i_crc) write(*,*) 'Fail at CRC' +! write(*,*) 'crc32', int_read(1), i_crc + close (id_png) +! + allocate(png_rgb(3*(npix_x+1)*npix_y)) + zbuf%ilen_gz = ntot_lenbuf + call alloc_zip_buffer(zbuf) + call zlib_infleat_char_once(ntot_lenbuf, gzipbuf, & + & (n_rgb*(npix_x+1)*npix_y), png_rgb, zbuf) + call dealloc_zip_buffer(zbuf) +! + call unfilter_png_image(n_rgb, npix_x, npix_y, png_rgb, rgb) + deallocate(png_rgb) +! + end subroutine calypso_read_png_data +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + character(len=kchara) function add_png_extension(file_header) +! + character(len=kchara), intent(in) :: file_header +! + write(add_png_extension,1011) trim(file_header) + 1011 format (a,".png") +! + end function add_png_extension +! +!----------------------------------------------------------------------- +! + end module calypso_png_file_IO diff --git a/src/Fortran_libraries/SERIAL_src/IO_ZLIB/filtering_rgba_png_line.f90 b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/filtering_rgba_png_line.f90 new file mode 100644 index 00000000..14c776ac --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/filtering_rgba_png_line.f90 @@ -0,0 +1,302 @@ +!>@file filtering_rgba_png_line.f90 +!! module filtering_rgba_png_line +!! +!! @author H. Matsui +!! @date Programmed in Oct., 2021 +!! +!! +!>@brief Filtering for PNG image +!! +!!@verbatim +!! subroutine no_filter_png_image(n_rgb, npix_x, npix_y, & +!! & rgb, png_rgb) +!! subroutine filter_png_image(n_rgb, npix_x, npix_y, rgb, png_rgb) +!! integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y +!! character(len = 1), intent(in) :: rgb(n_rgb*npix_x*npix_y) +!! character(len = 1), intent(inout) & +!! & :: png_rgb(n_rgb*(npix_x+1)*npix_y) +!! +!! subroutine unfilter_png_rgba_line & +!! & (iflag_filter, iflag_left_edge, iflag_bottom, & +!! & npix_x, i_rgba_up, i_rgba_line) +!! integer(kind = 4), intent(in) :: iflag_filter +!! integer(kind = 4), intent(in) :: iflag_left_edge, iflag_bottom +!! integer(kind = 4), intent(in) :: npix_x +!! integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) +!! integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +!! subroutine sel_filter_png_rgb & +!! & (n_rgb, npix_x, npix_y, rgb, png_rgb) +!! integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y +!! character(len = 1), intent(in) :: rgb(n_rgb*npix_x*npix_y) +!! character(len = 1), intent(inout) & +!! & :: png_rgb(n_rgb*(npix_x+1)*npix_y) +!!@endverbatim +!! + module filtering_rgba_png_line +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!------------------------------------------------------------------------ +! + subroutine no_filter_png_image(n_rgb, npix_x, npix_y, & + & rgb, png_rgb) +! + integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y + character(len = 1), intent(in) :: rgb(n_rgb*npix_x*npix_y) + character(len = 1), intent(inout) & + & :: png_rgb(n_rgb*(npix_x+1)*npix_y) +! + integer(kind = 4) :: i, j, icou, jcou +! +! + do j = 1, npix_y + icou = 1 + (j-1)*(n_rgb*npix_x+1) + png_rgb(icou) = char(0) +!$omp parallel do private(i,jcou) + do i = 1, npix_x + jcou = n_rgb*(i-1) + (npix_y-j)*(n_rgb*npix_x) + icou = 1 + 3*(i-1) + (j-1)*(n_rgb*npix_x+1) + png_rgb(icou+1:icou+n_rgb) = rgb(jcou+1:jcou+n_rgb) + end do +!$omp end parallel do + end do +! + end subroutine no_filter_png_image +! +!------------------------------------------------------------------------ +! + subroutine filter_png_image(n_rgb, npix_x, npix_y, rgb, png_rgb) +! + use line_rgba_filtering_4_png + use transfer_to_long_integers +! + integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y + character(len = 1), intent(in) :: rgb(n_rgb*npix_x*npix_y) + character(len = 1), intent(inout) & + & :: png_rgb(n_rgb*(npix_x+1)*npix_y) +! + integer(kind = 4), allocatable :: i_rgba_line(:,:,:) + integer(kind = 4), allocatable :: i_rgba_up(:,:) +! + integer(kind = 4) :: iflag_sel + integer(kind = 4) :: i, j, icou, jcou +! +! + allocate(i_rgba_line(4,0:npix_x,0:4)) + allocate(i_rgba_up(4,0:npix_x)) +!$omp parallel workshare + i_rgba_line(1:4,0:npix_x,0:4) = 0 + i_rgba_up(1:4,0:npix_x) = 0 +!$omp end parallel workshare +! + iflag_sel = 0 + do j = 1, npix_y + i_rgba_line(1:4,0,0) = 0 +!$omp parallel do private(i,jcou) + do i = 1, npix_x + jcou = n_rgb*(i-1) + (npix_y-j)*(n_rgb*npix_x) + i_rgba_line(1:n_rgb,i,0) = iachar(rgb(jcou+1:jcou+n_rgb)) + end do +!$omp end parallel do +! + i_rgba_up(1:4,0) = 0 + if(j .eq. 0) then +!$omp parallel workshare + i_rgba_up(1:4,1:npix_x) = 0 +!$omp end parallel workshare + else +!$omp parallel do private(i,jcou) + do i = 1, npix_x + jcou = n_rgb*(i-1) + (npix_y-j+1)*(n_rgb*npix_x) + i_rgba_up(1:n_rgb,i) = iachar(rgb(jcou+1:jcou+n_rgb)) + end do +!$omp end parallel do + end if +! + call sel_filter_png_rgba_line(j, n_rgb, npix_x, i_rgba_up, & + & i_rgba_line, iflag_sel) +! + icou = 1 + (j-1)*(n_rgb*npix_x+1) + png_rgb(icou) = char(iflag_sel) +!$omp parallel do private(i,icou) + do i = 1, npix_x + icou = 1 + n_rgb*(i-1) + (j-1)*(n_rgb*npix_x+1) + png_rgb(icou+1:icou+n_rgb) = char(i_rgba_line(1:n_rgb,i,0)) + end do +!$omp end parallel do + end do + deallocate(i_rgba_line, i_rgba_up) +! + end subroutine filter_png_image +! +!------------------------------------------------------------------------ +! + subroutine unfilter_png_image(n_rgb, npix_x, npix_y, & + & png_rgb, rgb) +! + integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y + character(len = 1), intent(in) :: png_rgb(n_rgb*(npix_x+1)*npix_y) + character(len = 1), intent(inout) :: rgb(n_rgb*npix_x*npix_y) +! + integer(kind = 4), allocatable :: i_rgb_line(:,:) + integer(kind = 4), allocatable :: i_rgb_up(:,:) +! + integer(kind = 4) :: iflag_filter + integer(kind = 4) :: i, j, icou, jcou +! +! + allocate(i_rgb_line(4,0:npix_x)) + allocate(i_rgb_up(4,0:npix_x)) +!$omp parallel workshare + i_rgb_line(1:4,0:npix_x) = 0 + i_rgb_up(1:4,0:npix_x) = 0 +!$omp end parallel workshare +! + do j = 1, npix_y + iflag_filter = iachar(png_rgb(1+(j-1)*(n_rgb*npix_x+1))) +! write(*,*) j, iflag_filter +! +!$omp parallel workshare + i_rgb_up(1:4,0:npix_x) = i_rgb_line(1:4,0:npix_x) +!$omp end parallel workshare + i_rgb_line(1:4,0) = 0 +!$omp parallel do private(i,icou) + do i = 1, npix_x + icou = 1 + n_rgb*(i-1) + (j-1)*(n_rgb*npix_x+1) + i_rgb_line(1:n_rgb,i) = iachar(png_rgb(icou+1:icou+n_rgb)) + end do +!$omp end parallel do +! + call unfilter_png_rgba_line(iflag_filter, 1, j, & + & npix_x, i_rgb_up, i_rgb_line) +! +!$omp parallel do private(i,jcou) + do i = 1, npix_x + jcou = n_rgb*(i-1) + (npix_y-j)*(n_rgb*npix_x) + rgb(jcou+1:jcou+n_rgb) = char(i_rgb_line(1:n_rgb,i)) + end do +!$omp end parallel do + end do + deallocate(i_rgb_line, i_rgb_up) +! + end subroutine unfilter_png_image +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + subroutine sel_filter_png_rgba_line(j, n_rgb, npix_x, i_rgba_up, & + & i_rgba_line, iflag_sel) +! + use line_rgba_filtering_4_png + use transfer_to_long_integers +! + integer(kind = 4), intent(in) :: j + integer(kind = 4), intent(in) :: n_rgb, npix_x + integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) +! + integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x,0:4) + integer(kind = 4), intent(inout) :: iflag_sel +! + integer(kind = 4) :: i, k, ic, i_ref + integer(kind = 4) :: line_ave(0:4), line_sigma(0:4) +! +! + do k = 1, 4 +!$omp parallel workshare + i_rgba_line(1:4,0:npix_x,k) = i_rgba_line(1:4,0:npix_x,0) +!$omp end parallel workshare + end do +! + call sub_filter_png_rgba_line(npix_x, i_rgba_line(1,0,0), & + & i_rgba_line(1,0,1)) +! + call up_filter_png_rgba_line(npix_x, i_rgba_up, & + & i_rgba_line(1,0,0), i_rgba_line(1,0,2)) +! + call ave_filter_png_rgba_line(1, j, npix_x, i_rgba_up, & + & i_rgba_line(1,0,0), i_rgba_line(1,0,3)) +! + call paeth_filter_png_rgba_line(npix_x, i_rgba_up, & + & i_rgba_line(1,0,0), i_rgba_line(1,0,4)) +! + line_ave(0:4) = 0 + line_sigma(0:4) = 0 +!$omp parallel do private(k,i,ic) + do k = 0, 4 + do i = 1, npix_x + line_ave(k) = line_ave(k) & + & + i_rgba_line(1,i,k) + i_rgba_line(2,i,k) & + & + i_rgba_line(3,i,k) + i_rgba_line(4,i,k) + end do + line_ave(k) = line_ave(k) / (n_rgb*npix_x) +! + do i = 1, npix_x + do ic = 1, n_rgb + line_sigma(k) = line_sigma(k) & + & + abs(i_rgba_line(ic,i,k) - line_ave(k)) + end do + end do + end do +!$omp end parallel do +! +! + iflag_sel = 0 + i_ref = line_sigma(0) + do k = 1, 4 + if(line_sigma(k) .lt. i_ref) then + iflag_sel = k + i_ref = line_sigma(k) + end if + end do +! write(*,*) 'iflag_sel', j, iflag_sel, line_sigma(0:4) +! + if(iflag_sel .gt. 0) then +!$omp parallel do private(i) + do i = 1, npix_x + i_rgba_line(1:4,i,0) = i_rgba_line(1:4,i,iflag_sel) + end do +!$omp end parallel do + end if +! + end subroutine sel_filter_png_rgba_line +! +!------------------------------------------------------------------------ +! + subroutine unfilter_png_rgba_line & + & (iflag_filter, iflag_left_edge, iflag_bottom, & + & npix_x, i_rgba_up, i_rgba_line) +! + use line_rgba_filtering_4_png +! + integer(kind = 4), intent(in) :: iflag_filter + integer(kind = 4), intent(in) :: iflag_left_edge, iflag_bottom + integer(kind = 4), intent(in) :: npix_x + integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) +! + integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +! +! + if(iflag_filter .eq. 1) then + call sub_unfilter_png_rgba_line(npix_x, i_rgba_line) + else if(iflag_filter .eq. 2) then + call up_unfilter_png_rgba_line & + & (npix_x, i_rgba_up, i_rgba_line) + else if(iflag_filter .eq. 3) then + call ave_unfilter_png_rgba_line(iflag_left_edge, iflag_bottom, & + & npix_x, i_rgba_up, i_rgba_line) + else if(iflag_filter .eq. 4) then + call paeth_unfilter_png_rgba_line & + & (npix_x, i_rgba_up, i_rgba_line) + end if +! + end subroutine unfilter_png_rgba_line +! +!------------------------------------------------------------------------ +! + end module filtering_rgba_png_line diff --git a/src/Fortran_libraries/SERIAL_src/IO_ZLIB/line_rgba_filtering_4_png.f90 b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/line_rgba_filtering_4_png.f90 new file mode 100644 index 00000000..c00e1f11 --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/line_rgba_filtering_4_png.f90 @@ -0,0 +1,314 @@ +!>@file line_rgba_filtering_4_png.f90 +!! module line_rgba_filtering_4_png +!! +!! @author H. Matsui +!! @date Programmed in Jan., 2020 +!! +!! +!>@brief Line filtering peration for PNG image compression +!! +!!@verbatim +!! subroutine sub_filter_png_rgba_line & +!! & (npix_x, i_rgba_org, i_rgba_line) +!! subroutine sub_unfilter_png_rgba_line(npix_x, i_rgba_line) +!! integer(kind = 4), intent(in) :: npix_x +!! integer(kind = 4), intent(in) :: i_rgba_org(4,0:npix_x) +!! integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +!! +!! subroutine up_filter_png_rgba_line & +!! & (npix_x, i_rgba_up, i_rgba_org, i_rgba_line) +!! subroutine up_unfilter_png_rgba_line & +!! & (npix_x, i_rgba_up, i_rgba_line) +!! integer(kind = 4), intent(in) :: npix_x +!! integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) +!! integer(kind = 4), intent(in) :: i_rgba_org(4,0:npix_x) +!! integer(kind = 4), intent(inout) :: i_rgb_line(4,0:npix_x) +!! +!! subroutine ave_filter_png_rgba_line & +!! & (iflag_left_edge, iflag_bottom, & +!! & npix_x, i_rgba_up, i_rgba_line) +!! subroutine ave_unfilter_png_rgba_line & +!! & (iflag_left_edge, iflag_bottom, & +!! & npix_x, i_rgba_up, i_rgba_line) +!! integer(kind = 4), intent(in) :: iflag_left_edge, iflag_bottom +!! integer(kind = 4), intent(in) :: npix_x +!! integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) +!! integer(kind = 4), intent(in) :: i_rgba_org(4,0:npix_x) +!! integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +!! +!! subroutine paeth_filter_png_rgba_line & +!! & (npix_x, i_rgba_up, i_rgba_org, i_rgba_line) +!! subroutine paeth_unfilter_png_rgba_line & +!! & (npix_x, i_rgba_up, i_rgba_line) +!! integer(kind = 4), intent(in) :: npix_x +!! integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) +!! integer(kind = 4), intent(in) :: i_rgba_org(4,0:npix_x) +!! integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +!! +!! subroutine non_filter_png_rgba_line & +!! & (n_rgb, npix_x, i_rgb_line, rgb_line) +!! integer(kind = 4), intent(in) :: n_rgb, npix_x +!! integer(kind = 4), intent(in) :: i_rgb_line(4,0:npix_x) +!! character(len = 1), intent(inout) :: rgb_line(0:n_rgb*npix_x) +!!@endverbatim +!! + module line_rgba_filtering_4_png +! + use m_precision +! + implicit none +! + private :: set_paeth_predictor +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine sub_filter_png_rgba_line & + & (npix_x, i_rgba_org, i_rgba_line) +! + integer(kind = 4), intent(in) :: npix_x + integer(kind = 4), intent(in) :: i_rgba_org(4,0:npix_x) + integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +! + integer(kind = 4) :: i +! +! +!$omp parallel do + do i = 1, npix_x + i_rgba_line(1:4,i) & + & = mod(i_rgba_org(1:4,i) - i_rgba_org(1:4,i-1)+256,256) + end do +!$omp end parallel do +! + end subroutine sub_filter_png_rgba_line +! +!------------------------------------------------------------------------ +! + subroutine sub_unfilter_png_rgba_line(npix_x, i_rgba_line) +! + integer(kind = 4), intent(in) :: npix_x + integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +! + integer(kind = 4) :: i +! + do i = 1, npix_x + i_rgba_line(1:4,i) & + & = mod((i_rgba_line(1:4,i)+i_rgba_line(1:4,i-1)+256), 256) + end do +! + end subroutine sub_unfilter_png_rgba_line +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + subroutine up_filter_png_rgba_line & + & (npix_x, i_rgba_up, i_rgba_org, i_rgba_line) +! + integer(kind = 4), intent(in) :: npix_x + integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) + integer(kind = 4), intent(in) :: i_rgba_org(4,0:npix_x) + integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +! + integer(kind = 4) :: i +! +!$omp parallel do + do i = 1, npix_x + i_rgba_line(1:4,i) & + & = mod((i_rgba_org(1:4,i)-i_rgba_up(1:4,i)+256),256) + end do +!$omp end parallel do +! + end subroutine up_filter_png_rgba_line +! +!------------------------------------------------------------------------ +! + subroutine up_unfilter_png_rgba_line & + & (npix_x, i_rgba_up, i_rgba_line) +! + integer(kind = 4), intent(in) :: npix_x + integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) +! + integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +! + integer(kind = 4) :: i +! + do i = 1, npix_x + i_rgba_line(1:4,i) & + & = mod((i_rgba_line(1:4,i) + i_rgba_up(1:4,i)+256), 256) + end do +! + end subroutine up_unfilter_png_rgba_line +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + subroutine ave_filter_png_rgba_line & + & (iflag_left_edge, iflag_bottom, & + & npix_x, i_rgba_up, i_rgba_org, i_rgba_line) +! + integer(kind = 4), intent(in) :: iflag_left_edge, iflag_bottom + integer(kind = 4), intent(in) :: npix_x + integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) + integer(kind = 4), intent(in) :: i_rgba_org(4,0:npix_x) +! + integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +! + integer(kind = 4) :: ipaeth(4) + integer(kind = 4) :: i +! +!$omp parallel do private(i,ipaeth) + do i = 1, npix_x + if(iflag_left_edge .eq. 1 .and. iflag_bottom .eq. 1 & + & .and. i .eq. 1) then + ipaeth(1:4) = 0 + else if(i .eq. 1) then + ipaeth(1:4) = i_rgba_up(1:4,i) + else if(iflag_bottom .eq. 1) then + ipaeth(1:4) = i_rgba_org(1:4,i-1) + else + ipaeth(1:4) = (i_rgba_org(1:4,i-1) + i_rgba_up(1:4,i)) / 2 + end if + i_rgba_line(1:4,i) & + & = mod((i_rgba_org(1:4,i)-ipaeth(1:4)+256),256) + end do +!$omp end parallel do +! + end subroutine ave_filter_png_rgba_line +! +!------------------------------------------------------------------------ +! + subroutine ave_unfilter_png_rgba_line & + & (iflag_left_edge, iflag_bottom, & + & npix_x, i_rgba_up, i_rgba_line) +! + integer(kind = 4), intent(in) :: iflag_left_edge, iflag_bottom + integer(kind = 4), intent(in) :: npix_x + integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) +! + integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +! + integer(kind = 4) :: ipaeth(4) + integer(kind = 4) :: i +! +! + do i = 1, npix_x + if(iflag_left_edge .eq. 1 .and. iflag_bottom .eq. 1 & + & .and. i .eq. 1) then + ipaeth(1:4) = 0 + else if(i .eq. 1) then + ipaeth(1:4) = i_rgba_up(1:4,i) + else if(iflag_bottom .eq. 1) then + ipaeth(1:4) = i_rgba_line(1:4,i-1) + else + ipaeth(1:4) = (i_rgba_line(1:4,i-1)+i_rgba_up(1:4,i)) / 2 + end if + i_rgba_line(1:4,i) & + & = mod((i_rgba_line(1:4,i)+ipaeth(1:4)+256),256) + end do +! + end subroutine ave_unfilter_png_rgba_line +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + subroutine paeth_filter_png_rgba_line & + & (npix_x, i_rgba_up, i_rgba_org, i_rgba_line) +! + integer(kind = 4), intent(in) :: npix_x + integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) + integer(kind = 4), intent(in) :: i_rgba_org(4,0:npix_x) + integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +! + integer(kind = 4) :: ipaeth(4) + integer(kind = 4) :: i +! +!$omp parallel do private(i,ipaeth) + do i = 1, npix_x + call set_paeth_predictor & + & (i_rgba_org(1,i-1), i_rgba_up(1,i), i_rgba_up(1,i-1), & + & ipaeth) + i_rgba_line(1:4,i) & + & = mod((i_rgba_org(1:4,i)-ipaeth(1:4)+256),256) + end do +!$omp end parallel do +! + end subroutine paeth_filter_png_rgba_line +! +!------------------------------------------------------------------------ +! + subroutine paeth_unfilter_png_rgba_line & + & (npix_x, i_rgba_up, i_rgba_line) +! + integer(kind = 4), intent(in) :: npix_x + integer(kind = 4), intent(in) :: i_rgba_up(4,0:npix_x) +! + integer(kind = 4), intent(inout) :: i_rgba_line(4,0:npix_x) +! + integer(kind = 4) :: ipaeth(4) + integer(kind = 4) :: i +! + do i = 1, npix_x + call set_paeth_predictor & + & (i_rgba_line(1,i-1), i_rgba_up(1,i), i_rgba_up(1,i-1), & + & ipaeth) + i_rgba_line(1:4,i) & + & = mod((i_rgba_line(1:4,i)+ipaeth(1:4)+256),256) + end do +! + end subroutine paeth_unfilter_png_rgba_line +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + subroutine set_paeth_predictor(ileft, iup, idiag, ipaeth) +! + integer(kind = 4), intent(in) :: ileft(4), iup(4), idiag(4) + integer(kind = 4), intent(inout) :: ipaeth(4) +! + integer(kind = 4) :: itmp(4), jleft(4), jup(4), jdiag(4) + integer(kind = 4) :: nd +! + itmp(1:4) = ileft(1:4) + iup(1:4) - idiag(1:4) +! + jleft(1:4) = abs(itmp(1:4) - ileft(1:4)) + jup(1:4) = abs(itmp(1:4) - iup(1:4)) + jdiag(1:4) = abs(itmp(1:4) - idiag(1:4)) +! + do nd = 1, 4 + if(jleft(nd) .le. jup(nd) .and. jleft(nd) .le. jdiag(nd)) then + ipaeth(nd) = ileft(nd) + else if(jup(nd) .le. jdiag(nd)) then + ipaeth(nd) = iup(nd) + else + ipaeth(nd) = idiag(nd) + end if + end do +! + end subroutine set_paeth_predictor +! +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ +! + subroutine non_filter_png_rgba_line & + & (n_rgb, npix_x, i_rgb_line, rgb_line) +! + integer(kind = 4), intent(in) :: n_rgb, npix_x + integer(kind = 4), intent(in) :: i_rgb_line(4,0:npix_x) + character(len = 1), intent(inout) :: rgb_line(0:n_rgb*npix_x) +! + integer(kind = 4) :: i +! +!$omp parallel do + do i = 1, npix_x + rgb_line(n_rgb*(i-1)+1:n_rgb*i) = char(i_rgb_line(1:n_rgb,i)) + end do +!$omp end parallel do +! + end subroutine non_filter_png_rgba_line +! +!------------------------------------------------------------------------ +! + end module line_rgba_filtering_4_png diff --git a/src/Fortran_libraries/SERIAL_src/IO_ZLIB/m_png_file_IO.f90 b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/m_png_file_IO.f90 new file mode 100644 index 00000000..1da26c00 --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/m_png_file_IO.f90 @@ -0,0 +1,336 @@ +!>@file m_png_file_IO.f90 +!!@brief module m_png_file_IO +! +!>@brief FORTRAN routine to PNG image IO +!!@date Programmed by H. Matsui on Sep., 2021 +!! +!!@verbatim +!! subroutine write_PNG_header_f(id_png, date_time, & +!! & n_rgb, npix_x, npix_y) +!! integer(kind = 4), intent(in) :: id_png +!! integer(kind = 4), intent(in) :: date_time(8) +!! integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y +!! subroutine read_PNG_header_f(id_png, flag_endian, & +!! & n_rgb, npix_x, npix_y) +!! integer(kind = 4), intent(in) :: id_png +!! logical, intent(inout) :: flag_endian +!! integer(kind = 4), intent(inout) :: n_rgb, npix_x, npix_y +!!@endverbatim +! + module m_png_file_IO +! + use m_precision +! + implicit none +! +!> PNG header '\x89PNG\r\n\x1a\n' + character(len=1), parameter, private :: PNG_HEADER(8) & + & = (/char(137), 'P', 'N', 'G', & + & char(13), char(10), char(26), char(10)/) +! + integer(kind = 4), parameter, private :: len_ihdr = 13 + character(len=4), parameter, private :: IHDR_HEADER = 'IHDR' +! + character(len = 1), parameter :: BIT_DEPTH = char(8) +! + character(len = 1), parameter :: GRAY_TYPE = char(0) + character(len = 1), parameter :: RGB_TYPE = char(2) + character(len = 1), parameter :: GRAY_A_TYPE = char(4) + character(len = 1), parameter :: RGBA_TYPE = char(6) +! + character(len = 1), parameter :: COMPRESSION_METHOD = char(0) + character(len = 1), parameter :: FILTER_METHOD = char(0) + character(len = 1), parameter :: INTERLACE_METHOD = char(0) + private :: BIT_DEPTH, COMPRESSION_METHOD + private :: GRAY_TYPE, RGB_TYPE, GRAY_A_TYPE, RGBA_TYPE + private :: FILTER_METHOD, INTERLACE_METHOD +! + integer(kind = 4), parameter :: len_gama = 4 + character(len=4), parameter :: GAMMA_HEADER = 'gAMA' + real(kind = 8), parameter :: gamma = 1.0 / 2.2d0 + integer(kind = 4), parameter :: int_gamma = int(gamma * 100000) + private :: len_gama, GAMMA_HEADER, gamma, int_gamma +! + integer(kind = 4), parameter, private :: len_time = 7 + character(len=4), parameter, private :: TIME_HEADER = 'tIME' +! + character(len=4), parameter, private :: TEXT_HEADER = 'tEXt' + character(len = 22), parameter, private & + & :: SOFTWARE = "Software"//char(0)//"Calypso_viz" +! + character(len=4), parameter :: iDAT_HEADER = 'IDAT' + character(len = 4), parameter :: iEND_HEADER = "IEND" +! +!------------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------------ +! + subroutine write_PNG_header_f(id_png, date_time, & + & n_rgb, npix_x, npix_y) +! + use number_to_bit +! + integer(kind = 4), intent(in) :: id_png + integer(kind = 4), intent(in) :: date_time(8) + integer(kind = 4), intent(in) :: n_rgb, npix_x, npix_y +! + integer(kind = 4) :: i_crc + character(len = 1) :: COLOR_TYPE +! +! + write(id_png) PNG_HEADER(1:8) +! + i_crc = 0 + write(id_png) num2bit4_big(len_ihdr) + write(id_png) IHDR_HEADER + call crc32_4_png(len(IHDR_HEADER), IHDR_HEADER, i_crc) + write(id_png) num2bit4_big(npix_x) + call crc32_4_png(4, num2bit4_big(npix_x), i_crc) + write(id_png) num2bit4_big(npix_y) + call crc32_4_png(4, num2bit4_big(npix_y), i_crc) + write(id_png) BIT_DEPTH + call crc32_4_png(len(BIT_DEPTH), BIT_DEPTH, i_crc) +! + if(n_rgb .eq. 4) then + COLOR_TYPE = RGBA_TYPE + else if(n_rgb .eq. 2) then + COLOR_TYPE = GRAY_A_TYPE + else if(n_rgb .eq. 1) then + COLOR_TYPE = GRAY_TYPE + else + COLOR_TYPE = RGB_TYPE + end if +! + write(id_png) COLOR_TYPE + call crc32_4_png(len(COLOR_TYPE), COLOR_TYPE, i_crc) + write(id_png) COMPRESSION_METHOD + call crc32_4_png(len(COMPRESSION_METHOD), & + & COMPRESSION_METHOD, i_crc) + write(id_png) FILTER_METHOD + call crc32_4_png(len(FILTER_METHOD), FILTER_METHOD, i_crc) + write(id_png) INTERLACE_METHOD + call crc32_4_png(len(INTERLACE_METHOD), INTERLACE_METHOD, i_crc) + write(id_png) num2bit4_big(i_crc) +! + i_crc = 0 + write(id_png) num2bit4_big(len_gama) + write(id_png) GAMMA_HEADER + call crc32_4_png(len(GAMMA_HEADER), GAMMA_HEADER, i_crc) + write(id_png) num2bit4_big(int_gamma) + call crc32_4_png(len(num2bit4_big(int_gamma)), & + & num2bit4_big(int_gamma), i_crc) + write(id_png) num2bit4_big(i_crc) +! +! + i_crc = 0 + write(id_png) num2bit4_big(len_time) + write(id_png) TIME_HEADER + call crc32_4_png(len(TIME_HEADER), TIME_HEADER, i_crc) + write(id_png) num2bit2_big(date_time(1)) + call crc32_4_png(len(num2bit2_big(date_time(1))), & + & num2bit2_big(date_time(1)), i_crc) + write(id_png) char(date_time(2)) + call crc32_4_png(1, char(date_time(2)), i_crc) + write(id_png) char(date_time(3)) + call crc32_4_png(1, char(date_time(3)), i_crc) + write(id_png) char(date_time(5)) + call crc32_4_png(1, char(date_time(5)), i_crc) + write(id_png) char(date_time(6)) + call crc32_4_png(1, char(date_time(6)), i_crc) + write(id_png) char(date_time(7)) + call crc32_4_png(1, char(date_time(7)), i_crc) + write(id_png) num2bit4_big(i_crc) +! + i_crc = 0 + write(id_png) num2bit4_big(len(SOFTWARE)) + write(id_png) TEXT_HEADER + call crc32_4_png(len(TEXT_HEADER), TEXT_HEADER, i_crc) + write(id_png) SOFTWARE + call crc32_4_png(len(SOFTWARE), SOFTWARE, i_crc) + write(id_png) num2bit4_big(i_crc) +! + end subroutine write_PNG_header_f +! +!------------------------------------------------------------------------ +! + subroutine read_PNG_header_f(id_png, flag_endian, & + & n_rgb, npix_x, npix_y) +! + use number_to_bit +! + use transfer_to_long_integers + use byte_swap_f +! + integer(kind = 4), intent(in) :: id_png +! + logical, intent(inout) :: flag_endian + integer(kind = 4), intent(inout) :: n_rgb, npix_x, npix_y +! + character(len = 32767) :: readbuf + character(len = 1) :: cmp_char + integer(kind = 4) :: int_read(1) + integer(kind = 4) :: i_crc + integer(kind = 4) :: iy, ilength + integer(kind = 4) :: i_year +! +! + read(id_png) readbuf(1:8) + do iy = 1, size(PNG_HEADER) + cmp_char = readbuf(iy:iy) + if(cmp_char .ne. PNG_HEADER(iy)) write(*,*) 'Fail header at ', iy + end do +! + i_crc = 0 + read(id_png) int_read + if(int_read(1) .eq. len_ihdr) then + flag_endian = .FALSE. + write(*,*) 'Keep big endian flag correctly' + else + flag_endian = .TRUE. + call byte_swap_int4_f(cast_long(1), int_read) + if((int_read(1) .eq. len_ihdr) .and. flag_endian) & + & write(*,*) 'Flip endian flag correctly' + end if +! + i_crc = 0 + read(id_png) readbuf(1:4) + call crc32_4_png(len(readbuf(1:4)), readbuf(1:4), i_crc) + do iy = 1, len(IHDR_HEADER) + if(readbuf(iy:iy) .ne. IHDR_HEADER(iy:iy)) & + & write(*,*) 'Fail at ', iy + end do +! +! Read number of pixels + read(id_png) int_read(1:1) + if(flag_endian) call byte_swap_int4_f(cast_long(1), int_read) + call crc32_4_png(len(num2bit4_big(int_read(1))), & + & num2bit4_big(int_read(1)), i_crc) + npix_x = int_read(1) +! + read(id_png) int_read(1:1) + if(flag_endian) call byte_swap_int4_f(cast_long(1), int_read) + call crc32_4_png(len(num2bit4_big(int_read(1))), & + & num2bit4_big(int_read(1)), i_crc) + npix_y = int_read(1) +! +! Read Image parameters + read(id_png) readbuf(1:1) + call crc32_4_png(len(readbuf(1:1)), readbuf(1:1), i_crc) + if(readbuf(1:1) .ne. BIT_DEPTH) write(*,*) 'Fail at BIT_DEPTH' + read(id_png) readbuf(1:1) + call crc32_4_png(len(readbuf(1:1)), readbuf(1:1), i_crc) +! + if(readbuf(1:1) .eq. RGB_TYPE) then + n_rgb = 3 + else if(readbuf(1:1) .eq. RGBA_TYPE) then + n_rgb = 4 + else if(readbuf(1:1) .eq. GRAY_A_TYPE) then + n_rgb = 2 + else if(readbuf(1:1) .eq. GRAY_TYPE) then + n_rgb = 1 + else + write(*,*) 'Fail at COLOR_TYPE' + end if +! + read(id_png) readbuf(1:1) + call crc32_4_png(len(readbuf(1:1)), readbuf(1:1), i_crc) + if(readbuf(1:1) .ne. COMPRESSION_METHOD) & + & write(*,*) 'Fail at COMPRESSION_METHOD' + read(id_png) readbuf(1:1) + call crc32_4_png(len(readbuf(1:1)), readbuf(1:1), i_crc) + if(readbuf(1:1) .ne. FILTER_METHOD) & + & write(*,*) 'Fail at FILTER_METHOD' + read(id_png) readbuf(1:1) + call crc32_4_png(len(readbuf(1:1)), readbuf(1:1), i_crc) + if(readbuf(1:1) .ne. INTERLACE_METHOD) & + & write(*,*) 'Fail at INTERLACE_METHOD' +! + read(id_png) int_read(1:1) + if(flag_endian) call byte_swap_int4_f(cast_long(1), int_read) + if(int_read(1) .ne. i_crc) write(*,*) 'Fail at CRC' +! write(*,*) 'crc32', int_read(1), i_crc +! +! Read Gamma + i_crc = 0 + read(id_png) int_read(1:1) + if(flag_endian) call byte_swap_int4_f(cast_long(1), int_read) + if(int_read(1) .ne. len_gama) write(*,*) 'Fail at len_gama' + read(id_png) readbuf(1:4) + call crc32_4_png(len(readbuf(1:4)), readbuf(1:4), i_crc) + do iy = 1, len(GAMMA_HEADER) + if(readbuf(iy:iy) .ne. GAMMA_HEADER(iy:iy)) write(*,*) & + & 'Fail at ', iy + end do +! + read(id_png) int_read(1:1) + if(flag_endian) call byte_swap_int4_f(cast_long(1), int_read(1)) + call crc32_4_png(len(num2bit4_big(int_read(1))), & + & num2bit4_big(int_read(1)), i_crc) + if(int_read(1) .ne. int_gamma) write(*,*) 'Fail at int_gamma' + read(id_png) int_read(1:1) + if(flag_endian) call byte_swap_int4_f(cast_long(1), int_read) + if(int_read(1) .ne. i_crc) write(*,*) 'Fail at CRC' +! write(*,*) 'crc32', int_read(1), i_crc +! +! + i_crc = 0 + read(id_png) int_read(1:1) + if(flag_endian) call byte_swap_int4_f(cast_long(1), int_read) + if(int_read(1) .ne. len_time) write(*,*) 'Fail at len_time' + read(id_png) readbuf(1:4) + call crc32_4_png(len(readbuf(1:4)), readbuf(1:4), i_crc) + do iy = 1, len(TIME_HEADER) + if(readbuf(iy:iy) .ne. TIME_HEADER(iy:iy)) & + & write(*,*) 'Fail at ', iy + end do +! + read(id_png) readbuf(1:2) + call crc32_4_png(len(readbuf(1:2)), readbuf(1:2), i_crc) + i_year = 256*iachar(readbuf(1:1)) + iachar(readbuf(2:2)) + write(*,*) 'Year: ', i_year + read(id_png) readbuf(1:1) + call crc32_4_png(len(readbuf(1:1)), readbuf(1:1), i_crc) + write(*,*) 'Month: ', iachar(readbuf(1:1)) + read(id_png) readbuf(1:1) + call crc32_4_png(len(readbuf(1:1)), readbuf(1:1), i_crc) + write(*,*) 'Day: ', iachar(readbuf(1:1)) + read(id_png) readbuf(1:1) + call crc32_4_png(len(readbuf(1:1)), readbuf(1:1), i_crc) + write(*,*) 'Hour: ', iachar(readbuf(1:1)) + read(id_png) readbuf(1:1) + call crc32_4_png(len(readbuf(1:1)), readbuf(1:1), i_crc) + write(*,*) 'Minuts: ', iachar(readbuf(1:1)) + read(id_png) readbuf(1:1) + call crc32_4_png(len(readbuf(1:1)), readbuf(1:1), i_crc) + write(*,*) 'Seconds: ', iachar(readbuf(1:1)) + read(id_png) int_read(1:1) + if(flag_endian) call byte_swap_int4_f(cast_long(1), int_read) + if(int_read(1) .ne. i_crc) write(*,*) 'Fail at CRC' +! write(*,*) 'crc32', int_read(1), i_crc +! + i_crc = 0 + read(id_png) int_read(1:1) + if(flag_endian) call byte_swap_int4_f(cast_long(1), int_read) + ilength = int_read(1) + read(id_png) readbuf(1:4) + call crc32_4_png(len(readbuf(1:4)), readbuf(1:4), i_crc) + do iy = 1, len(TEXT_HEADER) + if(readbuf(iy:iy) .ne. TEXT_HEADER(iy:iy)) write(*,*) & + & 'Fail at ', iy + end do + read(id_png) readbuf(1:ilength) + call crc32_4_png(len(readbuf(1:ilength)), readbuf(1:ilength), & + & i_crc) + write(*,*) 'Text ', readbuf(1:ilength) + read(id_png) int_read(1:1) + if(flag_endian) call byte_swap_int4_f(cast_long(1), int_read) + if(int_read(1) .ne. i_crc) write(*,*) 'Fail at CRC' +! write(*,*) 'crc32', int_read(1), i_crc +! + end subroutine read_PNG_header_f +! +!------------------------------------------------------------------------ +! + end module m_png_file_IO diff --git a/src/Fortran_libraries/SERIAL_src/IO_ZLIB/output_image_sel_4_png.F90 b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/output_image_sel_4_png.F90 new file mode 100644 index 00000000..f5619bd6 --- /dev/null +++ b/src/Fortran_libraries/SERIAL_src/IO_ZLIB/output_image_sel_4_png.F90 @@ -0,0 +1,117 @@ +!> @file output_image_sel_4_png.f90 +!! module output_image_sel_4_png +!! +!! @author H. Matsui +!! @date Written in June, 2009 +! +!> @brief selector for image data output +!! +!!@verbatim +!! subroutine sel_output_image_file(id_file_type, img_head, & +!! & npix_x, npix_y, cimage) +!! subroutine sel_rgba_image_file(id_file_type, img_head, & +!! & npix_x, npix_y, cimage) +!!@endverbatim +! + module output_image_sel_4_png +! + use m_precision + use m_constants +! +#ifdef PNG_OUTPUT + use t_png_file_access +#endif +! + use write_bmp_image +! + implicit none +! + character(len = kchara), parameter :: hd_BMP = 'BMP' + character(len = kchara), parameter :: hd_PNG = 'PNG' + character(len = kchara), parameter :: hd_QUILT_BMP = 'QUILT' + character(len = kchara), parameter :: hd_QUILT_BMP_GZ = 'QUILT_GZ' +! + character(len = kchara), parameter & + & :: hd_QUILT_BMP_GZ2 = 'QUILT_GZIP' + character(len = kchara), parameter & + & :: hd_QUILT_BMP_GZ3 = 'GZ_QUILT' + character(len = kchara), parameter & + & :: hd_QUILT_BMP_GZ4 = 'GZIP_QUILT' +! + integer(kind = kint), parameter :: iflag_UNDEFINED = -1 + integer(kind = kint), parameter :: iflag_BMP = 11 + integer(kind = kint), parameter :: iflag_PNG = 12 + integer(kind = kint), parameter :: iflag_QUILT_BMP = 111 + integer(kind = kint), parameter :: iflag_QUILT_BMP_GZ = 113 + +#ifdef PNG_OUTPUT + type(buffer_4_png), private :: pbuf +#endif +! +!------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------ +! + subroutine sel_output_image_file(id_file_type, img_head, & + & npix_x, npix_y, cimage) +! + use calypso_png_file_IO +! + integer(kind = kint), intent(in) :: id_file_type + integer(kind = kint), intent(in) :: npix_x, npix_y + character(len=kchara), intent(in) :: img_head + character(len = 1), intent(in) :: cimage(3,npix_x*npix_y) +! +! + if(id_file_type .eq. iflag_PNG) then +#ifdef PNG_OUTPUT + call write_png_rgb_f & + & (img_head, npix_x, npix_y, cimage(1,1), pbuf) + return +#endif +#ifdef ZLIB_IO + call calypso_write_png & + & (img_head, ithree, npix_x, npix_y, cimage(1,1)) + return +#endif + end if +! + call pixout_BMP(img_head, npix_x, npix_y, cimage(1,1)) +! + end subroutine sel_output_image_file +! +!------------------------------------------------------------------ +! + subroutine sel_rgba_image_file(id_file_type, img_head, & + & npix_x, npix_y, cimage) +! + use calypso_png_file_IO +! + integer(kind = kint), intent(in) :: id_file_type + integer(kind = kint), intent(in) :: npix_x, npix_y + character(len=kchara), intent(in) :: img_head + character(len = 1), intent(in) :: cimage(4,npix_x*npix_y) +! +! + if(id_file_type .eq. iflag_PNG) then +#ifdef PNG_OUTPUT + call write_png_rgba_f & + & (img_head, npix_x, npix_y, cimage(1,1), pbuf) + return +#endif +#ifdef ZLIB_IO + call calypso_write_png & + & (img_head, ifour, npix_x, npix_y, cimage(1,1)) + return +#endif + end if +! + write(*,*) 'BitMap does not support transparent image' +! + end subroutine sel_rgba_image_file +! +!------------------------------------------------------------------ +! + end module output_image_sel_4_png diff --git a/src/Fortran_libraries/UTILS_src/MESH/Makefile.depends b/src/Fortran_libraries/UTILS_src/MESH/Makefile.depends index 78748e87..79ae65b6 100644 --- a/src/Fortran_libraries/UTILS_src/MESH/Makefile.depends +++ b/src/Fortran_libraries/UTILS_src/MESH/Makefile.depends @@ -6,6 +6,10 @@ check_geometries.o: $(MESHDIR)/check_geometries.f90 m_precision.o m_machine_para $(F90) -c $(F90OPTFLAGS) $< compare_mesh_structures.o: $(MESHDIR)/compare_mesh_structures.f90 m_precision.o m_machine_parameter.o t_comm_table.o t_geometry_data.o t_mesh_data.o m_phys_constants.o compare_indices.o copy_communication_table.o $(F90) -c $(F90OPTFLAGS) $< +const_bc_infinity_surf.o: $(MESHDIR)/const_bc_infinity_surf.f90 m_precision.o t_bc_data_list.o m_boundary_condition_IDs.o + $(F90) -c $(F90OPTFLAGS) $< +const_bc_infty_surf_type.o: $(MESHDIR)/const_bc_infty_surf_type.f90 m_precision.o t_bc_data_list.o t_group_data.o t_surface_boundary.o const_bc_infinity_surf.o t_mesh_data.o + $(F90) -c $(F90OPTFLAGS) $< const_edge_4_viewer.o: $(MESHDIR)/const_edge_4_viewer.f90 m_precision.o m_geometry_constants.o t_viewer_mesh.o t_viewer_group.o t_sum_hash.o t_edge_data.o const_grp_edge_4_viewer.o set_edge_hash_by_sf.o set_edge_data_by_sf.o $(F90) -c $(F90OPTFLAGS) $< const_edge_data.o: $(MESHDIR)/const_edge_data.f90 m_precision.o m_geometry_constants.o t_geometry_data.o t_surface_data.o t_edge_data.o t_sum_hash.o m_machine_parameter.o set_edge_hash_by_ele.o set_edge_data_by_ele.o set_local_id_table_4_1ele.o @@ -40,6 +44,8 @@ find_node_4_each_group.o: $(MESHDIR)/find_node_4_each_group.f90 m_precision.o m_ $(F90) -c $(F90OPTFLAGS) $< find_node_4_group.o: $(MESHDIR)/find_node_4_group.f90 m_precision.o m_constants.o calypso_mpi.o find_node_4_each_group.o quicksort.o $(F90) -c $(F90OPTFLAGS) $< +find_selected_domain_bd.o: $(MESHDIR)/find_selected_domain_bd.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< load_element_mesh_data.o: $(MESHDIR)/load_element_mesh_data.f90 m_precision.o m_constants.o m_machine_parameter.o t_mesh_data.o t_read_mesh_data.o t_file_IO_parameter.o set_surface_data_4_IO.o set_surface_data.o set_edge_data_4_IO.o $(F90) -c $(F90OPTFLAGS) $< load_mesh_data.o: $(MESHDIR)/load_mesh_data.f90 m_precision.o m_constants.o m_machine_parameter.o t_file_IO_parameter.o t_mesh_data.o t_comm_table.o t_geometry_data.o t_surface_data.o t_edge_data.o t_group_data.o mesh_IO_select.o set_nnod_4_ele_by_type.o cal_minmax_and_stacks.o set_element_data_4_IO.o copy_mesh_structures.o set_group_types_4_IO.o @@ -144,6 +150,8 @@ t_geometry_data.o: $(MESHDIR)/t_geometry_data.f90 m_precision.o m_machine_parame $(F90) -c $(F90OPTFLAGS) $< t_group_connects.o: $(MESHDIR)/t_group_connects.f90 m_precision.o $(F90) -c $(F90OPTFLAGS) $< +t_layering_ele_list.o: $(MESHDIR)/t_layering_ele_list.f90 m_precision.o t_group_data.o m_machine_parameter.o + $(F90) -c $(F90OPTFLAGS) $< t_merged_viewer_mesh.o: $(MESHDIR)/t_merged_viewer_mesh.f90 m_precision.o m_constants.o t_viewer_mesh.o t_viewer_group.o $(F90) -c $(F90OPTFLAGS) $< t_mesh_data.o: $(MESHDIR)/t_mesh_data.f90 m_precision.o t_comm_table.o t_geometry_data.o t_group_data.o t_surface_group_connect.o t_surface_data.o t_edge_data.o t_surface_group_normals.o t_group_connects.o t_surface_boundary.o @@ -156,6 +164,8 @@ t_psf_results.o: $(MESHDIR)/t_psf_results.f90 m_precision.o m_field_file_format. $(F90) -c $(F90OPTFLAGS) $< t_sum_hash.o: $(MESHDIR)/t_sum_hash.f90 m_precision.o $(F90) -c $(F90OPTFLAGS) $< +t_surf_grp_list_each_surf.o: $(MESHDIR)/t_surf_grp_list_each_surf.f90 m_precision.o t_surface_data.o t_group_data.o + $(F90) -c $(F90OPTFLAGS) $< t_surface_boundary.o: $(MESHDIR)/t_surface_boundary.f90 m_precision.o $(F90) -c $(F90OPTFLAGS) $< t_surface_data.o: $(MESHDIR)/t_surface_data.f90 m_precision.o m_geometry_constants.o m_machine_parameter.o diff --git a/src/Fortran_libraries/UTILS_src/MESH/const_bc_infinity_surf.f90 b/src/Fortran_libraries/UTILS_src/MESH/const_bc_infinity_surf.f90 new file mode 100644 index 00000000..124b344e --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/MESH/const_bc_infinity_surf.f90 @@ -0,0 +1,97 @@ +!>@file const_bc_infinity_surf.f90 +!!@brief module const_bc_infinity_surf +!! +!!@author H. Matsui +!!@date Programmed in Dec., 2008 +! +!>@brief Set group for infinity elements +!! +!!@verbatim +!! subroutine count_num_bc_infinity & +!! & (infty_BC, num_surf, surf_name, ngrp_sf_infty) +!! subroutine set_bc_infty_id(infty_BC, num_surf, surf_name, & +!! & ngrp_sf_infty, id_grp_sf_infty) +!! type(boundary_condition_list), intent(in) :: infty_BC +!!@endverbatim +! + module const_bc_infinity_surf +! + use m_precision + use t_bc_data_list +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine count_num_bc_infinity & + & (infty_BC, num_surf, surf_name, ngrp_sf_infty) +! + use m_boundary_condition_IDs +! + type(boundary_condition_list), intent(in) :: infty_BC + integer(kind=kint), intent(in) :: num_surf + character(len=kchara), intent(in) :: surf_name(num_surf) +! + integer (kind=kint), intent(inout) :: ngrp_sf_infty +! + integer (kind = kint) :: igrp, jgrp +! +! + ngrp_sf_infty = 0 + do igrp = 1, num_surf +! +! --- for infinity element + do jgrp = 1, infty_BC%num_bc + if (surf_name(igrp) .eq. infty_BC%bc_name(jgrp) & + & .and. infty_BC%ibc_type(jgrp) .eq. iflag_surf_infty) then + ngrp_sf_infty = ngrp_sf_infty + 1 + end if + end do + end do +! + end subroutine count_num_bc_infinity +! +!----------------------------------------------------------------------- +! + subroutine set_bc_infty_id(infty_BC, num_surf, surf_name, & + & ngrp_sf_infty, id_grp_sf_infty) +! + use m_boundary_condition_IDs +! + type(boundary_condition_list), intent(in) :: infty_BC + integer(kind=kint), intent(in) :: num_surf + character(len=kchara), intent(in) :: surf_name(num_surf) + integer (kind=kint), intent(in) :: ngrp_sf_infty +! + integer (kind=kint), intent(inout) & + & :: id_grp_sf_infty(ngrp_sf_infty) +! + integer (kind=kint) :: igrp, jgrp + integer (kind=kint) :: icou +! +! --------- boundary condition for temperature + icou = 0 + do igrp = 1, num_surf +! +! ----------- loop for boundary conditions + do jgrp = 1, infty_BC%num_bc +! +! ----------- check surface group + if (surf_name(igrp) .eq. infty_BC%bc_name(jgrp) & + & .and. infty_BC%ibc_type(jgrp) .eq. iflag_surf_infty) then + icou = icou + 1 + id_grp_sf_infty(icou) = igrp + end if +! + end do + end do +! + end subroutine set_bc_infty_id +! +!----------------------------------------------------------------------- +! + end module const_bc_infinity_surf diff --git a/src/Fortran_libraries/UTILS_src/MESH/const_bc_infty_surf_type.f90 b/src/Fortran_libraries/UTILS_src/MESH/const_bc_infty_surf_type.f90 new file mode 100644 index 00000000..de88bcd5 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/MESH/const_bc_infty_surf_type.f90 @@ -0,0 +1,67 @@ +!const_bc_infty_surf_type.f90 +! module const_bc_infty_surf_type +! +! written by H. Matsui on Dec., 2008 +! +! +!! subroutine const_bc_infinity_surf_grp & +!! & (infty_BC, surf_grp, infty_grp) +!! type(boundary_condition_list), intent(in) :: infty_BC +!! type(surface_group_data), intent(in) :: surf_grp +!! type(scalar_surf_BC_list), intent(inout) :: infty_grp +!! subroutine empty_infty_surf_type(group) +!! type(mesh_groups), intent(inout) :: group +! + module const_bc_infty_surf_type +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine const_bc_infinity_surf_grp & + & (infty_BC, surf_grp, infty_grp) +! + use t_bc_data_list + use t_group_data + use t_surface_boundary + use const_bc_infinity_surf +! + type(boundary_condition_list), intent(in) :: infty_BC + type(surface_group_data), intent(in) :: surf_grp + type(scalar_surf_BC_list), intent(inout) :: infty_grp +! +! + call count_num_bc_infinity(infty_BC, & + & surf_grp%num_grp, surf_grp%grp_name, infty_grp%ngrp_sf) +! + call alloc_scalar_surf_BC(infty_grp) +! + call set_bc_infty_id(infty_BC, surf_grp%num_grp, & + & surf_grp%grp_name, infty_grp%ngrp_sf, infty_grp%igrp_sf) +! + end subroutine const_bc_infinity_surf_grp +! +!----------------------------------------------------------------------- +! + subroutine empty_infty_surf_type(infty_grp) +! + use t_mesh_data + use const_bc_infinity_surf +! + type(scalar_surf_BC_list), intent(inout) :: infty_grp +! +! + infty_grp%ngrp_sf = 0 + call alloc_scalar_surf_BC(infty_grp) +! + end subroutine empty_infty_surf_type +! +!----------------------------------------------------------------------- +! + end module const_bc_infty_surf_type diff --git a/src/Fortran_libraries/UTILS_src/MESH/find_selected_domain_bd.f90 b/src/Fortran_libraries/UTILS_src/MESH/find_selected_domain_bd.f90 new file mode 100644 index 00000000..00e6a0f8 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/MESH/find_selected_domain_bd.f90 @@ -0,0 +1,108 @@ +!find_selected_domain_bd +! module find_selected_domain_bd +! +! subroutine allocate_imark_4_surface(numsurf) +! +!! subroutine mark_selected_domain_bd(numele, numsurf, isf_4_ele, & +!! & iflag_used_ele, imark_sf) +!! subroutine count_selected_domain_bd(numsurf, imark_sf, nsurf_bd) +!! subroutine s_find_selected_domain_bd & +!! & (numele, numsurf, iele_4_surf, imark_sf, & +!! & iflag_used_ele, nsurf_bd, isurf_bd_item) +! + module find_selected_domain_bd +! + use m_precision +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine mark_selected_domain_bd(numele, numsurf, isf_4_ele, & + & iflag_used_ele, imark_sf) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numele, numsurf + integer(kind = kint), intent(in) :: isf_4_ele(numele, nsurf_4_ele) + integer(kind = kint), intent(in) :: iflag_used_ele(numele) +! + integer(kind = kint), intent(inout) :: imark_sf(numsurf) +! + integer(kind = kint) :: iele, k1, isurf +! +! +! +!$omp parallel workshare + imark_sf(1:numsurf) = 0 +!$omp end parallel workshare +! + do k1 = 1, nsurf_4_ele + do iele = 1, numele + if(iflag_used_ele(iele) .gt. 0) then + isurf = abs(isf_4_ele(iele,k1)) + imark_sf(isurf) = imark_sf(isurf) + 1 + end if + end do + end do +! + end subroutine mark_selected_domain_bd +! +! --------------------------------------------------------------------- +! + subroutine count_selected_domain_bd(numsurf, imark_sf, nsurf_bd) +! + integer(kind = kint), intent(in) :: numsurf + integer(kind = kint), intent(in) :: imark_sf(numsurf) + integer(kind = kint), intent(inout) :: nsurf_bd +! + integer(kind = kint) :: isurf +! + nsurf_bd = 0 + do isurf = 1, numsurf + if(imark_sf(isurf) .eq. 1) nsurf_bd = nsurf_bd + 1 + end do +! + end subroutine count_selected_domain_bd +! +! --------------------------------------------------------------------- +! + subroutine s_find_selected_domain_bd & + & (numele, numsurf, iele_4_surf, imark_sf, & + & iflag_used_ele, nsurf_bd, isurf_bd_item) +! + integer(kind = kint), intent(in) :: numele, numsurf + integer(kind = kint), intent(in) :: iele_4_surf(numsurf,2,2) +! + integer(kind = kint), intent(in) :: imark_sf(numsurf) + integer(kind = kint), intent(in) :: iflag_used_ele(numele) + integer(kind = kint), intent(in) :: nsurf_bd + integer(kind = kint), intent(inout) :: isurf_bd_item(2,nsurf_bd) +! + integer(kind = kint) :: icou, isurf, iele +! +! + icou = 0 + do isurf = 1, numsurf + if(imark_sf(isurf) .eq. 1) then + icou = icou + 1 + iele = iele_4_surf(isurf,1,1) + if(iflag_used_ele(iele) .gt. 0) then + isurf_bd_item(1,icou) = iele + isurf_bd_item(2,icou) = iele_4_surf(isurf,1,2) + else + isurf_bd_item(1,icou) = iele_4_surf(isurf,2,1) + isurf_bd_item(2,icou) = iele_4_surf(isurf,2,2) + end if + end if + end do +! + end subroutine s_find_selected_domain_bd +! +! --------------------------------------------------------------------- +! + end module find_selected_domain_bd diff --git a/src/Fortran_libraries/UTILS_src/MESH/t_layering_ele_list.f90 b/src/Fortran_libraries/UTILS_src/MESH/t_layering_ele_list.f90 new file mode 100644 index 00000000..6f8d01b8 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/MESH/t_layering_ele_list.f90 @@ -0,0 +1,153 @@ +!>@file t_layering_ele_list.f90 +!! module t_layering_ele_list +!! +!!@author H. Matsui +!!@date Programmed in Nov., 2009 +! +!> @brief Structure of grouping of elements +!! +!!@verbatim +!! subroutine alloc_layering_ele_list_type(layer_tbl) +!! subroutine alloc_layer_items_type(layer_tbl) +!! subroutine alloc_layering_volumes_type(layer_tbl) +!! +!! subroutine dealloc_layering_ele_list_type(layer_tbl) +!! subroutine dealloc_layering_volumes_type(layer_tbl) +!! +!! subroutine check_layer_stack_type(id_rank, layer_tbl) +!!@endverbatim +! + module t_layering_ele_list +! + use m_precision + use t_group_data +! + implicit none +! +! layering element table +! +!> Structure of grouping of elements + type layering_tbl +!> element group structure for layering + type(group_data) :: e_grp +! +!> minimum number of each layer with SMP + integer(kind = kint) :: minlayer_4_smp +! +!> starting address for each layer for SMP + integer (kind = kint), allocatable & + & :: istack_item_layer_d_smp(:) +!> minimum number of each layer for SMP + integer(kind = kint) :: min_item_layer_d_smp +!> maximum number of each layer for SMP + integer(kind = kint) :: max_item_layer_d_smp +! +! volumes of layering area +! +!> volumes for each layer + real(kind = kreal), allocatable :: volumes_layer(:) +!> 1 / volumes_layer + real(kind = kreal), allocatable :: a_vol_layer(:) +! +!> volumes for all layer + real(kind = kreal) :: vol_total_layer(1) +!> 1 / vol_total_layer + real(kind = kreal) :: a_vol_total_layer(1) + end type layering_tbl +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine alloc_layering_ele_list_type(layer_tbl) +! + use m_machine_parameter +! + type(layering_tbl), intent(inout) :: layer_tbl +! +! + layer_tbl%e_grp%num_grp_smp = layer_tbl%e_grp%num_grp * np_smp + call alloc_group_num(layer_tbl%e_grp) + call alloc_group_smp(layer_tbl%e_grp) +! + allocate (layer_tbl%istack_item_layer_d_smp(0:np_smp) ) +! + if (layer_tbl%e_grp%num_grp .gt. 0) then + layer_tbl%istack_item_layer_d_smp = 0 + end if +! + end subroutine alloc_layering_ele_list_type +! +! ---------------------------------------------------------------------- +! + subroutine alloc_layer_items_type(layer_tbl) +! + type(layering_tbl), intent(inout) :: layer_tbl +! +! + call alloc_group_item(layer_tbl%e_grp) +! + end subroutine alloc_layer_items_type +! +! ---------------------------------------------------------------------- +! + subroutine alloc_layering_volumes_type(layer_tbl) +! + type(layering_tbl), intent(inout) :: layer_tbl +! +! + allocate( layer_tbl%volumes_layer(layer_tbl%e_grp%num_grp) ) + allocate( layer_tbl%a_vol_layer(layer_tbl%e_grp%num_grp) ) +! + if(layer_tbl%e_grp%num_grp .gt. 0) then + layer_tbl%volumes_layer = 0.0d0 + layer_tbl%a_vol_layer = 0.0d0 + end if +! + end subroutine alloc_layering_volumes_type +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine dealloc_layering_ele_list_type(layer_tbl) +! + type(layering_tbl), intent(inout) :: layer_tbl +! +! + call dealloc_group_smp(layer_tbl%e_grp) + call dealloc_group_item(layer_tbl%e_grp) + call dealloc_group_num(layer_tbl%e_grp) +! + deallocate (layer_tbl%istack_item_layer_d_smp ) +! + end subroutine dealloc_layering_ele_list_type +! +! ---------------------------------------------------------------------- +! + subroutine dealloc_layering_volumes_type(layer_tbl) +! + type(layering_tbl), intent(inout) :: layer_tbl +! +! + deallocate( layer_tbl%volumes_layer, layer_tbl%a_vol_layer) +! + end subroutine dealloc_layering_volumes_type +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine check_layer_stack_type(id_rank, layer_tbl) +! + integer, intent(in) :: id_rank + type(layering_tbl), intent(in) :: layer_tbl +! +! + call check_group_type_data(id_rank, layer_tbl%e_grp) +! + end subroutine check_layer_stack_type +! +! ---------------------------------------------------------------------- +! + end module t_layering_ele_list diff --git a/src/Fortran_libraries/UTILS_src/MESH/t_surf_grp_list_each_surf.f90 b/src/Fortran_libraries/UTILS_src/MESH/t_surf_grp_list_each_surf.f90 new file mode 100644 index 00000000..5b4e329e --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/MESH/t_surf_grp_list_each_surf.f90 @@ -0,0 +1,201 @@ +!>@file t_surf_grp_list_each_surf.f90 +!!@brief module t_surf_grp_list_each_surf +!! +!!@author H. Matsui +!!@date Programmed in Dec., 2008 +! +!> @brief Structure of connectivity data for surface group items +!! +!!@verbatim +!! subroutine init_sf_grp_list_each_surf(surf, surf_grp, & +!! & sf_grp_4_sf) +!! subroutine dealloc_num_sf_grp_each_surf(sf_grp_4_sf) +!! type(surface_data), intent(in) :: surf +!! type(surface_group_data), intent(in) :: surf_grp +!! type(sf_grp_list_each_surf), intent(inout) :: sf_grp_4_sf +!!@endverbatim +! + module t_surf_grp_list_each_surf +! + use m_precision + use t_surface_data + use t_group_data +! + implicit none +! + type sf_grp_list_each_surf +!> Total number of surfaces with surface group + integer(kind = kint) :: ntot_grp_4_surf +!> Number stack of surface group for each surface + integer(kind = kint), allocatable :: istack_grp_surf(:) +!> Ssurface group ID for each surface + integer(kind = kint), allocatable :: igrp_4_surf(:) + end type sf_grp_list_each_surf +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine init_sf_grp_list_each_surf(surf, surf_grp, & + & sf_grp_4_sf) +! + type(surface_data), intent(in) :: surf + type(surface_group_data), intent(in) :: surf_grp +! + type(sf_grp_list_each_surf), intent(inout) :: sf_grp_4_sf +! + integer(kind = kint), allocatable :: icou_surf(:) +! + allocate(icou_surf(surf%numsurf)) +!$omp parallel workshare + icou_surf(1:surf%numsurf) = 0 +!$omp end parallel workshare +! + call alloc_num_sf_grp_each_surf(surf, sf_grp_4_sf) +! + call count_sf_grp_list_each_surf(surf, surf_grp, & + & sf_grp_4_sf%ntot_grp_4_surf, sf_grp_4_sf%istack_grp_surf, & + & icou_surf) +! + call alloc_sf_grp_list_each_surf(sf_grp_4_sf) + call set_sf_grp_list_each_surf(surf, surf_grp, & + & sf_grp_4_sf%ntot_grp_4_surf, sf_grp_4_sf%istack_grp_surf, & + & icou_surf, sf_grp_4_sf%igrp_4_surf) + deallocate(icou_surf) +! + end subroutine init_sf_grp_list_each_surf +! +! ----------------------------------------------------------------------- +! + subroutine dealloc_num_sf_grp_each_surf(sf_grp_4_sf) +! + type(sf_grp_list_each_surf), intent(inout) :: sf_grp_4_sf +! +! + if(allocated(sf_grp_4_sf%igrp_4_surf) .eqv. .FALSE.) return + deallocate(sf_grp_4_sf%igrp_4_surf, sf_grp_4_sf%istack_grp_surf) + sf_grp_4_sf%ntot_grp_4_surf = 0 +! + end subroutine dealloc_num_sf_grp_each_surf +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine alloc_num_sf_grp_each_surf(surf, sf_grp_4_sf) +! + type(surface_data), intent(in) :: surf + type(sf_grp_list_each_surf), intent(inout) :: sf_grp_4_sf +! +! + allocate(sf_grp_4_sf%istack_grp_surf(0:surf%numsurf)) +!$omp parallel workshare + sf_grp_4_sf%istack_grp_surf(0:surf%numsurf) = 0 +!$omp end parallel workshare +! + end subroutine alloc_num_sf_grp_each_surf +! +! ----------------------------------------------------------------------- +! + subroutine alloc_sf_grp_list_each_surf(sf_grp_4_sf) +! + type(sf_grp_list_each_surf), intent(inout) :: sf_grp_4_sf +! +! + allocate(sf_grp_4_sf%igrp_4_surf(sf_grp_4_sf%ntot_grp_4_surf)) +! + if(sf_grp_4_sf%ntot_grp_4_surf .le. 0) return +!$omp parallel workshare + sf_grp_4_sf%igrp_4_surf(1:sf_grp_4_sf%ntot_grp_4_surf) = 0 +!$omp end parallel workshare +! + end subroutine alloc_sf_grp_list_each_surf +! +! ----------------------------------------------------------------------- +! + subroutine count_sf_grp_list_each_surf(surf, surf_grp, & + & ntot_grp_4_each_surf, istack_grp_4_each_surf, & + & icou_surf) +! + type(surface_data), intent(in) :: surf + type(surface_group_data), intent(in) :: surf_grp +! + integer(kind = kint), intent(inout) :: ntot_grp_4_each_surf + integer(kind = kint), intent(inout) :: icou_surf(surf%numsurf) + integer(kind = kint), intent(inout) & + & :: istack_grp_4_each_surf(0:surf%numsurf) +! + integer(kind = kint) :: igrp, ist, ied, inum + integer(kind = kint) :: iele, k1, isurf +! +! +!$omp parallel workshare + icou_surf(1:surf%numsurf) = 0 +!$omp end parallel workshare +! + do igrp = 1, surf_grp%num_grp + ist = surf_grp%istack_grp(igrp-1)+1 + ied = surf_grp%istack_grp(igrp) + do inum = ist, ied + iele = surf_grp%item_sf_grp(1,inum) + k1 = surf_grp%item_sf_grp(2,inum) + isurf = abs(surf%isf_4_ele(iele,k1)) +! + icou_surf(isurf) = icou_surf(isurf) + 1 + end do + end do +! + istack_grp_4_each_surf(0) = 0 + do isurf = 1, surf%numsurf + istack_grp_4_each_surf(isurf) & + & = istack_grp_4_each_surf(isurf-1) + icou_surf(isurf) + end do + ntot_grp_4_each_surf = istack_grp_4_each_surf(surf%numsurf) +! + end subroutine count_sf_grp_list_each_surf +! +! ----------------------------------------------------------------------- +! + subroutine set_sf_grp_list_each_surf(surf, surf_grp, & + & ntot_grp_4_each_surf, istack_grp_4_each_surf, & + & icou_surf, igrp_4_each_surf) +! + type(surface_data), intent(in) :: surf + type(surface_group_data), intent(in) :: surf_grp + integer(kind = kint), intent(in) :: ntot_grp_4_each_surf +! + integer(kind = kint), intent(inout) :: icou_surf(surf%numsurf) + integer(kind = kint), intent(inout) & + & :: istack_grp_4_each_surf(0:surf%numsurf) + integer(kind = kint), intent(inout) & + & :: igrp_4_each_surf(ntot_grp_4_each_surf) +! + integer(kind = kint) :: igrp, ist, ied, inum + integer(kind = kint) :: iele, k1, isurf, icou +! +! +!$omp parallel workshare + icou_surf(1:surf%numsurf) & + & = istack_grp_4_each_surf(0:surf%numsurf-1) +!$omp end parallel workshare +! + do igrp = 1, surf_grp%num_grp + ist = surf_grp%istack_grp(igrp-1)+1 + ied = surf_grp%istack_grp(igrp) + do inum = ist, ied + iele = surf_grp%item_sf_grp(1,inum) + k1 = surf_grp%item_sf_grp(2,inum) + isurf = abs(surf%isf_4_ele(iele,k1)) +! + icou_surf(isurf) = icou_surf(isurf) + 1 + icou = icou_surf(isurf) + igrp_4_each_surf(icou) = igrp + end do + end do +! + end subroutine set_sf_grp_list_each_surf +! +! ----------------------------------------------------------------------- +! + end module t_surf_grp_list_each_surf diff --git a/src/Fortran_libraries/UTILS_src/Makefile b/src/Fortran_libraries/UTILS_src/Makefile index e5a969e8..0f20b95a 100644 --- a/src/Fortran_libraries/UTILS_src/Makefile +++ b/src/Fortran_libraries/UTILS_src/Makefile @@ -8,7 +8,8 @@ LIB_UTILS = -lcalypso_utils LIB_UTILS_FILE = libcalypso_utils.a SUBDIRS = \ -MESH \ +MESH \ +jacobian \ MERGE diff --git a/src/Fortran_libraries/UTILS_src/jacobian/Makefile b/src/Fortran_libraries/UTILS_src/jacobian/Makefile new file mode 100644 index 00000000..4beff907 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/Makefile @@ -0,0 +1,32 @@ +# +# +# + +JACOBIDIR = $$(UTILS_SRCDIR)/jacobian + +SOURCES = $(shell ls *.f90) +MOD_JACOBI = $(addsuffix .o,$(basename $(SOURCES)) ) + +# +# ------------------------------------------------------------------------- +# + +dir_list: + @echo 'JACOBIDIR = $(JACOBIDIR)' >> $(MAKENAME) + +lib_archve: + @echo ' $$(AR) $$(ARFLUGS) rcsv $$@ $$(MOD_JACOBI)' >> $(MAKENAME) + +mod_list: + @echo MOD_JACOBI= \\ >> $(MAKENAME) + @echo $(MOD_JACOBI) >> $(MAKENAME) + + +module: + @cat Makefile.depends >> $(MAKENAME) + +depends: + @$(MAKE_MOD_DEP) Makefile.depends '$$(JACOBIDIR)' $(SOURCES) + +clean: + rm -f *.o *.mod *~ *.par *.diag *.a diff --git a/src/Fortran_libraries/UTILS_src/jacobian/Makefile.depends b/src/Fortran_libraries/UTILS_src/jacobian/Makefile.depends new file mode 100644 index 00000000..881955d4 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/Makefile.depends @@ -0,0 +1,119 @@ +cal_1edge_jacobians.o: $(JACOBIDIR)/cal_1edge_jacobians.f90 m_precision.o m_geometry_constants.o cal_jacobian_1d.o + $(F90) -c $(F90OPTFLAGS) $< +cal_1ele_jacobians.o: $(JACOBIDIR)/cal_1ele_jacobians.f90 m_precision.o m_geometry_constants.o cal_jacobian_3d_linear.o cal_jacobian_3d_quad.o cal_jacobian_3d_lag.o cal_jacobian_3d_linear_quad.o + $(F90) -c $(F90OPTFLAGS) $< +cal_1ele_jacobians_infinte.o: $(JACOBIDIR)/cal_1ele_jacobians_infinte.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o cal_shape_func_infty_3d.o cal_jacobian_3d_inf_linear.o cal_jacobian_3d_inf_quad.o cal_jacobian_3d_inf_lag.o cal_jacobian_3d_inf_l_quad.o + $(F90) -c $(F90OPTFLAGS) $< +cal_1surf_grp_jacobians.o: $(JACOBIDIR)/cal_1surf_grp_jacobians.f90 m_precision.o m_geometry_constants.o cal_jacobian_sf_grp_linear.o cal_jacobian_sf_grp_quad.o cal_jacobian_sf_grp_lag.o cal_jacobian_sf_grp_l_quad.o + $(F90) -c $(F90OPTFLAGS) $< +cal_1surf_jacobians.o: $(JACOBIDIR)/cal_1surf_jacobians.f90 m_precision.o m_geometry_constants.o cal_jacobian_2d_linear.o cal_jacobian_2d_quad.o cal_jacobian_2d_lag.o cal_jacobian_2d_linear_quad.o + $(F90) -c $(F90OPTFLAGS) $< +cal_gradient_on_element.o: $(JACOBIDIR)/cal_gradient_on_element.f90 m_precision.o m_constants.o m_machine_parameter.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_1d.o: $(JACOBIDIR)/cal_jacobian_1d.f90 m_precision.o m_geometry_constants.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_2d_lag.o: $(JACOBIDIR)/cal_jacobian_2d_lag.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_2d_linear.o: $(JACOBIDIR)/cal_jacobian_2d_linear.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_2d_linear_quad.o: $(JACOBIDIR)/cal_jacobian_2d_linear_quad.f90 m_precision.o m_constants.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_2d_quad.o: $(JACOBIDIR)/cal_jacobian_2d_quad.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_3d_inf_l_quad.o: $(JACOBIDIR)/cal_jacobian_3d_inf_l_quad.f90 m_precision.o m_geometry_constants.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_3d_inf_lag.o: $(JACOBIDIR)/cal_jacobian_3d_inf_lag.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_3d_inf_linear.o: $(JACOBIDIR)/cal_jacobian_3d_inf_linear.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_3d_inf_quad.o: $(JACOBIDIR)/cal_jacobian_3d_inf_quad.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_3d_lag.o: $(JACOBIDIR)/cal_jacobian_3d_lag.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_3d_linear.o: $(JACOBIDIR)/cal_jacobian_3d_linear.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_3d_linear_quad.o: $(JACOBIDIR)/cal_jacobian_3d_linear_quad.f90 m_precision.o m_constants.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_3d_quad.o: $(JACOBIDIR)/cal_jacobian_3d_quad.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_sf_grp_l_quad.o: $(JACOBIDIR)/cal_jacobian_sf_grp_l_quad.f90 m_precision.o m_constants.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_sf_grp_lag.o: $(JACOBIDIR)/cal_jacobian_sf_grp_lag.f90 m_precision.o m_constants.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_sf_grp_linear.o: $(JACOBIDIR)/cal_jacobian_sf_grp_linear.f90 m_precision.o m_constants.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_jacobian_sf_grp_quad.o: $(JACOBIDIR)/cal_jacobian_sf_grp_quad.f90 m_precision.o m_constants.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_layered_volumes.o: $(JACOBIDIR)/cal_layered_volumes.f90 m_precision.o m_constants.o m_machine_parameter.o t_geometry_data.o t_layering_ele_list.o calypso_mpi.o calypso_mpi_real.o transfer_to_long_integers.o + $(F90) -c $(F90OPTFLAGS) $< +cal_shape_func_infty_3d.o: $(JACOBIDIR)/cal_shape_func_infty_3d.f90 m_precision.o m_geometry_constants.o set_shape_elements_infty_sf.o shape_func_3d_linear.o shape_func_3d_quad.o shape_func_3d_lag.o + $(F90) -c $(F90OPTFLAGS) $< +cal_shape_function_1d.o: $(JACOBIDIR)/cal_shape_function_1d.f90 m_precision.o m_constants.o m_geometry_constants.o shape_func_elements.o shape_func_1d_linear.o shape_func_1d_quad.o + $(F90) -c $(F90OPTFLAGS) $< +cal_shape_function_2d.o: $(JACOBIDIR)/cal_shape_function_2d.f90 m_precision.o m_constants.o m_geometry_constants.o shape_func_elements.o shape_func_2d_linear.o shape_func_2d_quad.o shape_func_2d_lag.o + $(F90) -c $(F90OPTFLAGS) $< +cal_shape_function_3d.o: $(JACOBIDIR)/cal_shape_function_3d.f90 m_precision.o m_constants.o m_geometry_constants.o shape_func_elements.o shape_func_3d_linear.o shape_func_3d_quad.o shape_func_3d_lag.o + $(F90) -c $(F90OPTFLAGS) $< +const_jacobians_1d.o: $(JACOBIDIR)/const_jacobians_1d.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o t_geometry_data.o t_edge_data.o t_fem_gauss_int_coefs.o t_shape_functions.o t_jacobian_1d.o cal_1edge_jacobians.o cal_shape_function_1d.o + $(F90) -c $(F90OPTFLAGS) $< +const_jacobians_2d.o: $(JACOBIDIR)/const_jacobians_2d.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o t_geometry_data.o t_surface_data.o t_group_data.o t_fem_gauss_int_coefs.o t_shape_functions.o t_jacobian_2d.o cal_1surf_jacobians.o cal_shape_function_2d.o + $(F90) -c $(F90OPTFLAGS) $< +const_jacobians_3d.o: $(JACOBIDIR)/const_jacobians_3d.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o t_geometry_data.o t_shape_functions.o t_fem_gauss_int_coefs.o t_jacobian_3d.o t_group_data.o t_surface_boundary.o cal_1ele_jacobians.o cal_shape_function_3d.o set_gauss_int_parameters.o set_integration_indices.o + $(F90) -c $(F90OPTFLAGS) $< +const_jacobians_infinity.o: $(JACOBIDIR)/const_jacobians_infinity.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o t_mesh_data.o t_geometry_data.o t_group_data.o t_fem_gauss_int_coefs.o t_shape_functions.o t_jacobian_3d.o cal_1ele_jacobians_infinte.o + $(F90) -c $(F90OPTFLAGS) $< +const_jacobians_sf_grp.o: $(JACOBIDIR)/const_jacobians_sf_grp.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o t_geometry_data.o t_surface_data.o t_group_data.o t_fem_gauss_int_coefs.o t_shape_functions.o t_jacobian_2d.o cal_1surf_grp_jacobians.o cal_shape_function_2d.o + $(F90) -c $(F90OPTFLAGS) $< +fem_element_volume.o: $(JACOBIDIR)/fem_element_volume.f90 m_precision.o m_machine_parameter.o t_fem_gauss_int_coefs.o t_geometry_data.o t_jacobians.o + $(F90) -c $(F90OPTFLAGS) $< +int_area_normal_4_surface.o: $(JACOBIDIR)/int_area_normal_4_surface.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o t_geometry_data.o t_surface_data.o t_group_data.o t_fem_gauss_int_coefs.o t_jacobian_2d.o + $(F90) -c $(F90OPTFLAGS) $< +int_volume_of_domain.o: $(JACOBIDIR)/int_volume_of_domain.f90 m_precision.o m_constants.o t_mesh_data.o t_geometry_data.o t_group_data.o t_surface_boundary.o t_shape_functions.o t_fem_gauss_int_coefs.o t_jacobians.o t_surface_group_normals.o set_normal_vectors.o const_jacobians_3d.o sum_volume_of_domain.o const_bc_infty_surf_type.o t_layering_ele_list.o cal_layered_volumes.o calypso_mpi_real.o fem_element_volume.o + $(F90) -c $(F90OPTFLAGS) $< +m_gauss_int_parameters.o: $(JACOBIDIR)/m_gauss_int_parameters.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +set_gauss_int_parameters.o: $(JACOBIDIR)/set_gauss_int_parameters.f90 m_precision.o m_constants.o m_gauss_int_parameters.o t_gauss_points.o + $(F90) -c $(F90OPTFLAGS) $< +set_integration_indices.o: $(JACOBIDIR)/set_integration_indices.f90 m_precision.o m_gauss_int_parameters.o + $(F90) -c $(F90OPTFLAGS) $< +set_normal_vectors.o: $(JACOBIDIR)/set_normal_vectors.f90 m_precision.o m_machine_parameter.o t_mesh_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_surface_group_normals.o t_shape_functions.o t_fem_gauss_int_coefs.o t_jacobians.o t_jacobian_2d.o int_area_normal_4_surface.o sum_normal_4_surf_group.o set_connects_4_surf_group.o + $(F90) -c $(F90OPTFLAGS) $< +set_shape_elements_infty_sf.o: $(JACOBIDIR)/set_shape_elements_infty_sf.f90 m_precision.o m_constants.o shape_func_elements.o shape_func_infty_elements.o + $(F90) -c $(F90OPTFLAGS) $< +shape_func_1d_linear.o: $(JACOBIDIR)/shape_func_1d_linear.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +shape_func_1d_quad.o: $(JACOBIDIR)/shape_func_1d_quad.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +shape_func_2d_lag.o: $(JACOBIDIR)/shape_func_2d_lag.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +shape_func_2d_linear.o: $(JACOBIDIR)/shape_func_2d_linear.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +shape_func_2d_quad.o: $(JACOBIDIR)/shape_func_2d_quad.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +shape_func_3d_lag.o: $(JACOBIDIR)/shape_func_3d_lag.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +shape_func_3d_linear.o: $(JACOBIDIR)/shape_func_3d_linear.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +shape_func_3d_quad.o: $(JACOBIDIR)/shape_func_3d_quad.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +shape_func_elements.o: $(JACOBIDIR)/shape_func_elements.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +shape_func_infty_elements.o: $(JACOBIDIR)/shape_func_infty_elements.f90 m_precision.o m_constants.o shape_func_elements.o + $(F90) -c $(F90OPTFLAGS) $< +sum_normal_4_surf_group.o: $(JACOBIDIR)/sum_normal_4_surf_group.f90 m_precision.o calypso_mpi.o calypso_mpi_real.o m_machine_parameter.o t_geometry_data.o t_group_data.o t_surface_group_normals.o transfer_to_long_integers.o + $(F90) -c $(F90OPTFLAGS) $< +sum_volume_of_domain.o: $(JACOBIDIR)/sum_volume_of_domain.f90 m_precision.o m_machine_parameter.o + $(F90) -c $(F90OPTFLAGS) $< +t_fem_gauss_int_coefs.o: $(JACOBIDIR)/t_fem_gauss_int_coefs.f90 m_precision.o m_constants.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +t_jacobian_1d.o: $(JACOBIDIR)/t_jacobian_1d.f90 m_precision.o + $(F90) -c $(F90OPTFLAGS) $< +t_jacobian_2d.o: $(JACOBIDIR)/t_jacobian_2d.f90 m_precision.o + $(F90) -c $(F90OPTFLAGS) $< +t_jacobian_3d.o: $(JACOBIDIR)/t_jacobian_3d.f90 m_precision.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +t_jacobians.o: $(JACOBIDIR)/t_jacobians.f90 m_precision.o m_geometry_constants.o t_fem_gauss_int_coefs.o t_geometry_data.o t_surface_data.o t_edge_data.o t_group_data.o t_shape_functions.o t_jacobian_3d.o t_jacobian_2d.o t_jacobian_1d.o const_jacobians_3d.o const_jacobians_infinity.o const_jacobians_sf_grp.o const_jacobians_2d.o const_jacobians_1d.o + $(F90) -c $(F90OPTFLAGS) $< +t_shape_functions.o: $(JACOBIDIR)/t_shape_functions.f90 m_precision.o t_fem_gauss_int_coefs.o + $(F90) -c $(F90OPTFLAGS) $< + diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_1edge_jacobians.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_1edge_jacobians.f90 new file mode 100644 index 00000000..2537e9c7 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_1edge_jacobians.f90 @@ -0,0 +1,171 @@ +!>@file cal_1edge_jacobians.f90 +!! module cal_1edge_jacobians +!! +!!@author H. Matsui +!!@date Programmed on Dec., 2008 +!!@n Modified by H. Matsui on Aug., 2015 +! +!> @brief obtain jacobian at one gauss point for linear element +!! +!!@verbatim +!! subroutine cal_jacobian_1d_2(numnod, numedge, nnod_4_edge, & +!! & ie_edge, xx, np_smp, iedge_smp_stack, & +!! & max_int_point, int_start1, ntot_int_1d, & +!! & xjac, axjac, xeg, dnxi) +!! subroutine cal_jacobian_1d_3(numnod, numedge, nnod_4_edge, & +!! & ie_edge, xx, np_smp, iedge_smp_stack, & +!! & max_int_point, int_start1, ntot_int_1d, & +!! & xjac, axjac, xeg, dnxi) +!! +!! subroutine cal_jacobian_1d_2_3(numnod, numedge, nnod_4_edge, & +!! & ie_edge, xx, np_smp, iedge_smp_stack, & +!! & max_int_point, int_start1, ntot_int_1d, & +!! & xjac, axjac, xeg, dnxi) +!!@end verbatim +! + module cal_1edge_jacobians +! + use m_precision + use m_geometry_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_1d_2(numnod, numedge, nnod_4_edge, & + & ie_edge, xx, np_smp, iedge_smp_stack, & + & max_int_point, int_start1, ntot_int_1d, & + & xjac, axjac, xeg, dnxi) +! + use cal_jacobian_1d +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numedge, nnod_4_edge + integer(kind = kint), intent(in) & + & :: ie_edge(numedge, nnod_4_edge) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iedge_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start1(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_1d + real(kind = kreal), intent(in) & + & :: dnxi(num_linear_edge,ntot_int_1d) +! + real(kind = kreal), intent(inout) :: xjac(numedge,ntot_int_1d) + real(kind = kreal), intent(inout) :: axjac(numedge,ntot_int_1d) + real(kind = kreal), intent(inout) :: xeg(numedge,ntot_int_1d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0 + ix = int_start1(i0) + ii +! + call s_cal_jacobian_1d_2(numnod, numedge, ie_edge, xx, & + & np_smp, iedge_smp_stack, xjac(1,ix), axjac(1,ix), & + & xeg(1,ix,1), xeg(1,ix,2), xeg(1,ix,3), dnxi(1,ix)) + end do + end do +! + end subroutine cal_jacobian_1d_2 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_1d_3(numnod, numedge, nnod_4_edge, & + & ie_edge, xx, np_smp, iedge_smp_stack, & + & max_int_point, int_start1, ntot_int_1d, & + & xjac, axjac, xeg, dnxi) +! + use cal_jacobian_1d +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numedge, nnod_4_edge + integer(kind = kint), intent(in) & + & :: ie_edge(numedge, nnod_4_edge) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iedge_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start1(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_1d + real(kind = kreal), intent(in) & + & :: dnxi(num_quad_edge,ntot_int_1d) +! + real(kind = kreal), intent(inout) :: xjac(numedge,ntot_int_1d) + real(kind = kreal), intent(inout) :: axjac(numedge,ntot_int_1d) + real(kind = kreal), intent(inout) :: xeg(numedge,ntot_int_1d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0 + ix = int_start1(i0) + ii +! + call s_cal_jacobian_1d_3(numnod, numedge, ie_edge, xx, & + & np_smp, iedge_smp_stack, xjac(1,ix), axjac(1,ix), & + & xeg(1,ix,1), xeg(1,ix,2), xeg(1,ix,3), dnxi(1,ix)) + end do + end do +! + end subroutine cal_jacobian_1d_3 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_1d_2_3(numnod, numedge, nnod_4_edge, & + & ie_edge, xx, np_smp, iedge_smp_stack, & + & max_int_point, int_start1, ntot_int_1d, & + & xjac, axjac, xeg, dnxi) +! + use cal_jacobian_1d +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numedge, nnod_4_edge + integer(kind = kint), intent(in) & + & :: ie_edge(numedge, nnod_4_edge) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iedge_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start1(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_1d + real(kind = kreal), intent(in) & + & :: dnxi(num_quad_edge,ntot_int_1d) +! + real(kind = kreal), intent(inout) :: xjac(numedge,ntot_int_1d) + real(kind = kreal), intent(inout) :: axjac(numedge,ntot_int_1d) + real(kind = kreal), intent(inout) :: xeg(numedge,ntot_int_1d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0 + ix = int_start1(i0) + ii +! + call s_cal_jacobian_1d_2_3(numnod, numedge, ie_edge, xx, & + & np_smp, iedge_smp_stack, xjac(1,ix), axjac(1,ix), & + & xeg(1,ix,1), xeg(1,ix,2), xeg(1,ix,3), dnxi(1,ix)) + end do + end do +! + end subroutine cal_jacobian_1d_2_3 +! +!----------------------------------------------------------------------- +! + end module cal_1edge_jacobians diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_1ele_jacobians.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_1ele_jacobians.f90 new file mode 100644 index 00000000..d0d15186 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_1ele_jacobians.f90 @@ -0,0 +1,256 @@ +!>@file cal_1ele_jacobians.f90 +!! module cal_1ele_jacobians +!! +!!@author H. Matsui +!!@date Programmed on Dec., 2008 +!!@n Modified by H. Matsui on Aug., 2015 +! +!> @brief obtain jacobian at one gauss point for linear element +!! +!!@verbatim +!! subroutine cal_jacobian_3d_8 & +!! & (numnod, numele, nnod_4_ele, np_smp, iele_smp_stack, & +!! & ie, xx, max_int_point, int_start3, ntot_int_3d, & +!! & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi) +!! subroutine cal_jacobian_3d_20 & +!! & (numnod, numele, nnod_4_ele, np_smp, iele_smp_stack, & +!! & ie, xx, max_int_point, int_start3, ntot_int_3d, & +!! & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi) +!! subroutine cal_jacobian_3d_27 & +!! & (numnod, numele, nnod_4_ele, np_smp, iele_smp_stack, & +!! & ie, xx, max_int_point, int_start3, ntot_int_3d, & +!! & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi) +!! subroutine cal_jacobian_3d_8_20 & +!! & (numnod, numele, nnod_4_ele, np_smp, iele_smp_stack, & +!! & ie, xx, max_int_point, int_start3, ntot_int_3d, & +!! & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi) +!!@end verbatim +! + module cal_1ele_jacobians +! + use m_precision + use m_geometry_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_3d_8 & + & (numnod, numele, nnod_4_ele, np_smp, iele_smp_stack, & + & ie, xx, max_int_point, int_start3, ntot_int_3d, & + & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi) +! + use cal_jacobian_3d_linear +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iele_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start3(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_3d + real(kind = kreal), intent(in) :: dnxi(num_t_linear,ntot_int_3d) + real(kind = kreal), intent(in) :: dnei(num_t_linear,ntot_int_3d) + real(kind = kreal), intent(in) :: dnzi(num_t_linear,ntot_int_3d) +! + real(kind = kreal), intent(inout) & + & :: dxidx(numele,ntot_int_3d,3,3) +! + real(kind = kreal), intent(inout) :: xjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) :: axjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) & + & :: dnx(numele,num_t_linear,ntot_int_3d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0*i0 + ix = int_start3(i0) + ii +! + call s_cal_jacobian_3d_8 & + & (numnod, numele, np_smp, iele_smp_stack, & + & ie(1,1), xx, xjac(1,ix), axjac(1,ix), & + & dnx(1,1,ix,1), dnx(1,1,ix,2), dnx(1,1,ix,3), & + & dxidx(1,ix,1,1), dxidx(1,ix,2,1), dxidx(1,ix,3,1), & + & dxidx(1,ix,1,2), dxidx(1,ix,2,2), dxidx(1,ix,3,2), & + & dxidx(1,ix,1,3), dxidx(1,ix,2,3), dxidx(1,ix,3,3), & + & dnxi(1,ix), dnei(1,ix), dnzi(1,ix) ) + end do + end do +! + end subroutine cal_jacobian_3d_8 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_3d_20 & + & (numnod, numele, nnod_4_ele, np_smp, iele_smp_stack, & + & ie, xx, max_int_point, int_start3, ntot_int_3d, & + & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi) +! + use cal_jacobian_3d_quad +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iele_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start3(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_3d + real(kind = kreal), intent(in) :: dnxi(num_t_quad,ntot_int_3d) + real(kind = kreal), intent(in) :: dnei(num_t_quad,ntot_int_3d) + real(kind = kreal), intent(in) :: dnzi(num_t_quad,ntot_int_3d) +! + real(kind = kreal), intent(inout) & + & :: dxidx(numele,ntot_int_3d,3,3) +! + real(kind = kreal), intent(inout) :: xjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) :: axjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) & + & :: dnx(numele,num_t_quad,ntot_int_3d,3) +! +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0*i0 + ix = int_start3(i0) + ii +! + call s_cal_jacobian_3d_20 & + & (numnod, numele, np_smp, iele_smp_stack, & + & ie(1,1), xx, xjac(1,ix), axjac(1,ix), & + & dnx(1,1,ix,1), dnx(1,1,ix,2), dnx(1,1,ix,3), & + & dxidx(1,ix,1,1), dxidx(1,ix,2,1), dxidx(1,ix,3,1), & + & dxidx(1,ix,1,2), dxidx(1,ix,2,2), dxidx(1,ix,3,2), & + & dxidx(1,ix,1,3), dxidx(1,ix,2,3), dxidx(1,ix,3,3), & + & dnxi(1,ix), dnei(1,ix), dnzi(1,ix) ) + end do + end do +! + end subroutine cal_jacobian_3d_20 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_3d_27 & + & (numnod, numele, nnod_4_ele, np_smp, iele_smp_stack, & + & ie, xx, max_int_point, int_start3, ntot_int_3d, & + & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi) +! + use cal_jacobian_3d_lag +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iele_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start3(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_3d + real(kind = kreal), intent(in) :: dnxi(num_t_lag,ntot_int_3d) + real(kind = kreal), intent(in) :: dnei(num_t_lag,ntot_int_3d) + real(kind = kreal), intent(in) :: dnzi(num_t_lag,ntot_int_3d) +! + real(kind = kreal), intent(inout) & + & :: dxidx(numele,ntot_int_3d,3,3) +! + real(kind = kreal), intent(inout) :: xjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) :: axjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) & + & :: dnx(numele,num_t_lag,ntot_int_3d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0*i0 + ix = int_start3(i0) + ii +! + call s_cal_jacobian_3d_27 & + & (numnod, numele, np_smp, iele_smp_stack, & + & ie(1,1), xx, xjac(1,ix), axjac(1,ix), & + & dnx(1,1,ix,1), dnx(1,1,ix,2), dnx(1,1,ix,3), & + & dxidx(1,ix,1,1), dxidx(1,ix,2,1), dxidx(1,ix,3,1), & + & dxidx(1,ix,1,2), dxidx(1,ix,2,2), dxidx(1,ix,3,2), & + & dxidx(1,ix,1,3), dxidx(1,ix,2,3), dxidx(1,ix,3,3), & + & dnxi(1,ix), dnei(1,ix), dnzi(1,ix) ) + end do + end do +! + end subroutine cal_jacobian_3d_27 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_3d_8_20 & + & (numnod, numele, nnod_4_ele, np_smp, iele_smp_stack, & + & ie, xx, max_int_point, int_start3, ntot_int_3d, & + & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi) +! + use cal_jacobian_3d_linear_quad +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iele_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start3(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_3d + real(kind = kreal), intent(in) :: dnxi(num_t_quad,ntot_int_3d) + real(kind = kreal), intent(in) :: dnei(num_t_quad,ntot_int_3d) + real(kind = kreal), intent(in) :: dnzi(num_t_quad,ntot_int_3d) +! + real(kind = kreal), intent(inout) & + & :: dxidx(numele,ntot_int_3d,3,3) +! + real(kind = kreal), intent(inout) :: xjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) :: axjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) & + & :: dnx(numele,num_t_quad,ntot_int_3d,3) +! +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0*i0 + ix = int_start3(i0) + ii +! + call s_cal_jacobian_3d_8_20 & + & (numnod, numele, np_smp, iele_smp_stack, & + & ie(1,1), xx, xjac(1,ix), axjac(1,ix), & + & dnx(1,1,ix,1), dnx(1,1,ix,2), dnx(1,1,ix,3), & + & dxidx(1,ix,1,1), dxidx(1,ix,2,1), dxidx(1,ix,3,1), & + & dxidx(1,ix,1,2), dxidx(1,ix,2,2), dxidx(1,ix,3,2), & + & dxidx(1,ix,1,3), dxidx(1,ix,2,3), dxidx(1,ix,3,3), & + & dnxi(1,ix), dnei(1,ix), dnzi(1,ix) ) + end do + end do +! + end subroutine cal_jacobian_3d_8_20 +! +!----------------------------------------------------------------------- +! + end module cal_1ele_jacobians diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_1ele_jacobians_infinte.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_1ele_jacobians_infinte.f90 new file mode 100644 index 00000000..0ddfb026 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_1ele_jacobians_infinte.f90 @@ -0,0 +1,334 @@ +!>@file cal_1ele_jacobians_infinte.f90 +!! module cal_1ele_jacobians_infinte +!! +!!@author H. Matsui +!!@date Programmed on Dec., 2008 +!!@n Modified by H. Matsui on Aug., 2015 +! +!> @brief obtain jacobian at one gauss point for infity element +!! +!!@verbatim +!! subroutine cal_jacobian_3d_inf_8(numnod, numele, nnod_4_ele, & +!! & np_smp, ie, xx, num_surf_bc, surf_item, ngrp_sf_infty,& +!! & id_grp_sf_infty, num_surf_smp, isurf_grp_smp_stack, & +!! & max_int_point, int_start3, ntot_int_3d, & +!! & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi, & +!! & dnxi_inf, dnei_inf, dnzi_inf) +!! subroutine cal_jacobian_3d_inf_20(numnod, numele, nnod_4_ele, & +!! & np_smp, ie, xx, num_surf_bc, surf_item, ngrp_sf_infty,& +!! & id_grp_sf_infty, num_surf_smp, isurf_grp_smp_stack, & +!! & max_int_point, int_start3, ntot_int_3d, & +!! & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi, & +!! & dnxi_inf, dnei_inf, dnzi_inf) +!! subroutine cal_jacobian_3d_inf_27(numnod, numele, nnod_4_ele, & +!! & np_smp, ie, xx, num_surf_bc, surf_item, ngrp_sf_infty,& +!! & id_grp_sf_infty, num_surf_smp, isurf_grp_smp_stack, & +!! & max_int_point, int_start3, ntot_int_3d, & +!! & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi, & +!! & dnxi_inf, dnei_inf, dnzi_inf) +!! +!! subroutine cal_jacobian_3d_inf_8_20(numnod, numele, nnod_4_ele, & +!! & np_smp, ie, xx, num_surf_bc, surf_item, ngrp_sf_infty,& +!! & id_grp_sf_infty, num_surf_smp, isurf_grp_smp_stack, & +!! & max_int_point, int_start3, ntot_int_3d, & +!! & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi, & +!! & dnxi_inf, dnei_inf, dnzi_inf) +!!@end verbatim +! + module cal_1ele_jacobians_infinte +! + use m_precision + use m_machine_parameter + use m_geometry_constants +! + use cal_shape_func_infty_3d +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_3d_inf_8(numnod, numele, nnod_4_ele, & + & np_smp, ie, xx, num_surf_bc, surf_item, ngrp_sf_infty, & + & id_grp_sf_infty, num_surf_smp, isurf_grp_smp_stack, & + & max_int_point, int_start3, ntot_int_3d, & + & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi, & + & dnxi_inf, dnei_inf, dnzi_inf) +! + use cal_jacobian_3d_inf_linear +! + integer(kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer (kind=kint), intent(in) :: ngrp_sf_infty + integer (kind=kint), intent(in) :: id_grp_sf_infty(ngrp_sf_infty) +! + integer(kind = kint), intent(in) :: np_smp, num_surf_smp + integer(kind = kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start3(max_int_point) +! + integer (kind=kint), intent(in) :: ntot_int_3d + real(kind = kreal), intent(in) :: dnxi(num_t_linear,ntot_int_3d) + real(kind = kreal), intent(in) :: dnei(num_t_linear,ntot_int_3d) + real(kind = kreal), intent(in) :: dnzi(num_t_linear,ntot_int_3d) +! + real(kind = kreal), intent(in) & + & :: dnxi_inf(num_t_linear,nsurf_4_ele,ntot_int_3d) + real(kind = kreal), intent(in) & + & :: dnei_inf(num_t_linear,nsurf_4_ele,ntot_int_3d) + real(kind = kreal), intent(in) & + & :: dnzi_inf(num_t_linear,nsurf_4_ele,ntot_int_3d) +! + real(kind = kreal), intent(inout) :: dxidx(numele,ntot_int_3d,3,3) +! + real(kind = kreal), intent(inout) :: xjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) :: axjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) & + & :: dnx(numele,num_t_linear,ntot_int_3d,3) +! + integer (kind=kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0*i0 + ix = int_start3(i0) + ii +! + call s_cal_jacobian_3d_inf_8 & + & (numnod, numele, np_smp, ie, xx, num_surf_bc, surf_item, & + & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & + & isurf_grp_smp_stack, xjac(1,ix), axjac(1,ix), & + & dnx(1,1,ix,1), dnx(1,1,ix,2), dnx(1,1,ix,3), & + & dxidx(1,ix,1,1), dxidx(1,ix,2,1), dxidx(1,ix,3,1), & + & dxidx(1,ix,1,2), dxidx(1,ix,2,2), dxidx(1,ix,3,2), & + & dxidx(1,ix,1,3), dxidx(1,ix,2,3), dxidx(1,ix,3,3), & + & dnxi(1,ix), dnei(1,ix), dnzi(1,ix), & + & dnxi_inf(1,1,ix), dnei_inf(1,1,ix), dnzi_inf(1,1,ix)) + end do + end do +! +! + end subroutine cal_jacobian_3d_inf_8 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_3d_inf_20(numnod, numele, nnod_4_ele, & + & np_smp, ie, xx, num_surf_bc, surf_item, ngrp_sf_infty, & + & id_grp_sf_infty, num_surf_smp, isurf_grp_smp_stack, & + & max_int_point, int_start3, ntot_int_3d, & + & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi, & + & dnxi_inf, dnei_inf, dnzi_inf) +! + use cal_jacobian_3d_inf_quad +! + integer(kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer (kind=kint), intent(in) :: ngrp_sf_infty + integer (kind=kint), intent(in) :: id_grp_sf_infty(ngrp_sf_infty) +! + integer(kind = kint), intent(in) :: np_smp, num_surf_smp + integer(kind = kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start3(max_int_point) +! + integer (kind=kint), intent(in) :: ntot_int_3d + real(kind = kreal), intent(in) :: dnxi(num_t_quad,ntot_int_3d) + real(kind = kreal), intent(in) :: dnei(num_t_quad,ntot_int_3d) + real(kind = kreal), intent(in) :: dnzi(num_t_quad,ntot_int_3d) +! + real(kind = kreal), intent(in) & + & :: dnxi_inf(num_t_quad,nsurf_4_ele,ntot_int_3d) + real(kind = kreal), intent(in) & + & :: dnei_inf(num_t_quad,nsurf_4_ele,ntot_int_3d) + real(kind = kreal), intent(in) & + & :: dnzi_inf(num_t_quad,nsurf_4_ele,ntot_int_3d) +! + real(kind = kreal), intent(inout) :: dxidx(numele,ntot_int_3d,3,3) +! + real(kind = kreal), intent(inout) :: xjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) :: axjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) & + & :: dnx(numele,num_t_quad,ntot_int_3d,3) +! + integer (kind=kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0*i0 + ix = int_start3(i0) + ii +! + call s_cal_jacobian_3d_inf_20 & + & (numnod, numele, np_smp, ie, xx, num_surf_bc, surf_item, & + & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & + & isurf_grp_smp_stack, xjac(1,ix), axjac(1,ix), & + & dnx(1,1,ix,1), dnx(1,1,ix,2), dnx(1,1,ix,3), & + & dxidx(1,ix,1,1), dxidx(1,ix,2,1), dxidx(1,ix,3,1), & + & dxidx(1,ix,1,2), dxidx(1,ix,2,2), dxidx(1,ix,3,2), & + & dxidx(1,ix,1,3), dxidx(1,ix,2,3), dxidx(1,ix,3,3), & + & dnxi(1,ix), dnei(1,ix), dnzi(1,ix), & + & dnxi_inf(1,1,ix), dnei_inf(1,1,ix), dnzi_inf(1,1,ix)) + end do + end do +! +! + end subroutine cal_jacobian_3d_inf_20 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_3d_inf_27(numnod, numele, nnod_4_ele, & + & np_smp, ie, xx, num_surf_bc, surf_item, ngrp_sf_infty, & + & id_grp_sf_infty, num_surf_smp, isurf_grp_smp_stack, & + & max_int_point, int_start3, ntot_int_3d, & + & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi, & + & dnxi_inf, dnei_inf, dnzi_inf) +! + use cal_jacobian_3d_inf_lag +! + integer(kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer (kind=kint), intent(in) :: ngrp_sf_infty + integer (kind=kint), intent(in) :: id_grp_sf_infty(ngrp_sf_infty) +! + integer(kind = kint), intent(in) :: np_smp, num_surf_smp + integer(kind = kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start3(max_int_point) +! + integer (kind=kint), intent(in) :: ntot_int_3d + real(kind = kreal), intent(in) :: dnxi(num_t_lag,ntot_int_3d) + real(kind = kreal), intent(in) :: dnei(num_t_lag,ntot_int_3d) + real(kind = kreal), intent(in) :: dnzi(num_t_lag,ntot_int_3d) +! + real(kind = kreal), intent(in) & + & :: dnxi_inf(num_t_lag,nsurf_4_ele,ntot_int_3d) + real(kind = kreal), intent(in) & + & :: dnei_inf(num_t_lag,nsurf_4_ele,ntot_int_3d) + real(kind = kreal), intent(in) & + & :: dnzi_inf(num_t_lag,nsurf_4_ele,ntot_int_3d) +! + real(kind = kreal), intent(inout) :: dxidx(numele,ntot_int_3d,3,3) +! + real(kind = kreal), intent(inout) :: xjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) :: axjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) & + & :: dnx(numele,num_t_lag,ntot_int_3d,3) +! + integer (kind=kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0*i0 + ix = int_start3(i0) + ii +! + call s_cal_jacobian_3d_inf_27 & + & (numnod, numele, np_smp, ie, xx, num_surf_bc, surf_item, & + & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & + & isurf_grp_smp_stack, xjac(1,ix), axjac(1,ix), & + & dnx(1,1,ix,1), dnx(1,1,ix,2), dnx(1,1,ix,3), & + & dxidx(1,ix,1,1), dxidx(1,ix,2,1), dxidx(1,ix,3,1), & + & dxidx(1,ix,1,2), dxidx(1,ix,2,2), dxidx(1,ix,3,2), & + & dxidx(1,ix,1,3), dxidx(1,ix,2,3), dxidx(1,ix,3,3), & + & dnxi(1,ix), dnei(1,ix), dnzi(1,ix), & + & dnxi_inf(1,1,ix), dnei_inf(1,1,ix), dnzi_inf(1,1,ix)) + end do + end do +! +! + end subroutine cal_jacobian_3d_inf_27 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_3d_inf_8_20(numnod, numele, nnod_4_ele, & + & np_smp, ie, xx, num_surf_bc, surf_item, ngrp_sf_infty, & + & id_grp_sf_infty, num_surf_smp, isurf_grp_smp_stack, & + & max_int_point, int_start3, ntot_int_3d, & + & xjac, axjac, dnx, dxidx, dnxi, dnei, dnzi, & + & dnxi_inf, dnei_inf, dnzi_inf) +! + use cal_jacobian_3d_inf_l_quad +! + integer(kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer (kind=kint), intent(in) :: ngrp_sf_infty + integer (kind=kint), intent(in) :: id_grp_sf_infty(ngrp_sf_infty) +! + integer(kind = kint), intent(in) :: np_smp, num_surf_smp + integer(kind = kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start3(max_int_point) +! + integer (kind=kint), intent(in) :: ntot_int_3d + real(kind = kreal), intent(in) :: dnxi(num_t_quad,ntot_int_3d) + real(kind = kreal), intent(in) :: dnei(num_t_quad,ntot_int_3d) + real(kind = kreal), intent(in) :: dnzi(num_t_quad,ntot_int_3d) +! + real(kind = kreal), intent(in) & + & :: dnxi_inf(num_t_quad,nsurf_4_ele,ntot_int_3d) + real(kind = kreal), intent(in) & + & :: dnei_inf(num_t_quad,nsurf_4_ele,ntot_int_3d) + real(kind = kreal), intent(in) & + & :: dnzi_inf(num_t_quad,nsurf_4_ele,ntot_int_3d) +! + real(kind = kreal), intent(inout) :: dxidx(numele,ntot_int_3d,3,3) +! + real(kind = kreal), intent(inout) :: xjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) :: axjac(numele,ntot_int_3d) + real(kind = kreal), intent(inout) & + & :: dnx(numele,num_t_quad,ntot_int_3d,3) +! + integer (kind=kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0*i0 + ix = int_start3(i0) + ii +! + call s_cal_jacobian_3d_inf_8_20 & + & (numnod, numele, np_smp, ie, xx, num_surf_bc, surf_item, & + & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & + & isurf_grp_smp_stack, xjac(1,ix), axjac(1,ix), & + & dnx(1,1,ix,1), dnx(1,1,ix,2), dnx(1,1,ix,3), & + & dxidx(1,ix,1,1), dxidx(1,ix,2,1), dxidx(1,ix,3,1), & + & dxidx(1,ix,1,2), dxidx(1,ix,2,2), dxidx(1,ix,3,2), & + & dxidx(1,ix,1,3), dxidx(1,ix,2,3), dxidx(1,ix,3,3), & + & dnxi(1,ix), dnei(1,ix), dnzi(1,ix), & + & dnxi_inf(1,1,ix), dnei_inf(1,1,ix), dnzi_inf(1,1,ix)) + end do + end do +! +! + end subroutine cal_jacobian_3d_inf_8_20 +! +!----------------------------------------------------------------------- +! + end module cal_1ele_jacobians_infinte diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_1surf_grp_jacobians.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_1surf_grp_jacobians.f90 new file mode 100644 index 00000000..c8c90362 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_1surf_grp_jacobians.f90 @@ -0,0 +1,267 @@ +!>@file cal_1surf_grp_jacobians.f90 +!! module cal_1surf_grp_jacobians +!! +!!@author H. Matsui +!!@date Programmed on Dec., 2008 +!!@n Modified by H. Matsui on Aug., 2015 +! +!> @brief obtain jacobian at one gauss point for linear element +!! +!!@verbatim +!! subroutine cal_jacobian_sf_grp_4(numnod, numele, nnod_4_ele, & +!! & ie, xx, num_surf, num_surf_bc, surf_item, & +!! & np_smp, num_surf_smp, isurf_grp_smp_stack, & +!! & max_int_point, int_start2, ntot_int_2d, & +!! & xjac, axjac, xsf, dnxi, dnei) +!! subroutine cal_jacobian_sf_grp_8(numnod, numele, nnod_4_ele, & +!! & ie, xx, num_surf, num_surf_bc, surf_item, & +!! & np_smp, num_surf_smp, isurf_grp_smp_stack, & +!! & max_int_point, int_start2, ntot_int_2d, & +!! & xjac, axjac, xsf, dnxi, dnei) +!! subroutine cal_jacobian_sf_grp_9(numnod, numele, nnod_4_ele, & +!! & ie, xx, num_surf, num_surf_bc, surf_item, & +!! & np_smp, num_surf_smp, isurf_grp_smp_stack, & +!! & max_int_point, int_start2, ntot_int_2d, & +!! & xjac, axjac, xsf, dnxi, dnei) +!! +!! subroutine cal_jacobian_sf_grp_4_8(numnod, numele, nnod_4_ele, & +!! & ie, xx, num_surf, num_surf_bc, surf_item, & +!! & np_smp, num_surf_smp, isurf_grp_smp_stack, & +!! & max_int_point, int_start2, ntot_int_2d, & +!! & xjac, axjac, xsf, dnxi, dnei) +!!@end verbatim +! + module cal_1surf_grp_jacobians +! + use m_precision + use m_geometry_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_sf_grp_4(numnod, numele, nnod_4_ele, & + & ie, xx, num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & max_int_point, int_start2, ntot_int_2d, & + & xjac, axjac, xsf, dnxi, dnei) +! + use cal_jacobian_sf_grp_linear +! + integer(kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: np_smp + integer (kind=kint), intent(in) :: num_surf_smp + integer (kind=kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer (kind=kint), intent(in) :: num_surf + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start2(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_2d + real(kind = kreal), intent(in) :: dnxi(num_linear_sf,ntot_int_2d) + real(kind = kreal), intent(in) :: dnei(num_linear_sf,ntot_int_2d) +! + real(kind = kreal), intent(inout) & + & :: xjac(num_surf_bc,ntot_int_2d) + real(kind = kreal), intent(inout) & + & :: axjac(num_surf_bc,ntot_int_2d) + real(kind = kreal), intent(inout) & + & :: xsf(num_surf_bc,ntot_int_2d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0 + ix = int_start2(i0) + ii +! + call s_cal_jacobian_sf_grp_4(numnod, numele, ie, xx, & + & num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & xjac(1,ix), axjac(1,ix), & + & xsf(1,ix,1), xsf(1,ix,2), xsf(1,ix,3), & + & dnxi(1,ix), dnei(1,ix) ) + end do + end do +! + end subroutine cal_jacobian_sf_grp_4 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_sf_grp_8(numnod, numele, nnod_4_ele, & + & ie, xx, num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & max_int_point, int_start2, ntot_int_2d, & + & xjac, axjac, xsf, dnxi, dnei) +! + use cal_jacobian_sf_grp_quad +! + integer(kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: np_smp + integer (kind=kint), intent(in) :: num_surf_smp + integer (kind=kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer (kind=kint), intent(in) :: num_surf + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start2(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_2d + real(kind = kreal), intent(in) :: dnxi(num_t_quad,ntot_int_2d) + real(kind = kreal), intent(in) :: dnei(num_t_quad,ntot_int_2d) +! + real(kind = kreal), intent(inout) & + & :: xjac(num_surf_bc,ntot_int_2d) + real(kind = kreal), intent(inout) & + & :: axjac(num_surf_bc,ntot_int_2d) + real(kind = kreal), intent(inout) & + & :: xsf(num_surf_bc,ntot_int_2d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0 + ix = int_start2(i0) + ii +! + call s_cal_jacobian_sf_grp_8(numnod, numele, ie, xx, & + & num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & xjac(1,ix), axjac(1,ix), & + & xsf(1,ix,1), xsf(1,ix,2), xsf(1,ix,3), & + & dnxi(1,ix), dnei(1,ix) ) + end do + end do +! + end subroutine cal_jacobian_sf_grp_8 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_sf_grp_9(numnod, numele, nnod_4_ele, & + & ie, xx, num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & max_int_point, int_start2, ntot_int_2d, & + & xjac, axjac, xsf, dnxi, dnei) +! + use cal_jacobian_sf_grp_lag +! + integer(kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: np_smp + integer (kind=kint), intent(in) :: num_surf_smp + integer (kind=kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer (kind=kint), intent(in) :: num_surf + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start2(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_2d + real(kind = kreal), intent(in) :: dnxi(num_lag_sf,ntot_int_2d) + real(kind = kreal), intent(in) :: dnei(num_lag_sf,ntot_int_2d) +! + real(kind = kreal), intent(inout) & + & :: xjac(num_surf_bc,ntot_int_2d) + real(kind = kreal), intent(inout) & + & :: axjac(num_surf_bc,ntot_int_2d) + real(kind = kreal), intent(inout) & + & :: xsf(num_surf_bc,ntot_int_2d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0 + ix = int_start2(i0) + ii +! + call s_cal_jacobian_sf_grp_9(numnod, numele, ie, xx, & + & num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & xjac(1,ix), axjac(1,ix), & + & xsf(1,ix,1), xsf(1,ix,2), xsf(1,ix,3), & + & dnxi(1,ix), dnei(1,ix) ) + end do + end do +! + end subroutine cal_jacobian_sf_grp_9 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_sf_grp_4_8(numnod, numele, nnod_4_ele, & + & ie, xx, num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & max_int_point, int_start2, ntot_int_2d, & + & xjac, axjac, xsf, dnxi, dnei) +! + use cal_jacobian_sf_grp_l_quad +! + integer(kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer(kind = kint), intent(in) :: ie(numele, nnod_4_ele) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: np_smp + integer (kind=kint), intent(in) :: num_surf_smp + integer (kind=kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer (kind=kint), intent(in) :: num_surf + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start2(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_2d + real(kind = kreal), intent(in) :: dnxi(num_quad_sf,ntot_int_2d) + real(kind = kreal), intent(in) :: dnei(num_quad_sf,ntot_int_2d) +! + real(kind = kreal), intent(inout) & + & :: xjac(num_surf_bc,ntot_int_2d) + real(kind = kreal), intent(inout) & + & :: axjac(num_surf_bc,ntot_int_2d) + real(kind = kreal), intent(inout) & + & :: xsf(num_surf_bc,ntot_int_2d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0 + ix = int_start2(i0) + ii +! + call s_cal_jacobian_sf_grp_4_8(numnod, numele, ie, xx, & + & num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & xjac(1,ix), axjac(1,ix), & + & xsf(1,ix,1), xsf(1,ix,2), xsf(1,ix,3), & + & dnxi(1,ix), dnei(1,ix) ) + end do + end do +! + end subroutine cal_jacobian_sf_grp_4_8 +! +!----------------------------------------------------------------------- +! + end module cal_1surf_grp_jacobians diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_1surf_jacobians.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_1surf_jacobians.f90 new file mode 100644 index 00000000..dafe8cd4 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_1surf_jacobians.f90 @@ -0,0 +1,218 @@ +!>@file cal_1surf_jacobians.f90 +!! module cal_1surf_jacobians +!! +!!@author H. Matsui +!!@date Programmed on Dec., 2008 +!!@n Modified by H. Matsui on Aug., 2015 +! +!> @brief obtain jacobian at one gauss point for linear element +!! +!!@verbatim +!! subroutine cal_jacobian_2d_4(numnod, numsurf, nnod_4_surf, & +!! & ie_surf, xx, np_smp, isurf_smp_stack, & +!! & max_int_point, int_start2, ntot_int_2d, & +!! & xjac, axjac, xsf, dnxi, dnei) +!! subroutine cal_jacobian_2d_8(numnod, numsurf, nnod_4_surf, & +!! & ie_surf, xx, np_smp, isurf_smp_stack, & +!! & max_int_point, int_start2, ntot_int_2d, & +!! & xjac, axjac, xsf, dnxi, dnei) +!! subroutine cal_jacobian_2d_9(numnod, numsurf, nnod_4_surf, & +!! & ie_surf, xx, np_smp, isurf_smp_stack, & +!! & max_int_point, int_start2, ntot_int_2d, & +!! & xjac, axjac, xsf, dnxi, dnei) +!! subroutine cal_jacobian_2d_4_8(numnod, numsurf, nnod_4_surf, & +!! & ie_surf, xx, np_smp, isurf_smp_stack, & +!! & max_int_point, int_start2, ntot_int_2d, & +!! & xjac, axjac, xsf, dnxi, dnei) +!!@end verbatim +! + module cal_1surf_jacobians +! + use m_precision + use m_geometry_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_2d_4(numnod, numsurf, nnod_4_surf, & + & ie_surf, xx, np_smp, isurf_smp_stack, & + & max_int_point, int_start2, ntot_int_2d, & + & xjac, axjac, xsf, dnxi, dnei) +! + use cal_jacobian_2d_linear +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numsurf, nnod_4_surf + integer(kind = kint), intent(in) :: ie_surf(numsurf,nnod_4_surf) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: isurf_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start2(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_2d + real(kind = kreal), intent(in) :: dnxi(num_linear_sf,ntot_int_2d) + real(kind = kreal), intent(in) :: dnei(num_linear_sf,ntot_int_2d) +! + real(kind = kreal), intent(inout) :: xjac(numsurf,ntot_int_2d) + real(kind = kreal), intent(inout) :: axjac(numsurf,ntot_int_2d) + real(kind = kreal), intent(inout) :: xsf(numsurf,ntot_int_2d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0 + ix = int_start2(i0) + ii +! + call s_cal_jacobian_2d_4(numnod, numsurf, ie_surf, xx, & + & np_smp, isurf_smp_stack, xjac(1,ix), axjac(1,ix), & + & xsf(1,ix,1), xsf(1,ix,2), xsf(1,ix,3), & + & dnxi(1,ix), dnei(1,ix)) + end do + end do +! + end subroutine cal_jacobian_2d_4 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_2d_8(numnod, numsurf, nnod_4_surf, & + & ie_surf, xx, np_smp, isurf_smp_stack, & + & max_int_point, int_start2, ntot_int_2d, & + & xjac, axjac, xsf, dnxi, dnei) +! + use cal_jacobian_2d_quad +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numsurf, nnod_4_surf + integer(kind = kint), intent(in) :: ie_surf(numsurf,nnod_4_surf) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: isurf_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start2(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_2d + real(kind = kreal), intent(in) :: dnxi(num_quad_sf,ntot_int_2d) + real(kind = kreal), intent(in) :: dnei(num_quad_sf,ntot_int_2d) +! + real(kind = kreal), intent(inout) :: xjac(numsurf,ntot_int_2d) + real(kind = kreal), intent(inout) :: axjac(numsurf,ntot_int_2d) + real(kind = kreal), intent(inout) :: xsf(numsurf,ntot_int_2d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0 + ix = int_start2(i0) + ii +! + call s_cal_jacobian_2d_8(numnod, numsurf, ie_surf, xx, & + & np_smp, isurf_smp_stack, xjac(1,ix), axjac(1,ix), & + & xsf(1,ix,1), xsf(1,ix,2), xsf(1,ix,3), & + & dnxi(1,ix), dnei(1,ix)) + end do + end do +! + end subroutine cal_jacobian_2d_8 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_2d_9(numnod, numsurf, nnod_4_surf, & + & ie_surf, xx, np_smp, isurf_smp_stack, & + & max_int_point, int_start2, ntot_int_2d, & + & xjac, axjac, xsf, dnxi, dnei) +! + use cal_jacobian_2d_lag +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numsurf, nnod_4_surf + integer(kind = kint), intent(in) :: ie_surf(numsurf,nnod_4_surf) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: isurf_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start2(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_2d + real(kind = kreal), intent(in) :: dnxi(num_lag_sf,ntot_int_2d) + real(kind = kreal), intent(in) :: dnei(num_lag_sf,ntot_int_2d) +! + real(kind = kreal), intent(inout) :: xjac(numsurf,ntot_int_2d) + real(kind = kreal), intent(inout) :: axjac(numsurf,ntot_int_2d) + real(kind = kreal), intent(inout) :: xsf(numsurf,ntot_int_2d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0 + ix = int_start2(i0) + ii +! + call s_cal_jacobian_2d_9(numnod, numsurf, ie_surf, xx, & + & np_smp, isurf_smp_stack, xjac(1,ix), axjac(1,ix), & + & xsf(1,ix,1), xsf(1,ix,2), xsf(1,ix,3), & + & dnxi(1,ix), dnei(1,ix)) + end do + end do +! + end subroutine cal_jacobian_2d_9 +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_2d_4_8(numnod, numsurf, nnod_4_surf, & + & ie_surf, xx, np_smp, isurf_smp_stack, & + & max_int_point, int_start2, ntot_int_2d, & + & xjac, axjac, xsf, dnxi, dnei) +! + use cal_jacobian_2d_linear_quad +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numsurf, nnod_4_surf + integer(kind = kint), intent(in) :: ie_surf(numsurf,nnod_4_surf) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: isurf_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(in) :: int_start2(max_int_point) +! + integer(kind = kint), intent(in) :: ntot_int_2d + real(kind = kreal), intent(in) :: dnxi(num_lag_sf,ntot_int_2d) + real(kind = kreal), intent(in) :: dnei(num_lag_sf,ntot_int_2d) +! + real(kind = kreal), intent(inout) :: xjac(numsurf,ntot_int_2d) + real(kind = kreal), intent(inout) :: axjac(numsurf,ntot_int_2d) + real(kind = kreal), intent(inout) :: xsf(numsurf,ntot_int_2d,3) +! + integer (kind = kint) :: ii, ix, i0 +! +! + do i0 = 1, max_int_point + do ii = 1, i0*i0 + ix = int_start2(i0) + ii +! + call s_cal_jacobian_2d_4_8(numnod, numsurf, ie_surf, xx, & + & np_smp, isurf_smp_stack, xjac(1,ix), axjac(1,ix), & + & xsf(1,ix,1), xsf(1,ix,2), xsf(1,ix,3), & + & dnxi(1,ix), dnei(1,ix)) + end do + end do +! + end subroutine cal_jacobian_2d_4_8 +! +!----------------------------------------------------------------------- +! + end module cal_1surf_jacobians diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_gradient_on_element.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_gradient_on_element.f90 new file mode 100644 index 00000000..7879babd --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_gradient_on_element.f90 @@ -0,0 +1,179 @@ +! +! module cal_gradient_on_element +! +! Written by H. Matsui on Nov., 2006 +! +!! subroutine fem_gradient_on_element(iele_fsmp_stack, & +!! & numnod, numele, nnod_4_ele, ie, a_vol_ele, & +!! & max_int_point, maxtot_int_3d, int_start3, owe3d, & +!! & ntot_int_3d, n_int, dnx, xjac, d_ele, d_nod) +!! subroutine fem_gradient_grp_on_element & +!! & (iele_fsmp_stack, numnod, numele, nnod_4_ele, ie, & +!! & a_vol_ele, nele_grp, iele_grp, & +!! & max_int_point, maxtot_int_3d, int_start3, owe3d, & +!! & ntot_int_3d, n_int, dnx, xjac, d_ele, d_nod) +! + module cal_gradient_on_element +! + use m_precision +! + use m_constants + use m_machine_parameter +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine fem_gradient_on_element(iele_fsmp_stack, & + & numnod, numele, nnod_4_ele, ie, a_vol_ele, & + & max_int_point, maxtot_int_3d, int_start3, owe3d, & + & ntot_int_3d, n_int, dnx, xjac, d_ele, d_nod) +! + integer (kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer (kind = kint), intent(in) :: iele_fsmp_stack(0:np_smp) + integer (kind = kint), intent(in) :: ie(numele,nnod_4_ele) + real(kind = kreal), intent(in) :: a_vol_ele(numele) +! + integer(kind = kint), intent(in) :: max_int_point, maxtot_int_3d + integer(kind = kint), intent(in) :: int_start3(max_int_point) + real(kind = kreal), intent(in) :: owe3d(maxtot_int_3d) +! + integer (kind = kint), intent(in) :: ntot_int_3d, n_int + real(kind=kreal), intent(in) & + & :: dnx(numele,nnod_4_ele,ntot_int_3d,3) + real(kind=kreal), intent(in) :: xjac(numele,ntot_int_3d) +! + real(kind = kreal), intent(in) :: d_nod(numnod) +! + real(kind = kreal), intent(inout) :: d_ele(numele,3) +! + integer (kind = kint) :: ip, inod, iele + integer (kind = kint) :: k1, ii, ix + integer (kind = kint) :: ist, ied +! +! --------- lead gradient in a element +! +!$omp parallel do private(ip,k1,ii,ix,iele,ist,ied,inod) + do ip = 1, np_smp + ist = iele_fsmp_stack(ip-1)+1 + ied = iele_fsmp_stack(ip) +! + d_ele(ist:ied,1) = zero + d_ele(ist:ied,2) = zero + d_ele(ist:ied,3) = zero +! + do k1 = 1, nnod_4_ele + do ii= 1, n_int * n_int * n_int + ix = int_start3(n_int) + ii +! +!cdir nodep + do iele = ist, ied + inod = ie(iele,k1) +! + d_ele(iele,1) = d_ele(iele,1) & + & + dnx(iele,k1,ix,1) * d_nod(inod) & + & * xjac(iele,ix) * owe3d(ix) & + & * a_vol_ele(iele) +! + d_ele(iele,2) = d_ele(iele,2) & + & + dnx(iele,k1,ix,2) * d_nod(inod) & + & * xjac(iele,ix) * owe3d(ix) & + & * a_vol_ele(iele) +! + d_ele(iele,3) = d_ele(iele,3) & + & + dnx(iele,k1,ix,3) * d_nod(inod) & + & * xjac(iele,ix) * owe3d(ix) & + & * a_vol_ele(iele) +! + end do + end do +! + end do + end do +!$omp end parallel do +! + end subroutine fem_gradient_on_element +! +! ---------------------------------------------------------------------- +! + subroutine fem_gradient_grp_on_element & + & (iele_fsmp_stack, numnod, numele, nnod_4_ele, ie, & + & a_vol_ele, nele_grp, iele_grp, & + & max_int_point, maxtot_int_3d, int_start3, owe3d, & + & ntot_int_3d, n_int, dnx, xjac, d_ele, d_nod) +! + integer (kind = kint), intent(in) :: numnod, numele, nnod_4_ele + integer (kind = kint), intent(in) :: iele_fsmp_stack(0:np_smp) + integer (kind = kint), intent(in) :: ie(numele,nnod_4_ele) + real(kind = kreal), intent(in) :: a_vol_ele(numele) +! + integer (kind = kint), intent(in) :: nele_grp + integer (kind = kint), intent(in) :: iele_grp(nele_grp) +! + integer(kind = kint), intent(in) :: max_int_point, maxtot_int_3d + integer(kind = kint), intent(in) :: int_start3(max_int_point) + real(kind = kreal), intent(in) :: owe3d(maxtot_int_3d) +! + integer (kind = kint), intent(in) :: ntot_int_3d, n_int + real(kind=kreal), intent(in) & + & :: dnx(numele,nnod_4_ele,ntot_int_3d,3) + real(kind=kreal), intent(in) :: xjac(numele,ntot_int_3d) +! + real(kind = kreal), intent(in) :: d_nod(numnod) +! + real(kind = kreal), intent(inout) :: d_ele(numele,3) +! + integer (kind = kint) :: ip, inod, inum, iele + integer (kind = kint) :: k1, ii, ix + integer (kind = kint) :: ist, ied +! +! --------- lead gradient in a element +! +!$omp parallel do private(ip,k1,ii,ix,inum,iele,ist,ied,inod) + do ip = 1, np_smp + ist = iele_fsmp_stack(ip-1)+1 + ied = iele_fsmp_stack(ip) + d_ele(ist:ied,1) = zero + d_ele(ist:ied,2) = zero + d_ele(ist:ied,3) = zero +! + do k1 = 1, nnod_4_ele + do ii= 1, n_int * n_int * n_int + ix = int_start3(n_int) + ii +! +!cdir nodep + do inum = ist, ied + iele = iele_grp(inum) + inod = ie(iele,k1) +! + d_ele(iele,1) = d_ele(iele,1) & + & + dnx(iele,k1,ix,1) * d_nod(inod) & + & * xjac(iele,ix) * owe3d(ix) & + & * a_vol_ele(iele) +! + d_ele(iele,2) = d_ele(iele,2) & + & + dnx(iele,k1,ix,2) * d_nod(inod) & + & * xjac(iele,ix) * owe3d(ix) & + & * a_vol_ele(iele) +! + d_ele(iele,3) = d_ele(iele,3) & + & + dnx(iele,k1,ix,3) * d_nod(inod) & + & * xjac(iele,ix) * owe3d(ix) & + & * a_vol_ele(iele) +! + end do + end do +! + end do + end do +!$omp end parallel do +! + end subroutine fem_gradient_grp_on_element +! +! ---------------------------------------------------------------------- +! + end module cal_gradient_on_element diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_1d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_1d.f90 new file mode 100644 index 00000000..7a9b629c --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_1d.f90 @@ -0,0 +1,359 @@ +! +! module cal_jacobian_1d +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_1d_2(numnod, numedge, & +! & ie_edge, xx, np_smp, iedge_smp_stack, xjac, axjac, & +! & xeg, yeg, zeg, dnxi) +! subroutine s_cal_jacobian_1d_3(numnod, numedge, nnod_4_edge, & +! & ie_edge, xx, np_smp, iedge_smp_stack, xjac, axjac, & +! & xeg, yeg, zeg, dnxi) +! subroutine s_cal_jacobian_1d_2_3(numnod, numedge, nnod_4_edge, & +! & ie_edge, xx, np_smp, iedge_smp_stack, xjac, axjac, & +! & xeg, yeg, zeg, dnxi) +! +! +! subroutine cal_x_jacobian_1d_2(numnod, numedge, nnod_4_edge, & +! & ie_edge, xx, xjac, axjac, xeg, dnxi) +! subroutine cal_x_jacobian_1d_3(numnod, numedge, nnod_4_edge, & +! & ie_edge, xx, xjac, axjac, xeg, dnxi) +! subroutine cal_x_jacobian_1d_2_3(numnod, numedge, nnod_4_edge, & +! & ie_edge, xx, xjac, axjac, xeg, dnxi) +! + module cal_jacobian_1d +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_1d_2(numnod, numedge, & + & ie_edge, xx, np_smp, iedge_smp_stack, xjac, axjac, & + & xeg, yeg, zeg, dnxi) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numedge + integer(kind = kint), intent(in) & + & :: ie_edge(numedge, num_linear_edge) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iedge_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_linear_edge) +! + real(kind = kreal), intent(inout) :: xjac(numedge) + real(kind = kreal), intent(inout) :: axjac(numedge) + real(kind = kreal), intent(inout) :: xeg(numedge) + real(kind = kreal), intent(inout) :: yeg(numedge) + real(kind = kreal), intent(inout) :: zeg(numedge) +! + integer(kind = kint) :: ip, ist, ied, iedge + integer(kind = kint) :: i1, i2 +! +! +!$omp parallel do private(ist,ied,iedge,i1,i2) + do ip = 1, np_smp + ist = iedge_smp_stack(ip-1) + 1 + ied = iedge_smp_stack(ip) +! +!cdir nodep noloopchg + do iedge = ist, ied +! + i1 = ie_edge(iedge, 1) + i2 = ie_edge(iedge, 2) +! + xeg(iedge) = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) +! + yeg(iedge) = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) +! + zeg(iedge) = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) +! + xjac(iedge) = sqrt( xeg(iedge)*xeg(iedge) & + & + yeg(iedge)*yeg(iedge) & + & + zeg(iedge)*zeg(iedge) ) +! + if (xjac(iedge) .eq. 0.0d0) then + axjac(iedge) = 1.0d+30 + else + axjac(iedge) = 1.0d00 / xjac(iedge) + end if +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_1d_2 +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_1d_3(numnod, numedge, & + & ie_edge, xx, np_smp, iedge_smp_stack, xjac, axjac, & + & xeg, yeg, zeg, dnxi) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numedge + integer(kind = kint), intent(in) & + & :: ie_edge(numedge, num_quad_edge) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iedge_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_quad_edge) +! + real(kind = kreal), intent(inout) :: xjac(numedge) + real(kind = kreal), intent(inout) :: axjac(numedge) + real(kind = kreal), intent(inout) :: xeg(numedge) + real(kind = kreal), intent(inout) :: yeg(numedge) + real(kind = kreal), intent(inout) :: zeg(numedge) +! + integer(kind = kint) :: ip, ist, ied, iedge + integer(kind = kint) :: i1, i2, i3 +! +! +!$omp parallel do private(ist,ied,iedge,i1,i2,i3) + do ip = 1, np_smp + ist = iedge_smp_stack(ip-1) + 1 + ied = iedge_smp_stack(ip) +! +!cdir nodep noloopchg + do iedge = ist, ied +! + i1 = ie_edge(iedge, 1) + i2 = ie_edge(iedge, 2) + i3 = ie_edge(iedge, 3) +! + xeg(iedge) = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) & + & + xx(i3, 1)*dnxi( 3) +! + yeg(iedge) = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) & + & + xx(i3, 2)*dnxi( 3) +! + zeg(iedge) = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) & + & + xx(i3, 3)*dnxi( 3) +! +! + xjac(iedge) = sqrt( xeg(iedge)*xeg(iedge) & + & + yeg(iedge)*yeg(iedge) & + & + zeg(iedge)*zeg(iedge) ) +! + if (xjac(iedge) .eq. 0.0d0) then + axjac(iedge) = 1.0d+30 + else + axjac(iedge) = 1.0d00 / xjac(iedge) + end if +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_1d_3 +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_1d_2_3(numnod, numedge, & + & ie_edge, xx, np_smp, iedge_smp_stack, xjac, axjac, & + & xeg, yeg, zeg, dnxi) +! + use m_constants + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numedge + integer(kind = kint), intent(in) & + & :: ie_edge(numedge, num_linear_edge) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iedge_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_quad_edge) +! + real(kind = kreal), intent(inout) :: xjac(numedge) + real(kind = kreal), intent(inout) :: axjac(numedge) + real(kind = kreal), intent(inout) :: xeg(numedge) + real(kind = kreal), intent(inout) :: yeg(numedge) + real(kind = kreal), intent(inout) :: zeg(numedge) +! + integer(kind = kint) :: ip, ist, ied, iedge + integer(kind = kint) :: i1, i2 + real(kind = kreal) :: x1, x2, x3, y1, y2, y3, z1, z2, z3 +! +! +!$omp parallel do private(ist,ied,iedge,i1,i2,x1,x2,x3,y1,y2,y3,z1,z2,z3) + do ip = 1, np_smp + ist = iedge_smp_stack(ip-1) + 1 + ied = iedge_smp_stack(ip) +! +!cdir nodep noloopchg + do iedge = ist, ied +! + i1 = ie_edge(iedge, 1) + i2 = ie_edge(iedge, 2) +! + x1 = xx(i1,1) + x2 = half * (xx(i1,1) + xx(i2,1)) + x3 = xx(i2,1) +! + y1 = xx(i1,2) + y2 = half * (xx(i1,2) + xx(i2,2)) + y3 = xx(i2,2) +! + z1 = xx(i1,3) + z2 = half * (xx(i1,3) + xx(i2,3)) + z3 = xx(i2,3) +! +! + xeg(iedge) = x1*dnxi( 1) + x2*dnxi( 2) + x3*dnxi( 3) + yeg(iedge) = y1*dnxi( 1) + y2*dnxi( 2) + y3*dnxi( 3) + zeg(iedge) = z1*dnxi( 1) + z2*dnxi( 2) + z3*dnxi( 3) +! +! + xjac(iedge) = sqrt( xeg(iedge)*xeg(iedge) & + & + yeg(iedge)*yeg(iedge) & + & + zeg(iedge)*zeg(iedge) ) +! + if (xjac(iedge) .eq. 0.0d0) then + axjac(iedge) = 1.0d+30 + else + axjac(iedge) = 1.0d00 / xjac(iedge) + end if +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_1d_2_3 +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_x_jacobian_1d_2(numnod, numedge, nnod_4_edge, & + & ie_edge, xx, xjac, axjac, xeg, dnxi) +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numedge, nnod_4_edge + integer(kind = kint), intent(in) :: ie_edge(numedge, nnod_4_edge) + real(kind = kreal), intent(in) :: xx(numnod) +! + real(kind = kreal), intent(in) :: dnxi(2) +! + real(kind = kreal), intent(inout) :: xjac(numedge) + real(kind = kreal), intent(inout) :: axjac(numedge) + real(kind = kreal), intent(inout) :: xeg(numedge) +! + integer(kind = kint) :: iedge, i1, i2 +! +! +!cdir nodep noloopchg + do iedge = 1, numedge-1 + i1 = ie_edge(iedge,1) + i2 = ie_edge(iedge,2) +! + xeg(iedge) = xx(i1)*dnxi( 1) + xx(i2)*dnxi( 2) + xjac(iedge) = sqrt( xeg(iedge)*xeg(iedge) ) +! + if (xjac(iedge) .eq. 0.0d0) then + axjac(iedge) = 1.0d+30 + else + axjac(iedge) = 1.0d00 / xjac(iedge) + end if + end do +! + end subroutine cal_x_jacobian_1d_2 +! +!----------------------------------------------------------------------- +! + subroutine cal_x_jacobian_1d_3(numnod, numedge, nnod_4_edge, & + & ie_edge, xx, xjac, axjac, xeg, dnxi) +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numedge, nnod_4_edge + integer(kind = kint), intent(in) :: ie_edge(numedge, nnod_4_edge) + real(kind = kreal), intent(in) :: xx(numnod) +! + real(kind = kreal), intent(in) :: dnxi(3) +! + real(kind = kreal), intent(inout) :: xjac(numedge) + real(kind = kreal), intent(inout) :: axjac(numedge) + real(kind = kreal), intent(inout) :: xeg(numedge) +! + integer(kind = kint) :: iedge + integer(kind = kint) :: i1, i2, i3 +! +! +!cdir nodep noloopchg + do iedge = 1, numedge-2, 2 + i1 = ie_edge(iedge,1) + i2 = ie_edge(iedge,2) + i3 = ie_edge(iedge,3) +! + xeg(iedge) = xx(i1)*dnxi(1) + xx(i2)*dnxi(2) + xx(i3)*dnxi(3) + xjac(iedge) = sqrt( xeg(iedge)*xeg(iedge) ) +! + if (xjac(iedge) .eq. 0.0d0) then + axjac(iedge) = 1.0d+30 + else + axjac(iedge) = 1.0d00 / xjac(iedge) + end if + end do +! + end subroutine cal_x_jacobian_1d_3 +! +!----------------------------------------------------------------------- +! + subroutine cal_x_jacobian_1d_2_3(numnod, numedge, nnod_4_edge, & + & ie_edge, xx, xjac, axjac, xeg, dnxi) +! + use m_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numedge, nnod_4_edge + integer(kind = kint), intent(in) :: ie_edge(numedge, nnod_4_edge) + real(kind = kreal), intent(in) :: xx(numnod) +! + real(kind = kreal), intent(in) :: dnxi(3) +! + real(kind = kreal), intent(inout) :: xjac(numedge) + real(kind = kreal), intent(inout) :: axjac(numedge) + real(kind = kreal), intent(inout) :: xeg(numedge) +! + integer(kind = kint) :: iedge + integer(kind = kint) :: i1, i2 +! +! +!cdir nodep noloopchg + do iedge = 1, numedge + i1 = ie_edge(iedge,1) + i2 = ie_edge(iedge,2) +! + xeg(iedge) = xx(i1)*dnxi(1) + half*(xx(i1) + xx(i2))*dnxi(2) & + & + xx(i2)*dnxi(3) + xjac(iedge) = sqrt( xeg(iedge)*xeg(iedge) ) +! + if (xjac(iedge) .eq. 0.0d0) then + axjac(iedge) = 1.0d+30 + else + axjac(iedge) = 1.0d00 / xjac(iedge) + end if + end do +! + end subroutine cal_x_jacobian_1d_2_3 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_1d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_lag.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_lag.f90 new file mode 100644 index 00000000..f40b67e1 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_lag.f90 @@ -0,0 +1,139 @@ +! +! module cal_jacobian_2d_lag +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_2d_9(numnod, numsurf, & +! & ie_surf, xx, np_smp, isurf_smp_stack, xjac, axjac, & +! & xsf, ysf, zsf, dnxi, dnei) +! + module cal_jacobian_2d_lag +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_2d_9(numnod, numsurf, & + & ie_surf, xx, np_smp, isurf_smp_stack, xjac, axjac, & + & xsf, ysf, zsf, dnxi, dnei) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numsurf + integer(kind = kint), intent(in) :: ie_surf(numsurf, num_lag_sf) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: isurf_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_lag_sf) + real(kind = kreal), intent(in) :: dnei(num_lag_sf) +! + real(kind = kreal), intent(inout) :: xjac(numsurf) + real(kind = kreal), intent(inout) :: axjac(numsurf) + real(kind = kreal), intent(inout) :: xsf(numsurf) + real(kind = kreal), intent(inout) :: ysf(numsurf) + real(kind = kreal), intent(inout) :: zsf(numsurf) +! + integer(kind = kint) :: ip, ist, ied, isurf +! + real(kind = kreal) :: dxxi, dxei + real(kind = kreal) :: dyxi, dyei + real(kind = kreal) :: dzxi, dzei +! + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8, i9 +! +! +!$omp parallel do private & +!$omp& (ist,ied,isurf,i1,i2,i3,i4,i5,i6,i7,i8,i9, & +!$omp& dxxi,dxei,dyxi,dyei,dzxi,dzei) + do ip = 1, np_smp + ist = isurf_smp_stack(ip-1) + 1 + ied = isurf_smp_stack(ip) +! +!cdir nodep noloopchg + do isurf = ist, ied +! + i1 = ie_surf(isurf, 1) + i2 = ie_surf(isurf, 2) + i3 = ie_surf(isurf, 3) + i4 = ie_surf(isurf, 4) + i5 = ie_surf(isurf, 5) + i6 = ie_surf(isurf, 6) + i7 = ie_surf(isurf, 7) + i8 = ie_surf(isurf, 8) + i9 = ie_surf(isurf, 9) +! + dxxi = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) & + & + xx(i3, 1)*dnxi( 3) + xx(i4, 1)*dnxi( 4) & + & + xx(i5, 1)*dnxi( 5) + xx(i6, 1)*dnxi( 6) & + & + xx(i7, 1)*dnxi( 7) + xx(i8, 1)*dnxi( 8) & + & + xx(i9, 1)*dnxi( 9) +! + dxei = xx(i1, 1)*dnei( 1) + xx(i2, 1)*dnei( 2) & + & + xx(i3, 1)*dnei( 3) + xx(i4, 1)*dnei( 4) & + & + xx(i5, 1)*dnei( 5) + xx(i6, 1)*dnei( 6) & + & + xx(i7, 1)*dnei( 7) + xx(i8, 1)*dnei( 8) & + & + xx(i9, 1)*dnei( 9) +! +! + dyxi = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) & + & + xx(i3, 2)*dnxi( 3) + xx(i4, 2)*dnxi( 4) & + & + xx(i5, 2)*dnxi( 5) + xx(i6, 2)*dnxi( 6) & + & + xx(i7, 2)*dnxi( 7) + xx(i8, 2)*dnxi( 8) & + & + xx(i9, 2)*dnxi( 9) +! + dyei = xx(i1, 2)*dnei( 1) + xx(i2, 2)*dnei( 2) & + & + xx(i3, 2)*dnei( 3) + xx(i4, 2)*dnei( 4) & + & + xx(i5, 2)*dnei( 5) + xx(i6, 2)*dnei( 6) & + & + xx(i7, 2)*dnei( 7) + xx(i8, 2)*dnei( 8) & + & + xx(i9, 2)*dnei( 9) +! +! + dzxi = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) & + & + xx(i3, 3)*dnxi( 3) + xx(i4, 3)*dnxi( 4) & + & + xx(i5, 3)*dnxi( 5) + xx(i6, 3)*dnxi( 6) & + & + xx(i7, 3)*dnxi( 7) + xx(i8, 3)*dnxi( 8) & + & + xx(i9, 3)*dnxi( 9) +! + dzei = xx(i1, 3)*dnei( 1) + xx(i2, 3)*dnei( 2) & + & + xx(i3, 3)*dnei( 3) + xx(i4, 3)*dnei( 4) & + & + xx(i5, 3)*dnei( 5) + xx(i6, 3)*dnei( 6) & + & + xx(i7, 3)*dnei( 7) + xx(i8, 3)*dnei( 8) & + & + xx(i9, 3)*dnei( 9) +! +! +! + xsf(isurf) = dyxi*dzei - dzxi*dyei + ysf(isurf) = dzxi*dxei - dxxi*dzei + zsf(isurf) = dxxi*dyei - dyxi*dxei +! + xjac(isurf) = sqrt( xsf(isurf)*xsf(isurf) & + & + ysf(isurf)*ysf(isurf) & + & + zsf(isurf)*zsf(isurf) ) +! + if (xjac(isurf) .eq. 0.0d0) then + axjac(isurf) = 1.0d+30 + else + axjac(isurf) = 1.0d00 / xjac(isurf) + end if +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_2d_9 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_2d_lag diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_linear.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_linear.f90 new file mode 100644 index 00000000..ac7e8179 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_linear.f90 @@ -0,0 +1,116 @@ +! +! module cal_jacobian_2d_linear +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_2d_4(numnod, numsurf, & +! & ie_surf, xx, np_smp, isurf_smp_stack, xjac, axjac, & +! & xsf, ysf, zsf, dnxi, dnei) +! + module cal_jacobian_2d_linear +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_2d_4(numnod, numsurf, & + & ie_surf, xx, np_smp, isurf_smp_stack, xjac, axjac, & + & xsf, ysf, zsf, dnxi, dnei) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numsurf + integer(kind = kint), intent(in) & + & :: ie_surf(numsurf, num_linear_sf) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: isurf_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_linear_sf) + real(kind = kreal), intent(in) :: dnei(num_linear_sf) +! + real(kind = kreal), intent(inout) :: xjac(numsurf) + real(kind = kreal), intent(inout) :: axjac(numsurf) + real(kind = kreal), intent(inout) :: xsf(numsurf) + real(kind = kreal), intent(inout) :: ysf(numsurf) + real(kind = kreal), intent(inout) :: zsf(numsurf) +! + integer(kind = kint) :: ip, ist, ied, isurf +! + real(kind = kreal) :: dxxi, dxei + real(kind = kreal) :: dyxi, dyei + real(kind = kreal) :: dzxi, dzei +! + integer(kind = kint) :: i1, i2, i3, i4 +! +! +!$omp parallel do private & +!$omp& (ist,ied,isurf,i1,i2,i3,i4,dxxi,dxei,dyxi,dyei,dzxi,dzei) + do ip = 1, np_smp + ist = isurf_smp_stack(ip-1) + 1 + ied = isurf_smp_stack(ip) +! +!cdir nodep noloopchg + do isurf = ist, ied +! + i1 = ie_surf(isurf, 1) + i2 = ie_surf(isurf, 2) + i3 = ie_surf(isurf, 3) + i4 = ie_surf(isurf, 4) +! + dxxi = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) & + & + xx(i3, 1)*dnxi( 3) + xx(i4, 1)*dnxi( 4) +! + dxei = xx(i1, 1)*dnei( 1) + xx(i2, 1)*dnei( 2) & + & + xx(i3, 1)*dnei( 3) + xx(i4, 1)*dnei( 4) +! +! + dyxi = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) & + & + xx(i3, 2)*dnxi( 3) + xx(i4, 2)*dnxi( 4) +! + dyei = xx(i1, 2)*dnei( 1) + xx(i2, 2)*dnei( 2) & + & + xx(i3, 2)*dnei( 3) + xx(i4, 2)*dnei( 4) +! +! + dzxi = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) & + & + xx(i3, 3)*dnxi( 3) + xx(i4, 3)*dnxi( 4) +! + dzei = xx(i1, 3)*dnei( 1) + xx(i2, 3)*dnei( 2) & + & + xx(i3, 3)*dnei( 3) + xx(i4, 3)*dnei( 4) +! +! +! + xsf(isurf) = dyxi*dzei - dzxi*dyei + ysf(isurf) = dzxi*dxei - dxxi*dzei + zsf(isurf) = dxxi*dyei - dyxi*dxei +! + xjac(isurf) = sqrt( xsf(isurf)*xsf(isurf) & + & + ysf(isurf)*ysf(isurf) & + & + zsf(isurf)*zsf(isurf) ) +! + if (xjac(isurf) .eq. 0.0d0) then + axjac(isurf) = 1.0d+30 + else + axjac(isurf) = 1.0d00 / xjac(isurf) + end if +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_2d_4 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_2d_linear diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_linear_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_linear_quad.f90 new file mode 100644 index 00000000..c04ce4d7 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_linear_quad.f90 @@ -0,0 +1,154 @@ +!cal_jacobian_2d_linear_quad.f90 +! module cal_jacobian_2d_linear_quad +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_2d_4_8(numnod, numsurf, & +! & ie_surf, xx, np_smp, isurf_smp_stack, xjac, axjac, & +! & xsf, ysf, zsf, dnxi, dnei) +! +!> @brief Caliculate jacobian by quadrature shape function +!> for 2-d quadrature element +! + module cal_jacobian_2d_linear_quad +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! +!> Caliculate jacobian by quadrature 2-d shape function +!> for linear element + subroutine s_cal_jacobian_2d_4_8(numnod, numsurf, & + & ie_surf, xx, np_smp, isurf_smp_stack, xjac, axjac, & + & xsf, ysf, zsf, dnxi, dnei) +! + use m_constants + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numsurf + integer(kind = kint), intent(in) & + & :: ie_surf(numsurf, num_linear_sf) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: isurf_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_quad_sf) + real(kind = kreal), intent(in) :: dnei(num_quad_sf) +! + real(kind = kreal), intent(inout) :: xjac(numsurf) + real(kind = kreal), intent(inout) :: axjac(numsurf) + real(kind = kreal), intent(inout) :: xsf(numsurf) + real(kind = kreal), intent(inout) :: ysf(numsurf) + real(kind = kreal), intent(inout) :: zsf(numsurf) +! + integer(kind = kint) :: ip, ist, ied, isurf +! + real(kind = kreal) :: dxxi, dxei + real(kind = kreal) :: dyxi, dyei + real(kind = kreal) :: dzxi, dzei +! + real(kind = kreal) :: x1, x2, x3, x4, x5, x6, x7, x8 + real(kind = kreal) :: y1, y2, y3, y4, y5, y6, y7, y8 + real(kind = kreal) :: z1, z2, z3, z4, z5, z6, z7, z8 + integer(kind = kint) :: i1, i2, i3, i4 +! +! +!$omp parallel do private & +!$omp& (ist,ied,isurf,i1,i2,i3,i4, & +!$omp& dxxi,dxei,dyxi,dyei,dzxi,dzei,x1,x2,x3,x4,x5,x6,x7,x8, & +!$omp& y1,y2,y3,y4,y5,y6,y7,y8,z1,z2,z3,z4,z5,z6,z7,z8) + do ip = 1, np_smp + ist = isurf_smp_stack(ip-1) + 1 + ied = isurf_smp_stack(ip) +! +!cdir nodep noloopchg + do isurf = ist, ied +! + i1 = ie_surf(isurf, 1) + i2 = ie_surf(isurf, 2) + i3 = ie_surf(isurf, 3) + i4 = ie_surf(isurf, 4) +! + x1 = xx(i1,1) + x2 = xx(i2,1) + x3 = xx(i3,1) + x4 = xx(i4,1) + x5 = half * (xx(i1,1) + xx(i2,1)) + x6 = half * (xx(i2,1) + xx(i3,1)) + x7 = half * (xx(i3,1) + xx(i4,1)) + x8 = half * (xx(i4,1) + xx(i1,1)) +! + y1 = xx(i1,2) + y2 = xx(i2,2) + y3 = xx(i3,2) + y4 = xx(i4,2) + y5 = half * (xx(i1,2) + xx(i2,2)) + y6 = half * (xx(i2,2) + xx(i3,2)) + y7 = half * (xx(i3,2) + xx(i4,2)) + y8 = half * (xx(i4,2) + xx(i1,2)) +! + z1 = xx(i1,3) + z2 = xx(i2,3) + z3 = xx(i3,3) + z4 = xx(i4,3) + z5 = half * (xx(i1,3) + xx(i2,3)) + z6 = half * (xx(i2,3) + xx(i3,3)) + z7 = half * (xx(i3,3) + xx(i4,3)) + z8 = half * (xx(i4,3) + xx(i1,3)) +! + dxxi = x1*dnxi( 1) + x2*dnxi( 2) + x3*dnxi( 3) + x4*dnxi( 4) & + & + x5*dnxi( 5) + x6*dnxi( 6) + x7*dnxi( 7) + x8*dnxi( 8) +! + dxei = x1*dnei( 1) + x2*dnei( 2) + x3*dnei( 3) + x4*dnei( 4) & + & + x5*dnei( 5) + x6*dnei( 6) + x7*dnei( 7) + x8*dnei( 8) +! +! + dyxi = y1*dnxi( 1) + y2*dnxi( 2) + y3*dnxi( 3) + y4*dnxi( 4) & + & + y5*dnxi( 5) + y6*dnxi( 6) + y7*dnxi( 7) + y8*dnxi( 8) +! + dyei = y1*dnei( 1) + y2*dnei( 2) + y3*dnei( 3) + y4*dnei( 4) & + & + y5*dnei( 5) + y6*dnei( 6) + y7*dnei( 7) + y8*dnei( 8) +! +! + dzxi = z1*dnxi( 1) + z2*dnxi( 2) + z3*dnxi( 3) + z4*dnxi( 4) & + & + z5*dnxi( 5) + z6*dnxi( 6) + z7*dnxi( 7) + z8*dnxi( 8) +! + dzei = z1*dnei( 1) + z2*dnei( 2) + z3*dnei( 3) + z4*dnei( 4) & + & + z5*dnei( 5) + z6*dnei( 6) + z7*dnei( 7) + z8*dnei( 8) +! +! +! + xsf(isurf) = dyxi*dzei - dzxi*dyei + ysf(isurf) = dzxi*dxei - dxxi*dzei + zsf(isurf) = dxxi*dyei - dyxi*dxei +! + xjac(isurf) = sqrt( xsf(isurf)*xsf(isurf) & + & + ysf(isurf)*ysf(isurf) & + & + zsf(isurf)*zsf(isurf) ) +! + if (xjac(isurf) .eq. 0.0d0) then + axjac(isurf) = 1.0d+30 + else + axjac(isurf) = 1.0d00 / xjac(isurf) + end if +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_2d_4_8 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_2d_linear_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_quad.f90 new file mode 100644 index 00000000..f1579ae3 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_2d_quad.f90 @@ -0,0 +1,132 @@ +! +! module cal_jacobian_2d_quad +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_2d_8(numnod, numsurf, & +! & ie_surf, xx, np_smp, isurf_smp_stack, xjac, axjac, & +! & xsf, ysf, zsf, dnxi, dnei) +! + module cal_jacobian_2d_quad +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_2d_8(numnod, numsurf, & + & ie_surf, xx, np_smp, isurf_smp_stack, xjac, axjac, & + & xsf, ysf, zsf, dnxi, dnei) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numsurf + integer(kind = kint), intent(in) :: ie_surf(numsurf, num_quad_sf) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: isurf_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_quad_sf) + real(kind = kreal), intent(in) :: dnei(num_quad_sf) +! + real(kind = kreal), intent(inout) :: xjac(numsurf) + real(kind = kreal), intent(inout) :: axjac(numsurf) + real(kind = kreal), intent(inout) :: xsf(numsurf) + real(kind = kreal), intent(inout) :: ysf(numsurf) + real(kind = kreal), intent(inout) :: zsf(numsurf) +! + integer(kind = kint) :: ip, ist, ied, isurf +! + real(kind = kreal) :: dxxi, dxei + real(kind = kreal) :: dyxi, dyei + real(kind = kreal) :: dzxi, dzei +! + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 +! +! +!$omp parallel do private & +!$omp& (ist,ied,isurf,i1,i2,i3,i4,i5,i6,i7,i8, & +!$omp& dxxi,dxei,dyxi,dyei,dzxi,dzei) + do ip = 1, np_smp + ist = isurf_smp_stack(ip-1) + 1 + ied = isurf_smp_stack(ip) +! +!cdir nodep noloopchg + do isurf = ist, ied +! + i1 = ie_surf(isurf, 1) + i2 = ie_surf(isurf, 2) + i3 = ie_surf(isurf, 3) + i4 = ie_surf(isurf, 4) + i5 = ie_surf(isurf, 5) + i6 = ie_surf(isurf, 6) + i7 = ie_surf(isurf, 7) + i8 = ie_surf(isurf, 8) +! + dxxi = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) & + & + xx(i3, 1)*dnxi( 3) + xx(i4, 1)*dnxi( 4) & + & + xx(i5, 1)*dnxi( 5) + xx(i6, 1)*dnxi( 6) & + & + xx(i7, 1)*dnxi( 7) + xx(i8, 1)*dnxi( 8) +! + dxei = xx(i1, 1)*dnei( 1) + xx(i2, 1)*dnei( 2) & + & + xx(i3, 1)*dnei( 3) + xx(i4, 1)*dnei( 4) & + & + xx(i5, 1)*dnei( 5) + xx(i6, 1)*dnei( 6) & + & + xx(i7, 1)*dnei( 7) + xx(i8, 1)*dnei( 8) +! +! + dyxi = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) & + & + xx(i3, 2)*dnxi( 3) + xx(i4, 2)*dnxi( 4) & + & + xx(i5, 2)*dnxi( 5) + xx(i6, 2)*dnxi( 6) & + & + xx(i7, 2)*dnxi( 7) + xx(i8, 2)*dnxi( 8) +! + dyei = xx(i1, 2)*dnei( 1) + xx(i2, 2)*dnei( 2) & + & + xx(i3, 2)*dnei( 3) + xx(i4, 2)*dnei( 4) & + & + xx(i5, 2)*dnei( 5) + xx(i6, 2)*dnei( 6) & + & + xx(i7, 2)*dnei( 7) + xx(i8, 2)*dnei( 8) +! +! + dzxi = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) & + & + xx(i3, 3)*dnxi( 3) + xx(i4, 3)*dnxi( 4) & + & + xx(i5, 3)*dnxi( 5) + xx(i6, 3)*dnxi( 6) & + & + xx(i7, 3)*dnxi( 7) + xx(i8, 3)*dnxi( 8) +! + dzei = xx(i1, 3)*dnei( 1) + xx(i2, 3)*dnei( 2) & + & + xx(i3, 3)*dnei( 3) + xx(i4, 3)*dnei( 4) & + & + xx(i5, 3)*dnei( 5) + xx(i6, 3)*dnei( 6) & + & + xx(i7, 3)*dnei( 7) + xx(i8, 3)*dnei( 8) +! +! +! + xsf(isurf) = dyxi*dzei - dzxi*dyei + ysf(isurf) = dzxi*dxei - dxxi*dzei + zsf(isurf) = dxxi*dyei - dyxi*dxei +! + xjac(isurf) = sqrt( xsf(isurf)*xsf(isurf) & + & + ysf(isurf)*ysf(isurf) & + & + zsf(isurf)*zsf(isurf) ) +! + if (xjac(isurf) .eq. 0.0d0) then + axjac(isurf) = 1.0d+30 + else + axjac(isurf) = 1.0d00 / xjac(isurf) + end if +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_2d_8 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_2d_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_l_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_l_quad.f90 new file mode 100644 index 00000000..0b831269 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_l_quad.f90 @@ -0,0 +1,477 @@ +!cal_jacobian_3d_inf_l_quad.f90 +! module cal_jacobian_3d_inf_l_quad +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June, 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_3d_inf_8_20(numnod, numele, nnod_4_ele,& +! & np_smp, ie, xx, num_surf_bc, surf_item, & +! & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & +! & isurf_grp_smp_stack, xjac, axjac, dnx, dny, dnz, & +! & dxidx, deidx, dzidx, dxidy, deidy, dzidy, & +! & dxidz, deidz, dzidz, dnxi, dnei, dnzi, & +! & dnxi_inf, dnei_inf, dnzi_inf) +! +!> @brief Caliculate jacobian by quadrature shape function +!> for infinity quadrature element +! + module cal_jacobian_3d_inf_l_quad +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! +!> Caliculate jacobian by quadrature infinity shape function +!> for linear element + subroutine s_cal_jacobian_3d_inf_8_20(numnod, numele, & + & np_smp, ie, xx, num_surf_bc, surf_item, & + & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & + & isurf_grp_smp_stack, xjac, axjac, dnx, dny, dnz, & + & dxidx, deidx, dzidx, dxidy, deidy, dzidy, & + & dxidz, deidz, dzidz, dnxi, dnei, dnzi, & + & dnxi_inf, dnei_inf, dnzi_inf) +! + use m_geometry_constants + use m_constants +! +! + integer(kind = kint), intent(in) :: numnod, numele + integer(kind = kint), intent(in) :: ie(numele, num_t_linear) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer (kind=kint), intent(in) :: ngrp_sf_infty + integer (kind=kint), intent(in) :: id_grp_sf_infty(ngrp_sf_infty) +! + integer(kind = kint), intent(in) :: np_smp, num_surf_smp + integer(kind = kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_t_quad) + real(kind = kreal), intent(in) :: dnei(num_t_quad) + real(kind = kreal), intent(in) :: dnzi(num_t_quad) +! + real(kind = kreal), intent(in) & + & :: dnxi_inf(num_t_quad,nsurf_4_ele) + real(kind = kreal), intent(in) & + & :: dnei_inf(num_t_quad,nsurf_4_ele) + real(kind = kreal), intent(in) & + & :: dnzi_inf(num_t_quad,nsurf_4_ele) +! + real(kind = kreal), intent(inout) :: dxidx(numele) + real(kind = kreal), intent(inout) :: deidx(numele) + real(kind = kreal), intent(inout) :: dzidx(numele) + real(kind = kreal), intent(inout) :: dxidy(numele) + real(kind = kreal), intent(inout) :: deidy(numele) + real(kind = kreal), intent(inout) :: dzidy(numele) + real(kind = kreal), intent(inout) :: dxidz(numele) + real(kind = kreal), intent(inout) :: deidz(numele) + real(kind = kreal), intent(inout) :: dzidz(numele) +! + real(kind = kreal), intent(inout) :: xjac(numele) + real(kind = kreal), intent(inout) :: axjac(numele) + real(kind = kreal), intent(inout) :: dnx(numele,num_t_quad) + real(kind = kreal), intent(inout) :: dny(numele,num_t_quad) + real(kind = kreal), intent(inout) :: dnz(numele,num_t_quad) +! + integer(kind = kint) :: i, ip, ist, ied, iele + integer(kind = kint) :: igrp, id_sf, inum, isf +! + real(kind = kreal) :: dxxi, dxei, dxzi + real(kind = kreal) :: dyxi, dyei, dyzi + real(kind = kreal) :: dzxi, dzei, dzzi + real(kind = kreal) :: xj11, xj12, xj13 + real(kind = kreal) :: xj21, xj22, xj23 + real(kind = kreal) :: xj31, xj32, xj33 +! + real(kind = kreal) :: x01, x02, x03, x04, x05, x06, x07, x08 + real(kind = kreal) :: x09, x10, x11, x12, x13, x14, x15, x16 + real(kind = kreal) :: x17, x18, x19, x20 + real(kind = kreal) :: y01, y02, y03, y04, y05, y06, y07, y08 + real(kind = kreal) :: y09, y10, y11, y12, y13, y14, y15, y16 + real(kind = kreal) :: y17, y18, y19, y20 + real(kind = kreal) :: z01, z02, z03, z04, z05, z06, z07, z08 + real(kind = kreal) :: z09, z10, z11, z12, z13, z14, z15, z16 + real(kind = kreal) :: z17, z18, z19, z20 + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 +! +! + do i = 1, ngrp_sf_infty + igrp = id_grp_sf_infty(i) +! +!$omp parallel do private & +!$omp& (ist,ied,id_sf,inum,iele,isf,i1,i2,i3,i4,i5,i6,i7,i8, & +!$omp& xj11,xj12,xj13,xj21,xj22,xj23,xj31,xj32,xj33, & +!$omp& x01,x02,x03,x04,x05,x06,x07,x08,x09,x10,x11,x12,x13,x14,x15, & +!$omp& x16,x17,x18,x19,x20,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & +!$omp& y11,y12,y13,y14,y15,y16,y17,y18,y19,y20,z01,z02,z03,z04,z05, & +!$omp& z06,z07,z08,z09,z10,z11,z12,z13,z14,z15,z16,z17,z18,z19,z20) + do ip = 1, np_smp + id_sf = np_smp*(igrp-1) + ip + ist = isurf_grp_smp_stack(id_sf-1)+1 + ied = isurf_grp_smp_stack(id_sf) +! +!cdir nodep noloopchg + do inum = ist, ied + iele = surf_item(1,inum) + isf = surf_item(2,inum) +! + i1 = ie(iele, 1) + i2 = ie(iele, 2) + i3 = ie(iele, 3) + i4 = ie(iele, 4) + i5 = ie(iele, 5) + i6 = ie(iele, 6) + i7 = ie(iele, 7) + i8 = ie(iele, 8) +! + x01 = xx(i1,1) + x02 = xx(i2,1) + x03 = xx(i3,1) + x04 = xx(i4,1) + x05 = xx(i5,1) + x06 = xx(i6,1) + x07 = xx(i7,1) + x08 = xx(i8,1) + x09 = half * (xx(i1,1) + xx(i2,1)) + x10 = half * (xx(i2,1) + xx(i3,1)) + x11 = half * (xx(i3,1) + xx(i4,1)) + x12 = half * (xx(i4,1) + xx(i1,1)) + x13 = half * (xx(i5,1) + xx(i6,1)) + x14 = half * (xx(i6,1) + xx(i7,1)) + x15 = half * (xx(i7,1) + xx(i8,1)) + x16 = half * (xx(i8,1) + xx(i5,1)) + x17 = half * (xx(i1,1) + xx(i5,1)) + x18 = half * (xx(i2,1) + xx(i6,1)) + x19 = half * (xx(i3,1) + xx(i7,1)) + x20 = half * (xx(i4,1) + xx(i8,1)) +! + y01 = xx(i1,2) + y02 = xx(i2,2) + y03 = xx(i3,2) + y04 = xx(i4,2) + y05 = xx(i5,2) + y06 = xx(i6,2) + y07 = xx(i7,2) + y08 = xx(i8,2) + y09 = half * (xx(i1,2) + xx(i2,2)) + y10 = half * (xx(i2,2) + xx(i3,2)) + y11 = half * (xx(i3,2) + xx(i4,2)) + y12 = half * (xx(i4,2) + xx(i1,2)) + y13 = half * (xx(i5,2) + xx(i6,2)) + y14 = half * (xx(i6,2) + xx(i7,2)) + y15 = half * (xx(i7,2) + xx(i8,2)) + y16 = half * (xx(i8,2) + xx(i5,2)) + y17 = half * (xx(i1,2) + xx(i5,2)) + y18 = half * (xx(i2,2) + xx(i6,2)) + y19 = half * (xx(i3,2) + xx(i7,2)) + y20 = half * (xx(i4,2) + xx(i8,2)) +! + z01 = xx(i1,3) + z02 = xx(i2,3) + z03 = xx(i3,3) + z04 = xx(i4,3) + z05 = xx(i5,3) + z06 = xx(i6,3) + z07 = xx(i7,3) + z08 = xx(i8,3) + z09 = half * (xx(i1,3) + xx(i2,3)) + z10 = half * (xx(i2,3) + xx(i3,3)) + z11 = half * (xx(i3,3) + xx(i4,3)) + z12 = half * (xx(i4,3) + xx(i1,3)) + z13 = half * (xx(i5,3) + xx(i6,3)) + z14 = half * (xx(i6,3) + xx(i7,3)) + z15 = half * (xx(i7,3) + xx(i8,3)) + z16 = half * (xx(i8,3) + xx(i5,3)) + z17 = half * (xx(i1,3) + xx(i5,3)) + z18 = half * (xx(i2,3) + xx(i6,3)) + z19 = half * (xx(i3,3) + xx(i7,3)) + z20 = half * (xx(i4,3) + xx(i8,3)) +! + dxxi = x01*dnxi_inf( 1,isf) + x02*dnxi_inf( 2,isf) & + & + x03*dnxi_inf( 3,isf) + x04*dnxi_inf( 4,isf) & + & + x05*dnxi_inf( 5,isf) + x06*dnxi_inf( 6,isf) & + & + x07*dnxi_inf( 7,isf) + x08*dnxi_inf( 8,isf) & + & + x09*dnxi_inf( 9,isf) + x10*dnxi_inf(10,isf) & + & + x11*dnxi_inf(11,isf) + x12*dnxi_inf(12,isf) & + & + x13*dnxi_inf(13,isf) + x14*dnxi_inf(14,isf) & + & + x15*dnxi_inf(15,isf) + x16*dnxi_inf(16,isf) & + & + x17*dnxi_inf(17,isf) + x18*dnxi_inf(18,isf) & + & + x19*dnxi_inf(19,isf) + x20*dnxi_inf(20,isf) +! + dxei = x01*dnei_inf( 1,isf) + x02*dnei_inf( 2,isf) & + & + x03*dnei_inf( 3,isf) + x04*dnei_inf( 4,isf) & + & + x05*dnei_inf( 5,isf) + x06*dnei_inf( 6,isf) & + & + x07*dnei_inf( 7,isf) + x08*dnei_inf( 8,isf) & + & + x09*dnei_inf( 9,isf) + x10*dnei_inf(10,isf) & + & + x11*dnei_inf(11,isf) + x12*dnei_inf(12,isf) & + & + x13*dnei_inf(13,isf) + x14*dnei_inf(14,isf) & + & + x15*dnei_inf(15,isf) + x16*dnei_inf(16,isf) & + & + x17*dnei_inf(17,isf) + x18*dnei_inf(18,isf) & + & + x19*dnei_inf(19,isf) + x20*dnei_inf(20,isf) +! + dxzi = x01*dnzi_inf( 1,isf) + x02*dnzi_inf( 2,isf) & + & + x03*dnzi_inf( 3,isf) + x04*dnzi_inf( 4,isf) & + & + x05*dnzi_inf( 5,isf) + x06*dnzi_inf( 6,isf) & + & + x07*dnzi_inf( 7,isf) + x08*dnzi_inf( 8,isf) & + & + x09*dnzi_inf( 9,isf) + x10*dnzi_inf(10,isf) & + & + x11*dnzi_inf(11,isf) + x12*dnzi_inf(12,isf) & + & + x13*dnzi_inf(13,isf) + x14*dnzi_inf(14,isf) & + & + x15*dnzi_inf(15,isf) + x16*dnzi_inf(16,isf) & + & + x17*dnzi_inf(17,isf) + x18*dnzi_inf(18,isf) & + & + x19*dnzi_inf(19,isf) + x20*dnzi_inf(20,isf) +! +! + dyxi = y01*dnxi_inf( 1,isf) + y02*dnxi_inf( 2,isf) & + & + y03*dnxi_inf( 3,isf) + y04*dnxi_inf( 4,isf) & + & + y05*dnxi_inf( 5,isf) + y06*dnxi_inf( 6,isf) & + & + y07*dnxi_inf( 7,isf) + y08*dnxi_inf( 8,isf) & + & + y09*dnxi_inf( 9,isf) + y10*dnxi_inf(10,isf) & + & + y11*dnxi_inf(11,isf) + y12*dnxi_inf(12,isf) & + & + y13*dnxi_inf(13,isf) + y14*dnxi_inf(14,isf) & + & + y15*dnxi_inf(15,isf) + y16*dnxi_inf(16,isf) & + & + y17*dnxi_inf(17,isf) + y18*dnxi_inf(18,isf) & + & + y19*dnxi_inf(19,isf) + y20*dnxi_inf(20,isf) +! + dyei = y01*dnei_inf( 1,isf) + y02*dnei_inf( 2,isf) & + & + y03*dnei_inf( 3,isf) + y04*dnei_inf( 4,isf) & + & + y05*dnei_inf( 5,isf) + y06*dnei_inf( 6,isf) & + & + y07*dnei_inf( 7,isf) + y08*dnei_inf( 8,isf) & + & + y09*dnei_inf( 9,isf) + y10*dnei_inf(10,isf) & + & + y11*dnei_inf(11,isf) + y12*dnei_inf(12,isf) & + & + y13*dnei_inf(13,isf) + y14*dnei_inf(14,isf) & + & + y15*dnei_inf(15,isf) + y16*dnei_inf(16,isf) & + & + y17*dnei_inf(17,isf) + y18*dnei_inf(18,isf) & + & + y19*dnei_inf(19,isf) + y20*dnei_inf(20,isf) +! + dyzi = y01*dnzi_inf( 1,isf) + y02*dnzi_inf( 2,isf) & + & + y03*dnzi_inf( 3,isf) + y04*dnzi_inf( 4,isf) & + & + y05*dnzi_inf( 5,isf) + y06*dnzi_inf( 6,isf) & + & + y07*dnzi_inf( 7,isf) + y08*dnzi_inf( 8,isf) & + & + y09*dnzi_inf( 9,isf) + y10*dnzi_inf(10,isf) & + & + y11*dnzi_inf(11,isf) + y12*dnzi_inf(12,isf) & + & + y13*dnzi_inf(13,isf) + y14*dnzi_inf(14,isf) & + & + y15*dnzi_inf(15,isf) + y16*dnzi_inf(16,isf) & + & + y17*dnzi_inf(17,isf) + y18*dnzi_inf(18,isf) & + & + y19*dnzi_inf(19,isf) + y20*dnzi_inf(20,isf) +! +! + dzxi = z01*dnxi_inf( 1,isf) + z02*dnxi_inf( 2,isf) & + & + z03*dnxi_inf( 3,isf) + z04*dnxi_inf( 4,isf) & + & + z05*dnxi_inf( 5,isf) + z06*dnxi_inf( 6,isf) & + & + z07*dnxi_inf( 7,isf) + z08*dnxi_inf( 8,isf) & + & + z09*dnxi_inf( 9,isf) + z10*dnxi_inf(10,isf) & + & + z11*dnxi_inf(11,isf) + z12*dnxi_inf(12,isf) & + & + z13*dnxi_inf(13,isf) + z14*dnxi_inf(14,isf) & + & + z15*dnxi_inf(15,isf) + z16*dnxi_inf(16,isf) & + & + z17*dnxi_inf(17,isf) + z18*dnxi_inf(18,isf) & + & + z19*dnxi_inf(19,isf) + z20*dnxi_inf(20,isf) +! + dzei = z01*dnei_inf( 1,isf) + z02*dnei_inf( 2,isf) & + & + z03*dnei_inf( 3,isf) + z04*dnei_inf( 4,isf) & + & + z05*dnei_inf( 5,isf) + z06*dnei_inf( 6,isf) & + & + z07*dnei_inf( 7,isf) + z08*dnei_inf( 8,isf) & + & + z09*dnei_inf( 9,isf) + z10*dnei_inf(10,isf) & + & + z11*dnei_inf(11,isf) + z12*dnei_inf(12,isf) & + & + z13*dnei_inf(13,isf) + z14*dnei_inf(14,isf) & + & + z15*dnei_inf(15,isf) + z16*dnei_inf(16,isf) & + & + z17*dnei_inf(17,isf) + z18*dnei_inf(18,isf) & + & + z19*dnei_inf(19,isf) + z20*dnei_inf(20,isf) +! + dzzi = z01*dnzi_inf( 1,isf) + z02*dnzi_inf( 2,isf) & + & + z03*dnzi_inf( 3,isf) + z04*dnzi_inf( 4,isf) & + & + z05*dnzi_inf( 5,isf) + z06*dnzi_inf( 6,isf) & + & + z07*dnzi_inf( 7,isf) + z08*dnzi_inf( 8,isf) & + & + z09*dnzi_inf( 9,isf) + z10*dnzi_inf(10,isf) & + & + z11*dnzi_inf(11,isf) + z12*dnzi_inf(12,isf) & + & + z13*dnzi_inf(13,isf) + z14*dnzi_inf(14,isf) & + & + z15*dnzi_inf(15,isf) + z16*dnzi_inf(16,isf) & + & + z17*dnzi_inf(17,isf) + z18*dnzi_inf(18,isf) & + & + z19*dnzi_inf(19,isf) + z20*dnzi_inf(20,isf) +! +! +! + xj11 = dyei*dzzi - dyzi*dzei + xj12 = dyzi*dzxi - dyxi*dzzi + xj13 = dyxi*dzei - dyei*dzxi +! + xj21 = dzei*dxzi - dzzi*dxei + xj22 = dzzi*dxxi - dzxi*dxzi + xj23 = dzxi*dxei - dzei*dxxi +! + xj31 = dxei*dyzi - dxzi*dyei + xj32 = dxzi*dyxi - dxxi*dyzi + xj33 = dxxi*dyei - dxei*dyxi +! +! + xjac(iele) = dxxi*dyei*dzzi & + & + dxei*dyzi*dzxi & + & + dxzi*dyxi*dzei & + & - ( dxzi*dyei*dzxi & + & + dxxi*dyzi*dzei & + & + dxei*dyxi*dzzi) +! + if (xjac(iele) .eq. 0.0d0) then + axjac(iele) = 1.0d+30 + else + axjac(iele) = 1.0d00 / xjac(iele) + end if +! +! + dxidx(iele) = xj11 * axjac(iele) + deidx(iele) = xj12 * axjac(iele) + dzidx(iele) = xj13 * axjac(iele) +! + dxidy(iele) = xj21 * axjac(iele) + deidy(iele) = xj22 * axjac(iele) + dzidy(iele) = xj23 * axjac(iele) +! + dxidz(iele) = xj31 * axjac(iele) + deidz(iele) = xj32 * axjac(iele) + dzidz(iele) = xj33 * axjac(iele) +! +! + dnx(iele, 1)= (xj11*dnxi( 1) + xj12*dnei( 1) + xj13*dnzi( 1)) & + & * axjac(iele) + dnx(iele, 2)= (xj11*dnxi( 2) + xj12*dnei( 2) + xj13*dnzi( 2)) & + & * axjac(iele) + dnx(iele, 3)= (xj11*dnxi( 3) + xj12*dnei( 3) + xj13*dnzi( 3)) & + & * axjac(iele) + dnx(iele, 4)= (xj11*dnxi( 4) + xj12*dnei( 4) + xj13*dnzi( 4)) & + & * axjac(iele) + dnx(iele, 5)= (xj11*dnxi( 5) + xj12*dnei( 5) + xj13*dnzi( 5)) & + & * axjac(iele) + dnx(iele, 6)= (xj11*dnxi( 6) + xj12*dnei( 6) + xj13*dnzi( 6)) & + & * axjac(iele) + dnx(iele, 7)= (xj11*dnxi( 7) + xj12*dnei( 7) + xj13*dnzi( 7)) & + & * axjac(iele) + dnx(iele, 8)= (xj11*dnxi( 8) + xj12*dnei( 8) + xj13*dnzi( 8)) & + & * axjac(iele) + dnx(iele, 9)= (xj11*dnxi( 9) + xj12*dnei( 9) + xj13*dnzi( 9)) & + & * axjac(iele) + dnx(iele,10)= (xj11*dnxi(10) + xj12*dnei(10) + xj13*dnzi(10)) & + & * axjac(iele) + dnx(iele,11)= (xj11*dnxi(11) + xj12*dnei(11) + xj13*dnzi(11)) & + & * axjac(iele) + dnx(iele,12)= (xj11*dnxi(12) + xj12*dnei(12) + xj13*dnzi(12)) & + & * axjac(iele) + dnx(iele,13)= (xj11*dnxi(13) + xj12*dnei(13) + xj13*dnzi(13)) & + & * axjac(iele) + dnx(iele,14)= (xj11*dnxi(14) + xj12*dnei(14) + xj13*dnzi(14)) & + & * axjac(iele) + dnx(iele,15)= (xj11*dnxi(15) + xj12*dnei(15) + xj13*dnzi(15)) & + & * axjac(iele) + dnx(iele,16)= (xj11*dnxi(16) + xj12*dnei(16) + xj13*dnzi(16)) & + & * axjac(iele) + dnx(iele,17)= (xj11*dnxi(17) + xj12*dnei(17) + xj13*dnzi(17)) & + & * axjac(iele) + dnx(iele,18)= (xj11*dnxi(18) + xj12*dnei(18) + xj13*dnzi(18)) & + & * axjac(iele) + dnx(iele,19)= (xj11*dnxi(19) + xj12*dnei(19) + xj13*dnzi(19)) & + & * axjac(iele) + dnx(iele,20)= (xj11*dnxi(20) + xj12*dnei(20) + xj13*dnzi(20)) & + & * axjac(iele) +! + dny(iele, 1)= (xj21*dnxi( 1) + xj22*dnei( 1) + xj23*dnzi( 1)) & + & * axjac(iele) + dny(iele, 2)= (xj21*dnxi( 2) + xj22*dnei( 2) + xj23*dnzi( 2)) & + & * axjac(iele) + dny(iele, 3)= (xj21*dnxi( 3) + xj22*dnei( 3) + xj23*dnzi( 3)) & + & * axjac(iele) + dny(iele, 4)= (xj21*dnxi( 4) + xj22*dnei( 4) + xj23*dnzi( 4)) & + & * axjac(iele) + dny(iele, 5)= (xj21*dnxi( 5) + xj22*dnei( 5) + xj23*dnzi( 5)) & + & * axjac(iele) + dny(iele, 6)= (xj21*dnxi( 6) + xj22*dnei( 6) + xj23*dnzi( 6)) & + & * axjac(iele) + dny(iele, 7)= (xj21*dnxi( 7) + xj22*dnei( 7) + xj23*dnzi( 7)) & + & * axjac(iele) + dny(iele, 8)= (xj21*dnxi( 8) + xj22*dnei( 8) + xj23*dnzi( 8)) & + & * axjac(iele) + dny(iele, 9)= (xj21*dnxi( 9) + xj22*dnei( 9) + xj23*dnzi( 9)) & + & * axjac(iele) + dny(iele,10)= (xj21*dnxi(10) + xj22*dnei(10) + xj23*dnzi(10)) & + & * axjac(iele) + dny(iele,11)= (xj21*dnxi(11) + xj22*dnei(11) + xj23*dnzi(11)) & + & * axjac(iele) + dny(iele,12)= (xj21*dnxi(12) + xj22*dnei(12) + xj23*dnzi(12)) & + & * axjac(iele) + dny(iele,13)= (xj21*dnxi(13) + xj22*dnei(13) + xj23*dnzi(13)) & + & * axjac(iele) + dny(iele,14)= (xj21*dnxi(14) + xj22*dnei(14) + xj23*dnzi(14)) & + & * axjac(iele) + dny(iele,15)= (xj21*dnxi(15) + xj22*dnei(15) + xj23*dnzi(15)) & + & * axjac(iele) + dny(iele,16)= (xj21*dnxi(16) + xj22*dnei(16) + xj23*dnzi(16)) & + & * axjac(iele) + dny(iele,17)= (xj21*dnxi(17) + xj22*dnei(17) + xj23*dnzi(17)) & + & * axjac(iele) + dny(iele,18)= (xj21*dnxi(18) + xj22*dnei(18) + xj23*dnzi(18)) & + & * axjac(iele) + dny(iele,19)= (xj21*dnxi(19) + xj22*dnei(19) + xj23*dnzi(19)) & + & * axjac(iele) + dny(iele,20)= (xj21*dnxi(20) + xj22*dnei(20) + xj23*dnzi(20)) & + & * axjac(iele) +! + dnz(iele, 1)= (xj31*dnxi( 1) + xj32*dnei( 1) + xj33*dnzi( 1)) & + & * axjac(iele) + dnz(iele, 2)= (xj31*dnxi( 2) + xj32*dnei( 2) + xj33*dnzi( 2)) & + & * axjac(iele) + dnz(iele, 3)= (xj31*dnxi( 3) + xj32*dnei( 3) + xj33*dnzi( 3)) & + & * axjac(iele) + dnz(iele, 4)= (xj31*dnxi( 4) + xj32*dnei( 4) + xj33*dnzi( 4)) & + & * axjac(iele) + dnz(iele, 5)= (xj31*dnxi( 5) + xj32*dnei( 5) + xj33*dnzi( 5)) & + & * axjac(iele) + dnz(iele, 6)= (xj31*dnxi( 6) + xj32*dnei( 6) + xj33*dnzi( 6)) & + & * axjac(iele) + dnz(iele, 7)= (xj31*dnxi( 7) + xj32*dnei( 7) + xj33*dnzi( 7)) & + & * axjac(iele) + dnz(iele, 8)= (xj31*dnxi( 8) + xj32*dnei( 8) + xj33*dnzi( 8)) & + & * axjac(iele) + dnz(iele, 9)= (xj31*dnxi( 9) + xj32*dnei( 9) + xj33*dnzi( 9)) & + & * axjac(iele) + dnz(iele,10)= (xj31*dnxi(10) + xj32*dnei(10) + xj33*dnzi(10)) & + & * axjac(iele) + dnz(iele,11)= (xj31*dnxi(11) + xj32*dnei(11) + xj33*dnzi(11)) & + & * axjac(iele) + dnz(iele,12)= (xj31*dnxi(12) + xj32*dnei(12) + xj33*dnzi(12)) & + & * axjac(iele) + dnz(iele,13)= (xj31*dnxi(13) + xj32*dnei(13) + xj33*dnzi(13)) & + & * axjac(iele) + dnz(iele,14)= (xj31*dnxi(14) + xj32*dnei(14) + xj33*dnzi(14)) & + & * axjac(iele) + dnz(iele,15)= (xj31*dnxi(15) + xj32*dnei(15) + xj33*dnzi(15)) & + & * axjac(iele) + dnz(iele,16)= (xj31*dnxi(16) + xj32*dnei(16) + xj33*dnzi(16)) & + & * axjac(iele) + dnz(iele,17)= (xj31*dnxi(17) + xj32*dnei(17) + xj33*dnzi(17)) & + & * axjac(iele) + dnz(iele,18)= (xj31*dnxi(18) + xj32*dnei(18) + xj33*dnzi(18)) & + & * axjac(iele) + dnz(iele,19)= (xj31*dnxi(19) + xj32*dnei(19) + xj33*dnzi(19)) & + & * axjac(iele) + dnz(iele,20)= (xj31*dnxi(20) + xj32*dnei(20) + xj33*dnzi(20)) & + & * axjac(iele) +! + end do + end do +!$omp end parallel do +! + end do +! + end subroutine s_cal_jacobian_3d_inf_8_20 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_3d_inf_l_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_lag.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_lag.f90 new file mode 100644 index 00000000..de5df5c6 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_lag.f90 @@ -0,0 +1,615 @@ +! +! module cal_jacobian_3d_inf_lag +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! +! subroutine s_cal_jacobian_3d_inf_27(numnod, numele, & +! & np_smp, ie, xx, num_surf_bc, surf_item, & +! & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & +! & isurf_grp_smp_stack, xjac, axjac, dnx, dny, dnz, & +! & dxidx, deidx, dzidx, dxidy, deidy, dzidy, & +! & dxidz, deidz, dzidz, dnxi, dnei, dnzi, & +! & dnxi_inf, dnei_inf, dnzi_inf) +! + module cal_jacobian_3d_inf_lag +! + use m_precision +! + use m_geometry_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_3d_inf_27(numnod, numele, & + & np_smp, ie, xx, num_surf_bc, surf_item, & + & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & + & isurf_grp_smp_stack, xjac, axjac, dnx, dny, dnz, & + & dxidx, deidx, dzidx, dxidy, deidy, dzidy, & + & dxidz, deidz, dzidz, dnxi, dnei, dnzi, & + & dnxi_inf, dnei_inf, dnzi_inf) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod, numele + integer(kind = kint), intent(in) :: ie(numele, num_t_lag) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer (kind=kint), intent(in) :: ngrp_sf_infty + integer (kind=kint), intent(in) :: id_grp_sf_infty(ngrp_sf_infty) +! + integer(kind = kint), intent(in) :: np_smp, num_surf_smp + integer(kind = kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_t_lag) + real(kind = kreal), intent(in) :: dnei(num_t_lag) + real(kind = kreal), intent(in) :: dnzi(num_t_lag) +! + real(kind = kreal), intent(in) & + & :: dnxi_inf(num_t_lag,nsurf_4_ele) + real(kind = kreal), intent(in) & + & :: dnei_inf(num_t_lag,nsurf_4_ele) + real(kind = kreal), intent(in) & + & :: dnzi_inf(num_t_lag,nsurf_4_ele) +! + real(kind = kreal), intent(inout) :: dxidx(numele) + real(kind = kreal), intent(inout) :: deidx(numele) + real(kind = kreal), intent(inout) :: dzidx(numele) + real(kind = kreal), intent(inout) :: dxidy(numele) + real(kind = kreal), intent(inout) :: deidy(numele) + real(kind = kreal), intent(inout) :: dzidy(numele) + real(kind = kreal), intent(inout) :: dxidz(numele) + real(kind = kreal), intent(inout) :: deidz(numele) + real(kind = kreal), intent(inout) :: dzidz(numele) +! + real(kind = kreal), intent(inout) :: xjac(numele) + real(kind = kreal), intent(inout) :: axjac(numele) + real(kind = kreal), intent(inout) :: dnx(numele,num_t_lag) + real(kind = kreal), intent(inout) :: dny(numele,num_t_lag) + real(kind = kreal), intent(inout) :: dnz(numele,num_t_lag) +! + integer(kind = kint) :: i, ip, ist, ied, iele + integer(kind = kint) :: igrp, id_sf, inum, isf +! + real(kind = kreal) :: dxxi, dxei, dxzi + real(kind = kreal) :: dyxi, dyei, dyzi + real(kind = kreal) :: dzxi, dzei, dzzi + real(kind = kreal) :: xj11, xj12, xj13 + real(kind = kreal) :: xj21, xj22, xj23 + real(kind = kreal) :: xj31, xj32, xj33 +! + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 + integer(kind = kint) :: i9, i10, i11, i12, i13, i14, i15, i16 + integer(kind = kint) :: i17, i18, i19, i20, i21, i22, i23, i24 + integer(kind = kint) :: i25, i26, i27 +! +! + do i = 1, ngrp_sf_infty + igrp = id_grp_sf_infty(i) +! +!$omp parallel do private & +!$omp& (ist,ied,id_sf,inum,iele,isf,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10, & +!$omp& i11,i12,i13,i14,i15,i16,i17,i18,i19,i20,i21,i22,i23,i24, & +!$omp& i25,i26,i27,dxxi,dxei,dxzi,dyxi,dyei,dyzi,dzxi,dzei,dzzi, & +!$omp& xj11,xj12,xj13,xj21,xj22,xj23,xj31,xj32,xj33) + do ip = 1, np_smp + id_sf = np_smp*(igrp-1) + ip + ist = isurf_grp_smp_stack(id_sf-1)+1 + ied = isurf_grp_smp_stack(id_sf) +! +!cdir nodep noloopchg + do inum = ist, ied + iele = surf_item(1,inum) + isf = surf_item(2,inum) +! + i1 = ie(iele, 1) + i2 = ie(iele, 2) + i3 = ie(iele, 3) + i4 = ie(iele, 4) + i5 = ie(iele, 5) + i6 = ie(iele, 6) + i7 = ie(iele, 7) + i8 = ie(iele, 8) + i9 = ie(iele, 9) + i10 = ie(iele,10) + i11 = ie(iele,11) + i12 = ie(iele,12) + i13 = ie(iele,13) + i14 = ie(iele,14) + i15 = ie(iele,15) + i16 = ie(iele,16) + i17 = ie(iele,17) + i18 = ie(iele,18) + i19 = ie(iele,19) + i20 = ie(iele,20) + i20 = ie(iele,20) + i21 = ie(iele,21) + i22 = ie(iele,22) + i23 = ie(iele,23) + i24 = ie(iele,24) + i25 = ie(iele,25) + i26 = ie(iele,26) + i27 = ie(iele,27) +! + dxxi = xx(i1, 1)*dnxi_inf( 1,isf) & + & + xx(i2, 1)*dnxi_inf( 2,isf) & + & + xx(i3, 1)*dnxi_inf( 3,isf) & + & + xx(i4, 1)*dnxi_inf( 4,isf) & + & + xx(i5, 1)*dnxi_inf( 5,isf) & + & + xx(i6, 1)*dnxi_inf( 6,isf) & + & + xx(i7, 1)*dnxi_inf( 7,isf) & + & + xx(i8, 1)*dnxi_inf( 8,isf) & + & + xx(i9, 1)*dnxi_inf( 9,isf) & + & + xx(i10,1)*dnxi_inf(10,isf) & + & + xx(i11,1)*dnxi_inf(11,isf) & + & + xx(i12,1)*dnxi_inf(12,isf) & + & + xx(i13,1)*dnxi_inf(13,isf) & + & + xx(i14,1)*dnxi_inf(14,isf) & + & + xx(i15,1)*dnxi_inf(15,isf) & + & + xx(i16,1)*dnxi_inf(16,isf) & + & + xx(i17,1)*dnxi_inf(17,isf) & + & + xx(i18,1)*dnxi_inf(18,isf) & + & + xx(i19,1)*dnxi_inf(19,isf) & + & + xx(i20,1)*dnxi_inf(20,isf) & + & + xx(i21,1)*dnxi_inf(21,isf) & + & + xx(i22,1)*dnxi_inf(22,isf) & + & + xx(i23,1)*dnxi_inf(23,isf) & + & + xx(i24,1)*dnxi_inf(24,isf) & + & + xx(i25,1)*dnxi_inf(25,isf) & + & + xx(i26,1)*dnxi_inf(26,isf) & + & + xx(i27,1)*dnxi_inf(27,isf) +! + dxei = xx(i1, 1)*dnei_inf( 1,isf) & + & + xx(i2, 1)*dnei_inf( 2,isf) & + & + xx(i3, 1)*dnei_inf( 3,isf) & + & + xx(i4, 1)*dnei_inf( 4,isf) & + & + xx(i5, 1)*dnei_inf( 5,isf) & + & + xx(i6, 1)*dnei_inf( 6,isf) & + & + xx(i7, 1)*dnei_inf( 7,isf) & + & + xx(i8, 1)*dnei_inf( 8,isf) & + & + xx(i9, 1)*dnei_inf( 9,isf) & + & + xx(i10,1)*dnei_inf(10,isf) & + & + xx(i11,1)*dnei_inf(11,isf) & + & + xx(i12,1)*dnei_inf(12,isf) & + & + xx(i13,1)*dnei_inf(13,isf) & + & + xx(i14,1)*dnei_inf(14,isf) & + & + xx(i15,1)*dnei_inf(15,isf) & + & + xx(i16,1)*dnei_inf(16,isf) & + & + xx(i17,1)*dnei_inf(17,isf) & + & + xx(i18,1)*dnei_inf(18,isf) & + & + xx(i19,1)*dnei_inf(19,isf) & + & + xx(i20,1)*dnei_inf(20,isf) & + & + xx(i21,1)*dnei_inf(21,isf) & + & + xx(i22,1)*dnei_inf(22,isf) & + & + xx(i23,1)*dnei_inf(23,isf) & + & + xx(i24,1)*dnei_inf(24,isf) & + & + xx(i25,1)*dnei_inf(25,isf) & + & + xx(i26,1)*dnei_inf(26,isf) & + & + xx(i27,1)*dnei_inf(27,isf) +! + dxzi = xx(i1, 1)*dnzi_inf( 1,isf) & + & + xx(i2, 1)*dnzi_inf( 2,isf) & + & + xx(i3, 1)*dnzi_inf( 3,isf) & + & + xx(i4, 1)*dnzi_inf( 4,isf) & + & + xx(i5, 1)*dnzi_inf( 5,isf) & + & + xx(i6, 1)*dnzi_inf( 6,isf) & + & + xx(i7, 1)*dnzi_inf( 7,isf) & + & + xx(i8, 1)*dnzi_inf( 8,isf) & + & + xx(i9, 1)*dnzi_inf( 9,isf) & + & + xx(i10,1)*dnzi_inf(10,isf) & + & + xx(i11,1)*dnzi_inf(11,isf) & + & + xx(i12,1)*dnzi_inf(12,isf) & + & + xx(i13,1)*dnzi_inf(13,isf) & + & + xx(i14,1)*dnzi_inf(14,isf) & + & + xx(i15,1)*dnzi_inf(15,isf) & + & + xx(i16,1)*dnzi_inf(16,isf) & + & + xx(i17,1)*dnzi_inf(17,isf) & + & + xx(i18,1)*dnzi_inf(18,isf) & + & + xx(i19,1)*dnzi_inf(19,isf) & + & + xx(i20,1)*dnzi_inf(20,isf) & + & + xx(i21,1)*dnzi_inf(21,isf) & + & + xx(i22,1)*dnzi_inf(22,isf) & + & + xx(i23,1)*dnzi_inf(23,isf) & + & + xx(i24,1)*dnzi_inf(24,isf) & + & + xx(i25,1)*dnzi_inf(25,isf) & + & + xx(i26,1)*dnzi_inf(26,isf) & + & + xx(i27,1)*dnzi_inf(27,isf) +! +! + dyxi = xx(i1, 2)*dnxi_inf( 1,isf) & + & + xx(i2, 2)*dnxi_inf( 2,isf) & + & + xx(i3, 2)*dnxi_inf( 3,isf) & + & + xx(i4, 2)*dnxi_inf( 4,isf) & + & + xx(i5, 2)*dnxi_inf( 5,isf) & + & + xx(i6, 2)*dnxi_inf( 6,isf) & + & + xx(i7, 2)*dnxi_inf( 7,isf) & + & + xx(i8, 2)*dnxi_inf( 8,isf) & + & + xx(i9, 2)*dnxi_inf( 9,isf) & + & + xx(i10,2)*dnxi_inf(10,isf) & + & + xx(i11,2)*dnxi_inf(11,isf) & + & + xx(i12,2)*dnxi_inf(12,isf) & + & + xx(i13,2)*dnxi_inf(13,isf) & + & + xx(i14,2)*dnxi_inf(14,isf) & + & + xx(i15,2)*dnxi_inf(15,isf) & + & + xx(i16,2)*dnxi_inf(16,isf) & + & + xx(i17,2)*dnxi_inf(17,isf) & + & + xx(i18,2)*dnxi_inf(18,isf) & + & + xx(i19,2)*dnxi_inf(19,isf) & + & + xx(i20,2)*dnxi_inf(20,isf) & + & + xx(i21,2)*dnxi_inf(21,isf) & + & + xx(i22,2)*dnxi_inf(22,isf) & + & + xx(i23,2)*dnxi_inf(23,isf) & + & + xx(i24,2)*dnxi_inf(24,isf) & + & + xx(i25,2)*dnxi_inf(25,isf) & + & + xx(i26,2)*dnxi_inf(26,isf) & + & + xx(i27,2)*dnxi_inf(27,isf) +! + dyei = xx(i1, 2)*dnei_inf( 1,isf) & + & + xx(i2, 2)*dnei_inf( 2,isf) & + & + xx(i3, 2)*dnei_inf( 3,isf) & + & + xx(i4, 2)*dnei_inf( 4,isf) & + & + xx(i5, 2)*dnei_inf( 5,isf) & + & + xx(i6, 2)*dnei_inf( 6,isf) & + & + xx(i7, 2)*dnei_inf( 7,isf) & + & + xx(i8, 2)*dnei_inf( 8,isf) & + & + xx(i9, 2)*dnei_inf( 9,isf) & + & + xx(i10,2)*dnei_inf(10,isf) & + & + xx(i11,2)*dnei_inf(11,isf) & + & + xx(i12,2)*dnei_inf(12,isf) & + & + xx(i13,2)*dnei_inf(13,isf) & + & + xx(i14,2)*dnei_inf(14,isf) & + & + xx(i15,2)*dnei_inf(15,isf) & + & + xx(i16,2)*dnei_inf(16,isf) & + & + xx(i17,2)*dnei_inf(17,isf) & + & + xx(i18,2)*dnei_inf(18,isf) & + & + xx(i19,2)*dnei_inf(19,isf) & + & + xx(i20,2)*dnei_inf(20,isf) & + & + xx(i21,2)*dnei_inf(21,isf) & + & + xx(i22,2)*dnei_inf(22,isf) & + & + xx(i23,2)*dnei_inf(23,isf) & + & + xx(i24,2)*dnei_inf(24,isf) & + & + xx(i25,2)*dnei_inf(25,isf) & + & + xx(i26,2)*dnei_inf(26,isf) & + & + xx(i27,2)*dnei_inf(27,isf) +! + dyzi = xx(i1, 2)*dnzi_inf( 1,isf) & + & + xx(i2, 2)*dnzi_inf( 2,isf) & + & + xx(i3, 2)*dnzi_inf( 3,isf) & + & + xx(i4, 2)*dnzi_inf( 4,isf) & + & + xx(i5, 2)*dnzi_inf( 5,isf) & + & + xx(i6, 2)*dnzi_inf( 6,isf) & + & + xx(i7, 2)*dnzi_inf( 7,isf) & + & + xx(i8, 2)*dnzi_inf( 8,isf) & + & + xx(i9, 2)*dnzi_inf( 9,isf) & + & + xx(i10,2)*dnzi_inf(10,isf) & + & + xx(i11,2)*dnzi_inf(11,isf) & + & + xx(i12,2)*dnzi_inf(12,isf) & + & + xx(i13,2)*dnzi_inf(13,isf) & + & + xx(i14,2)*dnzi_inf(14,isf) & + & + xx(i15,2)*dnzi_inf(15,isf) & + & + xx(i16,2)*dnzi_inf(16,isf) & + & + xx(i17,2)*dnzi_inf(17,isf) & + & + xx(i18,2)*dnzi_inf(18,isf) & + & + xx(i19,2)*dnzi_inf(19,isf) & + & + xx(i20,2)*dnzi_inf(20,isf) & + & + xx(i21,2)*dnzi_inf(21,isf) & + & + xx(i22,2)*dnzi_inf(22,isf) & + & + xx(i23,2)*dnzi_inf(23,isf) & + & + xx(i24,2)*dnzi_inf(24,isf) & + & + xx(i25,2)*dnzi_inf(25,isf) & + & + xx(i26,2)*dnzi_inf(26,isf) & + & + xx(i27,2)*dnzi_inf(27,isf) +! +! + dzxi = xx(i1, 3)*dnxi_inf( 1,isf) & + & + xx(i2, 3)*dnxi_inf( 2,isf) & + & + xx(i3, 3)*dnxi_inf( 3,isf) & + & + xx(i4, 3)*dnxi_inf( 4,isf) & + & + xx(i5, 3)*dnxi_inf( 5,isf) & + & + xx(i6, 3)*dnxi_inf( 6,isf) & + & + xx(i7, 3)*dnxi_inf( 7,isf) & + & + xx(i8, 3)*dnxi_inf( 8,isf) & + & + xx(i9, 3)*dnxi_inf( 9,isf) & + & + xx(i10,3)*dnxi_inf(10,isf) & + & + xx(i11,3)*dnxi_inf(11,isf) & + & + xx(i12,3)*dnxi_inf(12,isf) & + & + xx(i13,3)*dnxi_inf(13,isf) & + & + xx(i14,3)*dnxi_inf(14,isf) & + & + xx(i15,3)*dnxi_inf(15,isf) & + & + xx(i16,3)*dnxi_inf(16,isf) & + & + xx(i17,3)*dnxi_inf(17,isf) & + & + xx(i18,3)*dnxi_inf(18,isf) & + & + xx(i19,3)*dnxi_inf(19,isf) & + & + xx(i20,3)*dnxi_inf(20,isf) & + & + xx(i21,3)*dnxi_inf(21,isf) & + & + xx(i22,3)*dnxi_inf(22,isf) & + & + xx(i23,3)*dnxi_inf(23,isf) & + & + xx(i24,3)*dnxi_inf(24,isf) & + & + xx(i25,3)*dnxi_inf(25,isf) & + & + xx(i26,3)*dnxi_inf(26,isf) & + & + xx(i27,3)*dnxi_inf(27,isf) +! + dzei = xx(i1, 3)*dnei_inf( 1,isf) & + & + xx(i2, 3)*dnei_inf( 2,isf) & + & + xx(i3, 3)*dnei_inf( 3,isf) & + & + xx(i4, 3)*dnei_inf( 4,isf) & + & + xx(i5, 3)*dnei_inf( 5,isf) & + & + xx(i6, 3)*dnei_inf( 6,isf) & + & + xx(i7, 3)*dnei_inf( 7,isf) & + & + xx(i8, 3)*dnei_inf( 8,isf) & + & + xx(i9, 3)*dnei_inf( 9,isf) & + & + xx(i10,3)*dnei_inf(10,isf) & + & + xx(i11,3)*dnei_inf(11,isf) & + & + xx(i12,3)*dnei_inf(12,isf) & + & + xx(i13,3)*dnei_inf(13,isf) & + & + xx(i14,3)*dnei_inf(14,isf) & + & + xx(i15,3)*dnei_inf(15,isf) & + & + xx(i16,3)*dnei_inf(16,isf) & + & + xx(i17,3)*dnei_inf(17,isf) & + & + xx(i18,3)*dnei_inf(18,isf) & + & + xx(i19,3)*dnei_inf(19,isf) & + & + xx(i20,3)*dnei_inf(20,isf) & + & + xx(i21,3)*dnei_inf(21,isf) & + & + xx(i22,3)*dnei_inf(22,isf) & + & + xx(i23,3)*dnei_inf(23,isf) & + & + xx(i24,3)*dnei_inf(24,isf) & + & + xx(i25,3)*dnei_inf(25,isf) & + & + xx(i26,3)*dnei_inf(26,isf) & + & + xx(i27,3)*dnei_inf(27,isf) +! + dzzi = xx(i1, 3)*dnzi_inf( 1,isf) & + & + xx(i2, 3)*dnzi_inf( 2,isf) & + & + xx(i3, 3)*dnzi_inf( 3,isf) & + & + xx(i4, 3)*dnzi_inf( 4,isf) & + & + xx(i5, 3)*dnzi_inf( 5,isf) & + & + xx(i6, 3)*dnzi_inf( 6,isf) & + & + xx(i7, 3)*dnzi_inf( 7,isf) & + & + xx(i8, 3)*dnzi_inf( 8,isf) & + & + xx(i9, 3)*dnzi_inf( 9,isf) & + & + xx(i10,3)*dnzi_inf(10,isf) & + & + xx(i11,3)*dnzi_inf(11,isf) & + & + xx(i12,3)*dnzi_inf(12,isf) & + & + xx(i13,3)*dnzi_inf(13,isf) & + & + xx(i14,3)*dnzi_inf(14,isf) & + & + xx(i15,3)*dnzi_inf(15,isf) & + & + xx(i16,3)*dnzi_inf(16,isf) & + & + xx(i17,3)*dnzi_inf(17,isf) & + & + xx(i18,3)*dnzi_inf(18,isf) & + & + xx(i19,3)*dnzi_inf(19,isf) & + & + xx(i20,3)*dnzi_inf(20,isf) & + & + xx(i21,3)*dnzi_inf(21,isf) & + & + xx(i22,3)*dnzi_inf(22,isf) & + & + xx(i23,3)*dnzi_inf(23,isf) & + & + xx(i24,3)*dnzi_inf(24,isf) & + & + xx(i25,3)*dnzi_inf(25,isf) & + & + xx(i26,3)*dnzi_inf(26,isf) & + & + xx(i27,3)*dnzi_inf(27,isf) +! +! +! + xj11 = dyei*dzzi - dyzi*dzei + xj12 = dyzi*dzxi - dyxi*dzzi + xj13 = dyxi*dzei - dyei*dzxi +! + xj21 = dzei*dxzi - dzzi*dxei + xj22 = dzzi*dxxi - dzxi*dxzi + xj23 = dzxi*dxei - dzei*dxxi +! + xj31 = dxei*dyzi - dxzi*dyei + xj32 = dxzi*dyxi - dxxi*dyzi + xj33 = dxxi*dyei - dxei*dyxi +! +! + xjac(iele) = dxxi*dyei*dzzi & + & + dxei*dyzi*dzxi & + & + dxzi*dyxi*dzei & + & - ( dxzi*dyei*dzxi & + & + dxxi*dyzi*dzei & + & + dxei*dyxi*dzzi) +! + if (xjac(iele) .eq. 0.0d0) then + axjac(iele) = 1.0d+30 + else + axjac(iele) = 1.0d00 / xjac(iele) + end if +! +! + dxidx(iele) = xj11 * axjac(iele) + deidx(iele) = xj12 * axjac(iele) + dzidx(iele) = xj13 * axjac(iele) +! + dxidy(iele) = xj21 * axjac(iele) + deidy(iele) = xj22 * axjac(iele) + dzidy(iele) = xj23 * axjac(iele) +! + dxidz(iele) = xj31 * axjac(iele) + deidz(iele) = xj32 * axjac(iele) + dzidz(iele) = xj33 * axjac(iele) +! +! + dnx(iele, 1)= (xj11*dnxi( 1) + xj12*dnei( 1) + xj13*dnzi( 1)) & + & * axjac(iele) + dnx(iele, 2)= (xj11*dnxi( 2) + xj12*dnei( 2) + xj13*dnzi( 2)) & + & * axjac(iele) + dnx(iele, 3)= (xj11*dnxi( 3) + xj12*dnei( 3) + xj13*dnzi( 3)) & + & * axjac(iele) + dnx(iele, 4)= (xj11*dnxi( 4) + xj12*dnei( 4) + xj13*dnzi( 4)) & + & * axjac(iele) + dnx(iele, 5)= (xj11*dnxi( 5) + xj12*dnei( 5) + xj13*dnzi( 5)) & + & * axjac(iele) + dnx(iele, 6)= (xj11*dnxi( 6) + xj12*dnei( 6) + xj13*dnzi( 6)) & + & * axjac(iele) + dnx(iele, 7)= (xj11*dnxi( 7) + xj12*dnei( 7) + xj13*dnzi( 7)) & + & * axjac(iele) + dnx(iele, 8)= (xj11*dnxi( 8) + xj12*dnei( 8) + xj13*dnzi( 8)) & + & * axjac(iele) + dnx(iele, 9)= (xj11*dnxi( 9) + xj12*dnei( 9) + xj13*dnzi( 9)) & + & * axjac(iele) + dnx(iele,10)= (xj11*dnxi(10) + xj12*dnei(10) + xj13*dnzi(10)) & + & * axjac(iele) + dnx(iele,11)= (xj11*dnxi(11) + xj12*dnei(11) + xj13*dnzi(11)) & + & * axjac(iele) + dnx(iele,12)= (xj11*dnxi(12) + xj12*dnei(12) + xj13*dnzi(12)) & + & * axjac(iele) + dnx(iele,13)= (xj11*dnxi(13) + xj12*dnei(13) + xj13*dnzi(13)) & + & * axjac(iele) + dnx(iele,14)= (xj11*dnxi(14) + xj12*dnei(14) + xj13*dnzi(14)) & + & * axjac(iele) + dnx(iele,15)= (xj11*dnxi(15) + xj12*dnei(15) + xj13*dnzi(15)) & + & * axjac(iele) + dnx(iele,16)= (xj11*dnxi(16) + xj12*dnei(16) + xj13*dnzi(16)) & + & * axjac(iele) + dnx(iele,17)= (xj11*dnxi(17) + xj12*dnei(17) + xj13*dnzi(17)) & + & * axjac(iele) + dnx(iele,18)= (xj11*dnxi(18) + xj12*dnei(18) + xj13*dnzi(18)) & + & * axjac(iele) + dnx(iele,19)= (xj11*dnxi(19) + xj12*dnei(19) + xj13*dnzi(19)) & + & * axjac(iele) + dnx(iele,20)= (xj11*dnxi(20) + xj12*dnei(20) + xj13*dnzi(20)) & + & * axjac(iele) + dnx(iele,21)= (xj11*dnxi(21) + xj12*dnei(21) + xj13*dnzi(21)) & + & * axjac(iele) + dnx(iele,22)= (xj11*dnxi(22) + xj12*dnei(22) + xj13*dnzi(22)) & + & * axjac(iele) + dnx(iele,23)= (xj11*dnxi(23) + xj12*dnei(23) + xj13*dnzi(23)) & + & * axjac(iele) + dnx(iele,24)= (xj11*dnxi(24) + xj12*dnei(24) + xj13*dnzi(24)) & + & * axjac(iele) + dnx(iele,25)= (xj11*dnxi(25) + xj12*dnei(25) + xj13*dnzi(25)) & + & * axjac(iele) + dnx(iele,26)= (xj11*dnxi(26) + xj12*dnei(26) + xj13*dnzi(26)) & + & * axjac(iele) + dnx(iele,27)= (xj11*dnxi(27) + xj12*dnei(27) + xj13*dnzi(27)) & + & * axjac(iele) +! + dny(iele, 1)= (xj21*dnxi( 1) + xj22*dnei( 1) + xj23*dnzi( 1)) & + & * axjac(iele) + dny(iele, 2)= (xj21*dnxi( 2) + xj22*dnei( 2) + xj23*dnzi( 2)) & + & * axjac(iele) + dny(iele, 3)= (xj21*dnxi( 3) + xj22*dnei( 3) + xj23*dnzi( 3)) & + & * axjac(iele) + dny(iele, 4)= (xj21*dnxi( 4) + xj22*dnei( 4) + xj23*dnzi( 4)) & + & * axjac(iele) + dny(iele, 5)= (xj21*dnxi( 5) + xj22*dnei( 5) + xj23*dnzi( 5)) & + & * axjac(iele) + dny(iele, 6)= (xj21*dnxi( 6) + xj22*dnei( 6) + xj23*dnzi( 6)) & + & * axjac(iele) + dny(iele, 7)= (xj21*dnxi( 7) + xj22*dnei( 7) + xj23*dnzi( 7)) & + & * axjac(iele) + dny(iele, 8)= (xj21*dnxi( 8) + xj22*dnei( 8) + xj23*dnzi( 8)) & + & * axjac(iele) + dny(iele, 9)= (xj21*dnxi( 9) + xj22*dnei( 9) + xj23*dnzi( 9)) & + & * axjac(iele) + dny(iele,10)= (xj21*dnxi(10) + xj22*dnei(10) + xj23*dnzi(10)) & + & * axjac(iele) + dny(iele,11)= (xj21*dnxi(11) + xj22*dnei(11) + xj23*dnzi(11)) & + & * axjac(iele) + dny(iele,12)= (xj21*dnxi(12) + xj22*dnei(12) + xj23*dnzi(12)) & + & * axjac(iele) + dny(iele,13)= (xj21*dnxi(13) + xj22*dnei(13) + xj23*dnzi(13)) & + & * axjac(iele) + dny(iele,14)= (xj21*dnxi(14) + xj22*dnei(14) + xj23*dnzi(14)) & + & * axjac(iele) + dny(iele,15)= (xj21*dnxi(15) + xj22*dnei(15) + xj23*dnzi(15)) & + & * axjac(iele) + dny(iele,16)= (xj21*dnxi(16) + xj22*dnei(16) + xj23*dnzi(16)) & + & * axjac(iele) + dny(iele,17)= (xj21*dnxi(17) + xj22*dnei(17) + xj23*dnzi(17)) & + & * axjac(iele) + dny(iele,18)= (xj21*dnxi(18) + xj22*dnei(18) + xj23*dnzi(18)) & + & * axjac(iele) + dny(iele,19)= (xj21*dnxi(19) + xj22*dnei(19) + xj23*dnzi(19)) & + & * axjac(iele) + dny(iele,20)= (xj21*dnxi(20) + xj22*dnei(20) + xj23*dnzi(20)) & + & * axjac(iele) + dny(iele,21)= (xj21*dnxi(21) + xj22*dnei(21) + xj23*dnzi(21)) & + & * axjac(iele) + dny(iele,22)= (xj21*dnxi(22) + xj22*dnei(22) + xj23*dnzi(22)) & + & * axjac(iele) + dny(iele,23)= (xj21*dnxi(23) + xj22*dnei(23) + xj23*dnzi(23)) & + & * axjac(iele) + dny(iele,24)= (xj21*dnxi(24) + xj22*dnei(24) + xj23*dnzi(24)) & + & * axjac(iele) + dny(iele,25)= (xj21*dnxi(25) + xj22*dnei(25) + xj23*dnzi(25)) & + & * axjac(iele) + dny(iele,26)= (xj21*dnxi(26) + xj22*dnei(26) + xj23*dnzi(26)) & + & * axjac(iele) + dny(iele,27)= (xj21*dnxi(27) + xj22*dnei(27) + xj23*dnzi(27)) & + & * axjac(iele) +! + dnz(iele, 1)= (xj31*dnxi( 1) + xj32*dnei( 1) + xj33*dnzi( 1)) & + & * axjac(iele) + dnz(iele, 2)= (xj31*dnxi( 2) + xj32*dnei( 2) + xj33*dnzi( 2)) & + & * axjac(iele) + dnz(iele, 3)= (xj31*dnxi( 3) + xj32*dnei( 3) + xj33*dnzi( 3)) & + & * axjac(iele) + dnz(iele, 4)= (xj31*dnxi( 4) + xj32*dnei( 4) + xj33*dnzi( 4)) & + & * axjac(iele) + dnz(iele, 5)= (xj31*dnxi( 5) + xj32*dnei( 5) + xj33*dnzi( 5)) & + & * axjac(iele) + dnz(iele, 6)= (xj31*dnxi( 6) + xj32*dnei( 6) + xj33*dnzi( 6)) & + & * axjac(iele) + dnz(iele, 7)= (xj31*dnxi( 7) + xj32*dnei( 7) + xj33*dnzi( 7)) & + & * axjac(iele) + dnz(iele, 8)= (xj31*dnxi( 8) + xj32*dnei( 8) + xj33*dnzi( 8)) & + & * axjac(iele) + dnz(iele, 9)= (xj31*dnxi( 9) + xj32*dnei( 9) + xj33*dnzi( 9)) & + & * axjac(iele) + dnz(iele,10)= (xj31*dnxi(10) + xj32*dnei(10) + xj33*dnzi(10)) & + & * axjac(iele) + dnz(iele,11)= (xj31*dnxi(11) + xj32*dnei(11) + xj33*dnzi(11)) & + & * axjac(iele) + dnz(iele,12)= (xj31*dnxi(12) + xj32*dnei(12) + xj33*dnzi(12)) & + & * axjac(iele) + dnz(iele,13)= (xj31*dnxi(13) + xj32*dnei(13) + xj33*dnzi(13)) & + & * axjac(iele) + dnz(iele,14)= (xj31*dnxi(14) + xj32*dnei(14) + xj33*dnzi(14)) & + & * axjac(iele) + dnz(iele,15)= (xj31*dnxi(15) + xj32*dnei(15) + xj33*dnzi(15)) & + & * axjac(iele) + dnz(iele,16)= (xj31*dnxi(16) + xj32*dnei(16) + xj33*dnzi(16)) & + & * axjac(iele) + dnz(iele,17)= (xj31*dnxi(17) + xj32*dnei(17) + xj33*dnzi(17)) & + & * axjac(iele) + dnz(iele,18)= (xj31*dnxi(18) + xj32*dnei(18) + xj33*dnzi(18)) & + & * axjac(iele) + dnz(iele,19)= (xj31*dnxi(19) + xj32*dnei(19) + xj33*dnzi(19)) & + & * axjac(iele) + dnz(iele,20)= (xj31*dnxi(20) + xj32*dnei(20) + xj33*dnzi(20)) & + & * axjac(iele) + dnz(iele,21)= (xj31*dnxi(21) + xj32*dnei(21) + xj33*dnzi(21)) & + & * axjac(iele) + dnz(iele,22)= (xj31*dnxi(22) + xj32*dnei(22) + xj33*dnzi(22)) & + & * axjac(iele) + dnz(iele,23)= (xj31*dnxi(23) + xj32*dnei(23) + xj33*dnzi(23)) & + & * axjac(iele) + dnz(iele,24)= (xj31*dnxi(24) + xj32*dnei(24) + xj33*dnzi(24)) & + & * axjac(iele) + dnz(iele,25)= (xj31*dnxi(25) + xj32*dnei(25) + xj33*dnzi(25)) & + & * axjac(iele) + dnz(iele,26)= (xj31*dnxi(26) + xj32*dnei(26) + xj33*dnzi(26)) & + & * axjac(iele) + dnz(iele,27)= (xj31*dnxi(27) + xj32*dnei(27) + xj33*dnzi(27)) & + & * axjac(iele) +! + end do + end do +!$omp end parallel do +! + end do +! + end subroutine s_cal_jacobian_3d_inf_27 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_3d_inf_lag diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_linear.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_linear.f90 new file mode 100644 index 00000000..07add710 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_linear.f90 @@ -0,0 +1,306 @@ +! +! module cal_jacobian_3d_inf_linear +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! +! subroutine s_cal_jacobian_3d_inf_8(numnod, numele, & +! & np_smp, ie, xx, num_surf_bc, surf_item, & +! & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & +! & isurf_grp_smp_stack, xjac, axjac, dnx, dny, dnz, & +! & dxidx, deidx, dzidx, dxidy, deidy, dzidy, & +! & dxidz, deidz, dzidz, dnxi, dnei, dnzi, & +! & dnxi_inf, dnei_inf, dnzi_inf) +! + module cal_jacobian_3d_inf_linear +! + use m_precision +! + use m_geometry_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_3d_inf_8(numnod, numele, & + & np_smp, ie, xx, num_surf_bc, surf_item, & + & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & + & isurf_grp_smp_stack, xjac, axjac, dnx, dny, dnz, & + & dxidx, deidx, dzidx, dxidy, deidy, dzidy, & + & dxidz, deidz, dzidz, dnxi, dnei, dnzi, & + & dnxi_inf, dnei_inf, dnzi_inf) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod, numele + integer(kind = kint), intent(in) :: ie(numele, num_t_linear) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer (kind=kint), intent(in) :: ngrp_sf_infty + integer (kind=kint), intent(in) :: id_grp_sf_infty(ngrp_sf_infty) +! + integer(kind = kint), intent(in) :: np_smp, num_surf_smp + integer(kind = kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_t_linear) + real(kind = kreal), intent(in) :: dnei(num_t_linear) + real(kind = kreal), intent(in) :: dnzi(num_t_linear) +! + real(kind = kreal), intent(in) & + & :: dnxi_inf(num_t_linear,nsurf_4_ele) + real(kind = kreal), intent(in) & + & :: dnei_inf(num_t_linear,nsurf_4_ele) + real(kind = kreal), intent(in) & + & :: dnzi_inf(num_t_linear,nsurf_4_ele) +! + real(kind = kreal), intent(inout) :: dxidx(numele) + real(kind = kreal), intent(inout) :: deidx(numele) + real(kind = kreal), intent(inout) :: dzidx(numele) + real(kind = kreal), intent(inout) :: dxidy(numele) + real(kind = kreal), intent(inout) :: deidy(numele) + real(kind = kreal), intent(inout) :: dzidy(numele) + real(kind = kreal), intent(inout) :: dxidz(numele) + real(kind = kreal), intent(inout) :: deidz(numele) + real(kind = kreal), intent(inout) :: dzidz(numele) +! + real(kind = kreal), intent(inout) :: xjac(numele) + real(kind = kreal), intent(inout) :: axjac(numele) + real(kind = kreal), intent(inout) :: dnx(numele,num_t_linear) + real(kind = kreal), intent(inout) :: dny(numele,num_t_linear) + real(kind = kreal), intent(inout) :: dnz(numele,num_t_linear) +! + integer(kind = kint) :: i, ip, ist, ied, iele + integer(kind = kint) :: igrp, id_sf, inum, isf +! + real(kind = kreal) :: dxxi, dxei, dxzi + real(kind = kreal) :: dyxi, dyei, dyzi + real(kind = kreal) :: dzxi, dzei, dzzi + real(kind = kreal) :: xj11, xj12, xj13 + real(kind = kreal) :: xj21, xj22, xj23 + real(kind = kreal) :: xj31, xj32, xj33 +! + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 +! +! + do i = 1, ngrp_sf_infty + igrp = id_grp_sf_infty(i) +! +!$omp parallel do private & +!$omp& (ist,ied,id_sf,inum,iele,isf,i1,i2,i3,i4,i5,i6,i7,i8, & +!$omp& dxxi,dxei,dxzi,dyxi,dyei,dyzi,dzxi,dzei,dzzi, & +!$omp& xj11,xj12,xj13,xj21,xj22,xj23,xj31,xj32,xj33) + do ip = 1, np_smp + id_sf = np_smp*(igrp-1) + ip + ist = isurf_grp_smp_stack(id_sf-1)+1 + ied = isurf_grp_smp_stack(id_sf) +! +!cdir nodep noloopchg + do inum = ist, ied + iele = surf_item(1,inum) + isf = surf_item(2,inum) +! + i1 = ie(iele, 1) + i2 = ie(iele, 2) + i3 = ie(iele, 3) + i4 = ie(iele, 4) + i5 = ie(iele, 5) + i6 = ie(iele, 6) + i7 = ie(iele, 7) + i8 = ie(iele, 8) +! + dxxi = xx(i1, 1)*dnxi_inf( 1,isf) & + & + xx(i2, 1)*dnxi_inf( 2,isf) & + & + xx(i3, 1)*dnxi_inf( 3,isf) & + & + xx(i4, 1)*dnxi_inf( 4,isf) & + & + xx(i5, 1)*dnxi_inf( 5,isf) & + & + xx(i6, 1)*dnxi_inf( 6,isf) & + & + xx(i7, 1)*dnxi_inf( 7,isf) & + & + xx(i8, 1)*dnxi_inf( 8,isf) +! + dxei = xx(i1, 1)*dnei_inf( 1,isf) & + & + xx(i2, 1)*dnei_inf( 2,isf) & + & + xx(i3, 1)*dnei_inf( 3,isf) & + & + xx(i4, 1)*dnei_inf( 4,isf) & + & + xx(i5, 1)*dnei_inf( 5,isf) & + & + xx(i6, 1)*dnei_inf( 6,isf) & + & + xx(i7, 1)*dnei_inf( 7,isf) & + & + xx(i8, 1)*dnei_inf( 8,isf) +! + dxzi = xx(i1, 1)*dnzi_inf( 1,isf) & + & + xx(i2, 1)*dnzi_inf( 2,isf) & + & + xx(i3, 1)*dnzi_inf( 3,isf) & + & + xx(i4, 1)*dnzi_inf( 4,isf) & + & + xx(i5, 1)*dnzi_inf( 5,isf) & + & + xx(i6, 1)*dnzi_inf( 6,isf) & + & + xx(i7, 1)*dnzi_inf( 7,isf) & + & + xx(i8, 1)*dnzi_inf( 8,isf) +! +! + dyxi = xx(i1, 2)*dnxi_inf( 1,isf) & + & + xx(i2, 2)*dnxi_inf( 2,isf) & + & + xx(i3, 2)*dnxi_inf( 3,isf) & + & + xx(i4, 2)*dnxi_inf( 4,isf) & + & + xx(i5, 2)*dnxi_inf( 5,isf) & + & + xx(i6, 2)*dnxi_inf( 6,isf) & + & + xx(i7, 2)*dnxi_inf( 7,isf) & + & + xx(i8, 2)*dnxi_inf( 8,isf) +! + dyei = xx(i1, 2)*dnei_inf( 1,isf) & + & + xx(i2, 2)*dnei_inf( 2,isf) & + & + xx(i3, 2)*dnei_inf( 3,isf) & + & + xx(i4, 2)*dnei_inf( 4,isf) & + & + xx(i5, 2)*dnei_inf( 5,isf) & + & + xx(i6, 2)*dnei_inf( 6,isf) & + & + xx(i7, 2)*dnei_inf( 7,isf) & + & + xx(i8, 2)*dnei_inf( 8,isf) +! + dyzi = xx(i1, 2)*dnzi_inf( 1,isf) & + & + xx(i2, 2)*dnzi_inf( 2,isf) & + & + xx(i3, 2)*dnzi_inf( 3,isf) & + & + xx(i4, 2)*dnzi_inf( 4,isf) & + & + xx(i5, 2)*dnzi_inf( 5,isf) & + & + xx(i6, 2)*dnzi_inf( 6,isf) & + & + xx(i7, 2)*dnzi_inf( 7,isf) & + & + xx(i8, 2)*dnzi_inf( 8,isf) +! +! + dzxi = xx(i1, 3)*dnxi_inf( 1,isf) & + & + xx(i2, 3)*dnxi_inf( 2,isf) & + & + xx(i3, 3)*dnxi_inf( 3,isf) & + & + xx(i4, 3)*dnxi_inf( 4,isf) & + & + xx(i5, 3)*dnxi_inf( 5,isf) & + & + xx(i6, 3)*dnxi_inf( 6,isf) & + & + xx(i7, 3)*dnxi_inf( 7,isf) & + & + xx(i8, 3)*dnxi_inf( 8,isf) +! + dzei = xx(i1, 3)*dnei_inf( 1,isf) & + & + xx(i2, 3)*dnei_inf( 2,isf) & + & + xx(i3, 3)*dnei_inf( 3,isf) & + & + xx(i4, 3)*dnei_inf( 4,isf) & + & + xx(i5, 3)*dnei_inf( 5,isf) & + & + xx(i6, 3)*dnei_inf( 6,isf) & + & + xx(i7, 3)*dnei_inf( 7,isf) & + & + xx(i8, 3)*dnei_inf( 8,isf) +! + dzzi = xx(i1, 3)*dnzi_inf( 1,isf) & + & + xx(i2, 3)*dnzi_inf( 2,isf) & + & + xx(i3, 3)*dnzi_inf( 3,isf) & + & + xx(i4, 3)*dnzi_inf( 4,isf) & + & + xx(i5, 3)*dnzi_inf( 5,isf) & + & + xx(i6, 3)*dnzi_inf( 6,isf) & + & + xx(i7, 3)*dnzi_inf( 7,isf) & + & + xx(i8, 3)*dnzi_inf( 8,isf) +! +! +! + xj11 = dyei*dzzi - dyzi*dzei + xj12 = dyzi*dzxi - dyxi*dzzi + xj13 = dyxi*dzei - dyei*dzxi +! + xj21 = dzei*dxzi - dzzi*dxei + xj22 = dzzi*dxxi - dzxi*dxzi + xj23 = dzxi*dxei - dzei*dxxi +! + xj31 = dxei*dyzi - dxzi*dyei + xj32 = dxzi*dyxi - dxxi*dyzi + xj33 = dxxi*dyei - dxei*dyxi +! +! + xjac(iele) = dxxi*dyei*dzzi & + & + dxei*dyzi*dzxi & + & + dxzi*dyxi*dzei & + & - ( dxzi*dyei*dzxi & + & + dxxi*dyzi*dzei & + & + dxei*dyxi*dzzi) +! + if (xjac(iele) .eq. 0.0d0) then + axjac(iele) = 1.0d+30 + else + axjac(iele) = 1.0d00 / xjac(iele) + end if +! +! + dxidx(iele) = xj11 * axjac(iele) + deidx(iele) = xj12 * axjac(iele) + dzidx(iele) = xj13 * axjac(iele) +! + dxidy(iele) = xj21 * axjac(iele) + deidy(iele) = xj22 * axjac(iele) + dzidy(iele) = xj23 * axjac(iele) +! + dxidz(iele) = xj31 * axjac(iele) + deidz(iele) = xj32 * axjac(iele) + dzidz(iele) = xj33 * axjac(iele) +! +! + dnx(iele, 1)= (xj11*dnxi( 1) + xj12*dnei( 1) + xj13*dnzi( 1)) & + & * axjac(iele) + dnx(iele, 2)= (xj11*dnxi( 2) + xj12*dnei( 2) + xj13*dnzi( 2)) & + & * axjac(iele) + dnx(iele, 3)= (xj11*dnxi( 3) + xj12*dnei( 3) + xj13*dnzi( 3)) & + & * axjac(iele) + dnx(iele, 4)= (xj11*dnxi( 4) + xj12*dnei( 4) + xj13*dnzi( 4)) & + & * axjac(iele) + dnx(iele, 5)= (xj11*dnxi( 5) + xj12*dnei( 5) + xj13*dnzi( 5)) & + & * axjac(iele) + dnx(iele, 6)= (xj11*dnxi( 6) + xj12*dnei( 6) + xj13*dnzi( 6)) & + & * axjac(iele) + dnx(iele, 7)= (xj11*dnxi( 7) + xj12*dnei( 7) + xj13*dnzi( 7)) & + & * axjac(iele) + dnx(iele, 8)= (xj11*dnxi( 8) + xj12*dnei( 8) + xj13*dnzi( 8)) & + & * axjac(iele) +! + dny(iele, 1)= (xj21*dnxi( 1) + xj22*dnei( 1) + xj23*dnzi( 1)) & + & * axjac(iele) + dny(iele, 2)= (xj21*dnxi( 2) + xj22*dnei( 2) + xj23*dnzi( 2)) & + & * axjac(iele) + dny(iele, 3)= (xj21*dnxi( 3) + xj22*dnei( 3) + xj23*dnzi( 3)) & + & * axjac(iele) + dny(iele, 4)= (xj21*dnxi( 4) + xj22*dnei( 4) + xj23*dnzi( 4)) & + & * axjac(iele) + dny(iele, 5)= (xj21*dnxi( 5) + xj22*dnei( 5) + xj23*dnzi( 5)) & + & * axjac(iele) + dny(iele, 6)= (xj21*dnxi( 6) + xj22*dnei( 6) + xj23*dnzi( 6)) & + & * axjac(iele) + dny(iele, 7)= (xj21*dnxi( 7) + xj22*dnei( 7) + xj23*dnzi( 7)) & + & * axjac(iele) + dny(iele, 8)= (xj21*dnxi( 8) + xj22*dnei( 8) + xj23*dnzi( 8)) & + & * axjac(iele) +! + dnz(iele, 1)= (xj31*dnxi( 1) + xj32*dnei( 1) + xj33*dnzi( 1)) & + & * axjac(iele) + dnz(iele, 2)= (xj31*dnxi( 2) + xj32*dnei( 2) + xj33*dnzi( 2)) & + & * axjac(iele) + dnz(iele, 3)= (xj31*dnxi( 3) + xj32*dnei( 3) + xj33*dnzi( 3)) & + & * axjac(iele) + dnz(iele, 4)= (xj31*dnxi( 4) + xj32*dnei( 4) + xj33*dnzi( 4)) & + & * axjac(iele) + dnz(iele, 5)= (xj31*dnxi( 5) + xj32*dnei( 5) + xj33*dnzi( 5)) & + & * axjac(iele) + dnz(iele, 6)= (xj31*dnxi( 6) + xj32*dnei( 6) + xj33*dnzi( 6)) & + & * axjac(iele) + dnz(iele, 7)= (xj31*dnxi( 7) + xj32*dnei( 7) + xj33*dnzi( 7)) & + & * axjac(iele) + dnz(iele, 8)= (xj31*dnxi( 8) + xj32*dnei( 8) + xj33*dnzi( 8)) & + & * axjac(iele) +! + end do + end do +!$omp end parallel do +! + end do +! + end subroutine s_cal_jacobian_3d_inf_8 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_3d_inf_linear diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_quad.f90 new file mode 100644 index 00000000..ec5f8806 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_inf_quad.f90 @@ -0,0 +1,502 @@ +! +! module cal_jacobian_3d_inf_quad +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June, 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_3d_inf_20(numnod, numele, & +! & np_smp, ie, xx, num_surf_bc, surf_item, & +! & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & +! & isurf_grp_smp_stack, xjac, axjac, dnx, dny, dnz, & +! & dxidx, deidx, dzidx, dxidy, deidy, dzidy, & +! & dxidz, deidz, dzidz, dnxi, dnei, dnzi, & +! & dnxi_inf, dnei_inf, dnzi_inf) +! + module cal_jacobian_3d_inf_quad +! + use m_precision +! + use m_geometry_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_3d_inf_20(numnod, numele, & + & np_smp, ie, xx, num_surf_bc, surf_item, & + & ngrp_sf_infty, id_grp_sf_infty, num_surf_smp, & + & isurf_grp_smp_stack, xjac, axjac, dnx, dny, dnz, & + & dxidx, deidx, dzidx, dxidy, deidy, dzidy, & + & dxidz, deidz, dzidz, dnxi, dnei, dnzi, & + & dnxi_inf, dnei_inf, dnzi_inf) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod, numele + integer(kind = kint), intent(in) :: ie(numele, num_t_quad) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + integer (kind=kint), intent(in) :: ngrp_sf_infty + integer (kind=kint), intent(in) :: id_grp_sf_infty(ngrp_sf_infty) +! + integer(kind = kint), intent(in) :: np_smp, num_surf_smp + integer(kind = kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_t_quad) + real(kind = kreal), intent(in) :: dnei(num_t_quad) + real(kind = kreal), intent(in) :: dnzi(num_t_quad) +! + real(kind = kreal), intent(in) & + & :: dnxi_inf(num_t_quad,nsurf_4_ele) + real(kind = kreal), intent(in) & + & :: dnei_inf(num_t_quad,nsurf_4_ele) + real(kind = kreal), intent(in) & + & :: dnzi_inf(num_t_quad,nsurf_4_ele) +! + real(kind = kreal), intent(inout) :: dxidx(numele) + real(kind = kreal), intent(inout) :: deidx(numele) + real(kind = kreal), intent(inout) :: dzidx(numele) + real(kind = kreal), intent(inout) :: dxidy(numele) + real(kind = kreal), intent(inout) :: deidy(numele) + real(kind = kreal), intent(inout) :: dzidy(numele) + real(kind = kreal), intent(inout) :: dxidz(numele) + real(kind = kreal), intent(inout) :: deidz(numele) + real(kind = kreal), intent(inout) :: dzidz(numele) +! + real(kind = kreal), intent(inout) :: xjac(numele) + real(kind = kreal), intent(inout) :: axjac(numele) + real(kind = kreal), intent(inout) :: dnx(numele,num_t_quad) + real(kind = kreal), intent(inout) :: dny(numele,num_t_quad) + real(kind = kreal), intent(inout) :: dnz(numele,num_t_quad) +! + integer(kind = kint) :: i, ip, ist, ied, iele + integer(kind = kint) :: igrp, id_sf, inum, isf +! + real(kind = kreal) :: dxxi, dxei, dxzi + real(kind = kreal) :: dyxi, dyei, dyzi + real(kind = kreal) :: dzxi, dzei, dzzi + real(kind = kreal) :: xj11, xj12, xj13 + real(kind = kreal) :: xj21, xj22, xj23 + real(kind = kreal) :: xj31, xj32, xj33 +! + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 + integer(kind = kint) :: i9, i10, i11, i12, i13, i14, i15, i16 + integer(kind = kint) :: i17, i18, i19, i20 +! +! + do i = 1, ngrp_sf_infty + igrp = id_grp_sf_infty(i) +! +!$omp parallel do private & +!$omp& (ist,ied,id_sf,inum,iele,isf,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10, & +!$omp& i11,i12,i13,i14,i15,i16,i17,i18,i19,i20, & +!$omp& dxxi,dxei,dxzi,dyxi,dyei,dyzi,dzxi,dzei,dzzi, & +!$omp& xj11,xj12,xj13,xj21,xj22,xj23,xj31,xj32,xj33) + do ip = 1, np_smp + id_sf = np_smp*(igrp-1) + ip + ist = isurf_grp_smp_stack(id_sf-1)+1 + ied = isurf_grp_smp_stack(id_sf) +! +!cdir nodep noloopchg + do inum = ist, ied + iele = surf_item(1,inum) + isf = surf_item(2,inum) +! + i1 = ie(iele, 1) + i2 = ie(iele, 2) + i3 = ie(iele, 3) + i4 = ie(iele, 4) + i5 = ie(iele, 5) + i6 = ie(iele, 6) + i7 = ie(iele, 7) + i8 = ie(iele, 8) + i9 = ie(iele, 9) + i10 = ie(iele,10) + i11 = ie(iele,11) + i12 = ie(iele,12) + i13 = ie(iele,13) + i14 = ie(iele,14) + i15 = ie(iele,15) + i16 = ie(iele,16) + i17 = ie(iele,17) + i18 = ie(iele,18) + i19 = ie(iele,19) + i20 = ie(iele,20) +! + dxxi = xx(i1, 1)*dnxi_inf( 1,isf) & + & + xx(i2, 1)*dnxi_inf( 2,isf) & + & + xx(i3, 1)*dnxi_inf( 3,isf) & + & + xx(i4, 1)*dnxi_inf( 4,isf) & + & + xx(i5, 1)*dnxi_inf( 5,isf) & + & + xx(i6, 1)*dnxi_inf( 6,isf) & + & + xx(i7, 1)*dnxi_inf( 7,isf) & + & + xx(i8, 1)*dnxi_inf( 8,isf) & + & + xx(i9, 1)*dnxi_inf( 9,isf) & + & + xx(i10,1)*dnxi_inf(10,isf) & + & + xx(i11,1)*dnxi_inf(11,isf) & + & + xx(i12,1)*dnxi_inf(12,isf) & + & + xx(i13,1)*dnxi_inf(13,isf) & + & + xx(i14,1)*dnxi_inf(14,isf) & + & + xx(i15,1)*dnxi_inf(15,isf) & + & + xx(i16,1)*dnxi_inf(16,isf) & + & + xx(i17,1)*dnxi_inf(17,isf) & + & + xx(i18,1)*dnxi_inf(18,isf) & + & + xx(i19,1)*dnxi_inf(19,isf) & + & + xx(i20,1)*dnxi_inf(20,isf) +! + dxei = xx(i1, 1)*dnei_inf( 1,isf) & + & + xx(i2, 1)*dnei_inf( 2,isf) & + & + xx(i3, 1)*dnei_inf( 3,isf) & + & + xx(i4, 1)*dnei_inf( 4,isf) & + & + xx(i5, 1)*dnei_inf( 5,isf) & + & + xx(i6, 1)*dnei_inf( 6,isf) & + & + xx(i7, 1)*dnei_inf( 7,isf) & + & + xx(i8, 1)*dnei_inf( 8,isf) & + & + xx(i9, 1)*dnei_inf( 9,isf) & + & + xx(i10,1)*dnei_inf(10,isf) & + & + xx(i11,1)*dnei_inf(11,isf) & + & + xx(i12,1)*dnei_inf(12,isf) & + & + xx(i13,1)*dnei_inf(13,isf) & + & + xx(i14,1)*dnei_inf(14,isf) & + & + xx(i15,1)*dnei_inf(15,isf) & + & + xx(i16,1)*dnei_inf(16,isf) & + & + xx(i17,1)*dnei_inf(17,isf) & + & + xx(i18,1)*dnei_inf(18,isf) & + & + xx(i19,1)*dnei_inf(19,isf) & + & + xx(i20,1)*dnei_inf(20,isf) +! + dxzi = xx(i1, 1)*dnzi_inf( 1,isf) & + & + xx(i2, 1)*dnzi_inf( 2,isf) & + & + xx(i3, 1)*dnzi_inf( 3,isf) & + & + xx(i4, 1)*dnzi_inf( 4,isf) & + & + xx(i5, 1)*dnzi_inf( 5,isf) & + & + xx(i6, 1)*dnzi_inf( 6,isf) & + & + xx(i7, 1)*dnzi_inf( 7,isf) & + & + xx(i8, 1)*dnzi_inf( 8,isf) & + & + xx(i9, 1)*dnzi_inf( 9,isf) & + & + xx(i10,1)*dnzi_inf(10,isf) & + & + xx(i11,1)*dnzi_inf(11,isf) & + & + xx(i12,1)*dnzi_inf(12,isf) & + & + xx(i13,1)*dnzi_inf(13,isf) & + & + xx(i14,1)*dnzi_inf(14,isf) & + & + xx(i15,1)*dnzi_inf(15,isf) & + & + xx(i16,1)*dnzi_inf(16,isf) & + & + xx(i17,1)*dnzi_inf(17,isf) & + & + xx(i18,1)*dnzi_inf(18,isf) & + & + xx(i19,1)*dnzi_inf(19,isf) & + & + xx(i20,1)*dnzi_inf(20,isf) +! +! + dyxi = xx(i1, 2)*dnxi_inf( 1,isf) & + & + xx(i2, 2)*dnxi_inf( 2,isf) & + & + xx(i3, 2)*dnxi_inf( 3,isf) & + & + xx(i4, 2)*dnxi_inf( 4,isf) & + & + xx(i5, 2)*dnxi_inf( 5,isf) & + & + xx(i6, 2)*dnxi_inf( 6,isf) & + & + xx(i7, 2)*dnxi_inf( 7,isf) & + & + xx(i8, 2)*dnxi_inf( 8,isf) & + & + xx(i9, 2)*dnxi_inf( 9,isf) & + & + xx(i10,2)*dnxi_inf(10,isf) & + & + xx(i11,2)*dnxi_inf(11,isf) & + & + xx(i12,2)*dnxi_inf(12,isf) & + & + xx(i13,2)*dnxi_inf(13,isf) & + & + xx(i14,2)*dnxi_inf(14,isf) & + & + xx(i15,2)*dnxi_inf(15,isf) & + & + xx(i16,2)*dnxi_inf(16,isf) & + & + xx(i17,2)*dnxi_inf(17,isf) & + & + xx(i18,2)*dnxi_inf(18,isf) & + & + xx(i19,2)*dnxi_inf(19,isf) & + & + xx(i20,2)*dnxi_inf(20,isf) +! + dyei = xx(i1, 2)*dnei_inf( 1,isf) & + & + xx(i2, 2)*dnei_inf( 2,isf) & + & + xx(i3, 2)*dnei_inf( 3,isf) & + & + xx(i4, 2)*dnei_inf( 4,isf) & + & + xx(i5, 2)*dnei_inf( 5,isf) & + & + xx(i6, 2)*dnei_inf( 6,isf) & + & + xx(i7, 2)*dnei_inf( 7,isf) & + & + xx(i8, 2)*dnei_inf( 8,isf) & + & + xx(i9, 2)*dnei_inf( 9,isf) & + & + xx(i10,2)*dnei_inf(10,isf) & + & + xx(i11,2)*dnei_inf(11,isf) & + & + xx(i12,2)*dnei_inf(12,isf) & + & + xx(i13,2)*dnei_inf(13,isf) & + & + xx(i14,2)*dnei_inf(14,isf) & + & + xx(i15,2)*dnei_inf(15,isf) & + & + xx(i16,2)*dnei_inf(16,isf) & + & + xx(i17,2)*dnei_inf(17,isf) & + & + xx(i18,2)*dnei_inf(18,isf) & + & + xx(i19,2)*dnei_inf(19,isf) & + & + xx(i20,2)*dnei_inf(20,isf) +! + dyzi = xx(i1, 2)*dnzi_inf( 1,isf) & + & + xx(i2, 2)*dnzi_inf( 2,isf) & + & + xx(i3, 2)*dnzi_inf( 3,isf) & + & + xx(i4, 2)*dnzi_inf( 4,isf) & + & + xx(i5, 2)*dnzi_inf( 5,isf) & + & + xx(i6, 2)*dnzi_inf( 6,isf) & + & + xx(i7, 2)*dnzi_inf( 7,isf) & + & + xx(i8, 2)*dnzi_inf( 8,isf) & + & + xx(i9, 2)*dnzi_inf( 9,isf) & + & + xx(i10,2)*dnzi_inf(10,isf) & + & + xx(i11,2)*dnzi_inf(11,isf) & + & + xx(i12,2)*dnzi_inf(12,isf) & + & + xx(i13,2)*dnzi_inf(13,isf) & + & + xx(i14,2)*dnzi_inf(14,isf) & + & + xx(i15,2)*dnzi_inf(15,isf) & + & + xx(i16,2)*dnzi_inf(16,isf) & + & + xx(i17,2)*dnzi_inf(17,isf) & + & + xx(i18,2)*dnzi_inf(18,isf) & + & + xx(i19,2)*dnzi_inf(19,isf) & + & + xx(i20,2)*dnzi_inf(20,isf) +! +! + dzxi = xx(i1, 3)*dnxi_inf( 1,isf) & + & + xx(i2, 3)*dnxi_inf( 2,isf) & + & + xx(i3, 3)*dnxi_inf( 3,isf) & + & + xx(i4, 3)*dnxi_inf( 4,isf) & + & + xx(i5, 3)*dnxi_inf( 5,isf) & + & + xx(i6, 3)*dnxi_inf( 6,isf) & + & + xx(i7, 3)*dnxi_inf( 7,isf) & + & + xx(i8, 3)*dnxi_inf( 8,isf) & + & + xx(i9, 3)*dnxi_inf( 9,isf) & + & + xx(i10,3)*dnxi_inf(10,isf) & + & + xx(i11,3)*dnxi_inf(11,isf) & + & + xx(i12,3)*dnxi_inf(12,isf) & + & + xx(i13,3)*dnxi_inf(13,isf) & + & + xx(i14,3)*dnxi_inf(14,isf) & + & + xx(i15,3)*dnxi_inf(15,isf) & + & + xx(i16,3)*dnxi_inf(16,isf) & + & + xx(i17,3)*dnxi_inf(17,isf) & + & + xx(i18,3)*dnxi_inf(18,isf) & + & + xx(i19,3)*dnxi_inf(19,isf) & + & + xx(i20,3)*dnxi_inf(20,isf) +! + dzei = xx(i1, 3)*dnei_inf( 1,isf) & + & + xx(i2, 3)*dnei_inf( 2,isf) & + & + xx(i3, 3)*dnei_inf( 3,isf) & + & + xx(i4, 3)*dnei_inf( 4,isf) & + & + xx(i5, 3)*dnei_inf( 5,isf) & + & + xx(i6, 3)*dnei_inf( 6,isf) & + & + xx(i7, 3)*dnei_inf( 7,isf) & + & + xx(i8, 3)*dnei_inf( 8,isf) & + & + xx(i9, 3)*dnei_inf( 9,isf) & + & + xx(i10,3)*dnei_inf(10,isf) & + & + xx(i11,3)*dnei_inf(11,isf) & + & + xx(i12,3)*dnei_inf(12,isf) & + & + xx(i13,3)*dnei_inf(13,isf) & + & + xx(i14,3)*dnei_inf(14,isf) & + & + xx(i15,3)*dnei_inf(15,isf) & + & + xx(i16,3)*dnei_inf(16,isf) & + & + xx(i17,3)*dnei_inf(17,isf) & + & + xx(i18,3)*dnei_inf(18,isf) & + & + xx(i19,3)*dnei_inf(19,isf) & + & + xx(i20,3)*dnei_inf(20,isf) +! + dzzi = xx(i1, 3)*dnzi_inf( 1,isf) & + & + xx(i2, 3)*dnzi_inf( 2,isf) & + & + xx(i3, 3)*dnzi_inf( 3,isf) & + & + xx(i4, 3)*dnzi_inf( 4,isf) & + & + xx(i5, 3)*dnzi_inf( 5,isf) & + & + xx(i6, 3)*dnzi_inf( 6,isf) & + & + xx(i7, 3)*dnzi_inf( 7,isf) & + & + xx(i8, 3)*dnzi_inf( 8,isf) & + & + xx(i9, 3)*dnzi_inf( 9,isf) & + & + xx(i10,3)*dnzi_inf(10,isf) & + & + xx(i11,3)*dnzi_inf(11,isf) & + & + xx(i12,3)*dnzi_inf(12,isf) & + & + xx(i13,3)*dnzi_inf(13,isf) & + & + xx(i14,3)*dnzi_inf(14,isf) & + & + xx(i15,3)*dnzi_inf(15,isf) & + & + xx(i16,3)*dnzi_inf(16,isf) & + & + xx(i17,3)*dnzi_inf(17,isf) & + & + xx(i18,3)*dnzi_inf(18,isf) & + & + xx(i19,3)*dnzi_inf(19,isf) & + & + xx(i20,3)*dnzi_inf(20,isf) +! +! +! + xj11 = dyei*dzzi - dyzi*dzei + xj12 = dyzi*dzxi - dyxi*dzzi + xj13 = dyxi*dzei - dyei*dzxi +! + xj21 = dzei*dxzi - dzzi*dxei + xj22 = dzzi*dxxi - dzxi*dxzi + xj23 = dzxi*dxei - dzei*dxxi +! + xj31 = dxei*dyzi - dxzi*dyei + xj32 = dxzi*dyxi - dxxi*dyzi + xj33 = dxxi*dyei - dxei*dyxi +! +! + xjac(iele) = dxxi*dyei*dzzi & + & + dxei*dyzi*dzxi & + & + dxzi*dyxi*dzei & + & - ( dxzi*dyei*dzxi & + & + dxxi*dyzi*dzei & + & + dxei*dyxi*dzzi) +! + if (xjac(iele) .eq. 0.0d0) then + axjac(iele) = 1.0d+30 + else + axjac(iele) = 1.0d00 / xjac(iele) + end if +! +! + dxidx(iele) = xj11 * axjac(iele) + deidx(iele) = xj12 * axjac(iele) + dzidx(iele) = xj13 * axjac(iele) +! + dxidy(iele) = xj21 * axjac(iele) + deidy(iele) = xj22 * axjac(iele) + dzidy(iele) = xj23 * axjac(iele) +! + dxidz(iele) = xj31 * axjac(iele) + deidz(iele) = xj32 * axjac(iele) + dzidz(iele) = xj33 * axjac(iele) +! +! + dnx(iele, 1)= (xj11*dnxi( 1) + xj12*dnei( 1) + xj13*dnzi( 1)) & + & * axjac(iele) + dnx(iele, 2)= (xj11*dnxi( 2) + xj12*dnei( 2) + xj13*dnzi( 2)) & + & * axjac(iele) + dnx(iele, 3)= (xj11*dnxi( 3) + xj12*dnei( 3) + xj13*dnzi( 3)) & + & * axjac(iele) + dnx(iele, 4)= (xj11*dnxi( 4) + xj12*dnei( 4) + xj13*dnzi( 4)) & + & * axjac(iele) + dnx(iele, 5)= (xj11*dnxi( 5) + xj12*dnei( 5) + xj13*dnzi( 5)) & + & * axjac(iele) + dnx(iele, 6)= (xj11*dnxi( 6) + xj12*dnei( 6) + xj13*dnzi( 6)) & + & * axjac(iele) + dnx(iele, 7)= (xj11*dnxi( 7) + xj12*dnei( 7) + xj13*dnzi( 7)) & + & * axjac(iele) + dnx(iele, 8)= (xj11*dnxi( 8) + xj12*dnei( 8) + xj13*dnzi( 8)) & + & * axjac(iele) + dnx(iele, 9)= (xj11*dnxi( 9) + xj12*dnei( 9) + xj13*dnzi( 9)) & + & * axjac(iele) + dnx(iele,10)= (xj11*dnxi(10) + xj12*dnei(10) + xj13*dnzi(10)) & + & * axjac(iele) + dnx(iele,11)= (xj11*dnxi(11) + xj12*dnei(11) + xj13*dnzi(11)) & + & * axjac(iele) + dnx(iele,12)= (xj11*dnxi(12) + xj12*dnei(12) + xj13*dnzi(12)) & + & * axjac(iele) + dnx(iele,13)= (xj11*dnxi(13) + xj12*dnei(13) + xj13*dnzi(13)) & + & * axjac(iele) + dnx(iele,14)= (xj11*dnxi(14) + xj12*dnei(14) + xj13*dnzi(14)) & + & * axjac(iele) + dnx(iele,15)= (xj11*dnxi(15) + xj12*dnei(15) + xj13*dnzi(15)) & + & * axjac(iele) + dnx(iele,16)= (xj11*dnxi(16) + xj12*dnei(16) + xj13*dnzi(16)) & + & * axjac(iele) + dnx(iele,17)= (xj11*dnxi(17) + xj12*dnei(17) + xj13*dnzi(17)) & + & * axjac(iele) + dnx(iele,18)= (xj11*dnxi(18) + xj12*dnei(18) + xj13*dnzi(18)) & + & * axjac(iele) + dnx(iele,19)= (xj11*dnxi(19) + xj12*dnei(19) + xj13*dnzi(19)) & + & * axjac(iele) + dnx(iele,20)= (xj11*dnxi(20) + xj12*dnei(20) + xj13*dnzi(20)) & + & * axjac(iele) +! + dny(iele, 1)= (xj21*dnxi( 1) + xj22*dnei( 1) + xj23*dnzi( 1)) & + & * axjac(iele) + dny(iele, 2)= (xj21*dnxi( 2) + xj22*dnei( 2) + xj23*dnzi( 2)) & + & * axjac(iele) + dny(iele, 3)= (xj21*dnxi( 3) + xj22*dnei( 3) + xj23*dnzi( 3)) & + & * axjac(iele) + dny(iele, 4)= (xj21*dnxi( 4) + xj22*dnei( 4) + xj23*dnzi( 4)) & + & * axjac(iele) + dny(iele, 5)= (xj21*dnxi( 5) + xj22*dnei( 5) + xj23*dnzi( 5)) & + & * axjac(iele) + dny(iele, 6)= (xj21*dnxi( 6) + xj22*dnei( 6) + xj23*dnzi( 6)) & + & * axjac(iele) + dny(iele, 7)= (xj21*dnxi( 7) + xj22*dnei( 7) + xj23*dnzi( 7)) & + & * axjac(iele) + dny(iele, 8)= (xj21*dnxi( 8) + xj22*dnei( 8) + xj23*dnzi( 8)) & + & * axjac(iele) + dny(iele, 9)= (xj21*dnxi( 9) + xj22*dnei( 9) + xj23*dnzi( 9)) & + & * axjac(iele) + dny(iele,10)= (xj21*dnxi(10) + xj22*dnei(10) + xj23*dnzi(10)) & + & * axjac(iele) + dny(iele,11)= (xj21*dnxi(11) + xj22*dnei(11) + xj23*dnzi(11)) & + & * axjac(iele) + dny(iele,12)= (xj21*dnxi(12) + xj22*dnei(12) + xj23*dnzi(12)) & + & * axjac(iele) + dny(iele,13)= (xj21*dnxi(13) + xj22*dnei(13) + xj23*dnzi(13)) & + & * axjac(iele) + dny(iele,14)= (xj21*dnxi(14) + xj22*dnei(14) + xj23*dnzi(14)) & + & * axjac(iele) + dny(iele,15)= (xj21*dnxi(15) + xj22*dnei(15) + xj23*dnzi(15)) & + & * axjac(iele) + dny(iele,16)= (xj21*dnxi(16) + xj22*dnei(16) + xj23*dnzi(16)) & + & * axjac(iele) + dny(iele,17)= (xj21*dnxi(17) + xj22*dnei(17) + xj23*dnzi(17)) & + & * axjac(iele) + dny(iele,18)= (xj21*dnxi(18) + xj22*dnei(18) + xj23*dnzi(18)) & + & * axjac(iele) + dny(iele,19)= (xj21*dnxi(19) + xj22*dnei(19) + xj23*dnzi(19)) & + & * axjac(iele) + dny(iele,20)= (xj21*dnxi(20) + xj22*dnei(20) + xj23*dnzi(20)) & + & * axjac(iele) +! + dnz(iele, 1)= (xj31*dnxi( 1) + xj32*dnei( 1) + xj33*dnzi( 1)) & + & * axjac(iele) + dnz(iele, 2)= (xj31*dnxi( 2) + xj32*dnei( 2) + xj33*dnzi( 2)) & + & * axjac(iele) + dnz(iele, 3)= (xj31*dnxi( 3) + xj32*dnei( 3) + xj33*dnzi( 3)) & + & * axjac(iele) + dnz(iele, 4)= (xj31*dnxi( 4) + xj32*dnei( 4) + xj33*dnzi( 4)) & + & * axjac(iele) + dnz(iele, 5)= (xj31*dnxi( 5) + xj32*dnei( 5) + xj33*dnzi( 5)) & + & * axjac(iele) + dnz(iele, 6)= (xj31*dnxi( 6) + xj32*dnei( 6) + xj33*dnzi( 6)) & + & * axjac(iele) + dnz(iele, 7)= (xj31*dnxi( 7) + xj32*dnei( 7) + xj33*dnzi( 7)) & + & * axjac(iele) + dnz(iele, 8)= (xj31*dnxi( 8) + xj32*dnei( 8) + xj33*dnzi( 8)) & + & * axjac(iele) + dnz(iele, 9)= (xj31*dnxi( 9) + xj32*dnei( 9) + xj33*dnzi( 9)) & + & * axjac(iele) + dnz(iele,10)= (xj31*dnxi(10) + xj32*dnei(10) + xj33*dnzi(10)) & + & * axjac(iele) + dnz(iele,11)= (xj31*dnxi(11) + xj32*dnei(11) + xj33*dnzi(11)) & + & * axjac(iele) + dnz(iele,12)= (xj31*dnxi(12) + xj32*dnei(12) + xj33*dnzi(12)) & + & * axjac(iele) + dnz(iele,13)= (xj31*dnxi(13) + xj32*dnei(13) + xj33*dnzi(13)) & + & * axjac(iele) + dnz(iele,14)= (xj31*dnxi(14) + xj32*dnei(14) + xj33*dnzi(14)) & + & * axjac(iele) + dnz(iele,15)= (xj31*dnxi(15) + xj32*dnei(15) + xj33*dnzi(15)) & + & * axjac(iele) + dnz(iele,16)= (xj31*dnxi(16) + xj32*dnei(16) + xj33*dnzi(16)) & + & * axjac(iele) + dnz(iele,17)= (xj31*dnxi(17) + xj32*dnei(17) + xj33*dnzi(17)) & + & * axjac(iele) + dnz(iele,18)= (xj31*dnxi(18) + xj32*dnei(18) + xj33*dnzi(18)) & + & * axjac(iele) + dnz(iele,19)= (xj31*dnxi(19) + xj32*dnei(19) + xj33*dnzi(19)) & + & * axjac(iele) + dnz(iele,20)= (xj31*dnxi(20) + xj32*dnei(20) + xj33*dnzi(20)) & + & * axjac(iele) +! + end do + end do +!$omp end parallel do +! + end do +! + end subroutine s_cal_jacobian_3d_inf_20 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_3d_inf_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_lag.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_lag.f90 new file mode 100644 index 00000000..245e537a --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_lag.f90 @@ -0,0 +1,470 @@ +! +! module cal_jacobian_3d_lag +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_3d_27(numnod, numele, & +! & np_smp, iele_smp_stack, ie, xx, xjac, axjac, & +! & dnx, dny, dnz, dxidx, deidx, dzidx, dxidy, deidy, & +! & dzidy, dxidz, deidz, dzidz, dnxi, dnei, dnzi) +! +!> \brief Caliculate jacobian by lagrange quadrature shape function +! + module cal_jacobian_3d_lag +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! +!> \brief Caliculate jacobian by lagrange quadrature shape function + subroutine s_cal_jacobian_3d_27(numnod, numele, & + & np_smp, iele_smp_stack, ie, xx, xjac, axjac, & + & dnx, dny, dnz, dxidx, deidx, dzidx, dxidy, deidy, & + & dzidy, dxidz, deidz, dzidz, dnxi, dnei, dnzi) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numele + integer(kind = kint), intent(in) :: ie(numele, num_t_lag) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iele_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_t_lag) + real(kind = kreal), intent(in) :: dnei(num_t_lag) + real(kind = kreal), intent(in) :: dnzi(num_t_lag) +! + real(kind = kreal), intent(inout) :: dxidx(numele) + real(kind = kreal), intent(inout) :: deidx(numele) + real(kind = kreal), intent(inout) :: dzidx(numele) + real(kind = kreal), intent(inout) :: dxidy(numele) + real(kind = kreal), intent(inout) :: deidy(numele) + real(kind = kreal), intent(inout) :: dzidy(numele) + real(kind = kreal), intent(inout) :: dxidz(numele) + real(kind = kreal), intent(inout) :: deidz(numele) + real(kind = kreal), intent(inout) :: dzidz(numele) +! + real(kind = kreal), intent(inout) :: xjac(numele) + real(kind = kreal), intent(inout) :: axjac(numele) + real(kind = kreal), intent(inout) :: dnx(numele,num_t_lag) + real(kind = kreal), intent(inout) :: dny(numele,num_t_lag) + real(kind = kreal), intent(inout) :: dnz(numele,num_t_lag) +! + integer(kind = kint) :: ip, ist, ied, iele +! + real(kind = kreal) :: dxxi, dxei, dxzi + real(kind = kreal) :: dyxi, dyei, dyzi + real(kind = kreal) :: dzxi, dzei, dzzi + real(kind = kreal) :: xj11, xj12, xj13 + real(kind = kreal) :: xj21, xj22, xj23 + real(kind = kreal) :: xj31, xj32, xj33 +! + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 + integer(kind = kint) :: i9, i10, i11, i12, i13, i14, i15, i16 + integer(kind = kint) :: i17, i18, i19, i20, i21, i22, i23, i24 + integer(kind = kint) :: i25, i26, i27 +! +! +!$omp parallel do private & +!$omp& (ist,ied,iele,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12,i13,i14, & +!$omp& i15,i16,i17,i18,i19,i20,i21,i22,i23,i24,i25,i26,i27, & +!$omp& dxxi,dxei,dxzi,dyxi,dyei,dyzi,dzxi,dzei,dzzi, & +!$omp& xj11,xj12,xj13,xj21,xj22,xj23,xj31,xj32,xj33) + do ip = 1, np_smp + ist = iele_smp_stack(ip-1) + 1 + ied = iele_smp_stack(ip) +! +!cdir nodep noloopchg + do iele = ist, ied +! + i1 = ie(iele, 1) + i2 = ie(iele, 2) + i3 = ie(iele, 3) + i4 = ie(iele, 4) + i5 = ie(iele, 5) + i6 = ie(iele, 6) + i7 = ie(iele, 7) + i8 = ie(iele, 8) + i9 = ie(iele, 9) + i10 = ie(iele,10) + i11 = ie(iele,11) + i12 = ie(iele,12) + i13 = ie(iele,13) + i14 = ie(iele,14) + i15 = ie(iele,15) + i16 = ie(iele,16) + i17 = ie(iele,17) + i18 = ie(iele,18) + i19 = ie(iele,19) + i20 = ie(iele,20) + i21 = ie(iele,21) + i22 = ie(iele,22) + i23 = ie(iele,23) + i24 = ie(iele,24) + i25 = ie(iele,25) + i26 = ie(iele,26) + i27 = ie(iele,27) +! + dxxi = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) & + & + xx(i3, 1)*dnxi( 3) + xx(i4, 1)*dnxi( 4) & + & + xx(i5, 1)*dnxi( 5) + xx(i6, 1)*dnxi( 6) & + & + xx(i7, 1)*dnxi( 7) + xx(i8, 1)*dnxi( 8) & + & + xx(i9, 1)*dnxi( 9) + xx(i10,1)*dnxi(10) & + & + xx(i11,1)*dnxi(11) + xx(i12,1)*dnxi(12) & + & + xx(i13,1)*dnxi(13) + xx(i14,1)*dnxi(14) & + & + xx(i15,1)*dnxi(15) + xx(i16,1)*dnxi(16) & + & + xx(i17,1)*dnxi(17) + xx(i18,1)*dnxi(18) & + & + xx(i19,1)*dnxi(19) + xx(i20,1)*dnxi(20) & + & + xx(i21,1)*dnxi(21) + xx(i22,1)*dnxi(22) & + & + xx(i23,1)*dnxi(23) + xx(i24,1)*dnxi(24) & + & + xx(i25,1)*dnxi(25) + xx(i26,1)*dnxi(26) & + & + xx(i27,1)*dnxi(27) +! + dxei = xx(i1, 1)*dnei( 1) + xx(i2, 1)*dnei( 2) & + & + xx(i3, 1)*dnei( 3) + xx(i4, 1)*dnei( 4) & + & + xx(i5, 1)*dnei( 5) + xx(i6, 1)*dnei( 6) & + & + xx(i7, 1)*dnei( 7) + xx(i8, 1)*dnei( 8) & + & + xx(i9, 1)*dnei( 9) + xx(i10,1)*dnei(10) & + & + xx(i11,1)*dnei(11) + xx(i12,1)*dnei(12) & + & + xx(i13,1)*dnei(13) + xx(i14,1)*dnei(14) & + & + xx(i15,1)*dnei(15) + xx(i16,1)*dnei(16) & + & + xx(i17,1)*dnei(17) + xx(i18,1)*dnei(18) & + & + xx(i19,1)*dnei(19) + xx(i20,1)*dnei(20) & + & + xx(i21,1)*dnei(21) + xx(i22,1)*dnei(22) & + & + xx(i23,1)*dnei(23) + xx(i24,1)*dnei(24) & + & + xx(i25,1)*dnei(25) + xx(i26,1)*dnei(26) & + & + xx(i27,1)*dnei(27) +! + dxzi = xx(i1, 1)*dnzi( 1) + xx(i2, 1)*dnzi( 2) & + & + xx(i3, 1)*dnzi( 3) + xx(i4, 1)*dnzi( 4) & + & + xx(i5, 1)*dnzi( 5) + xx(i6, 1)*dnzi( 6) & + & + xx(i7, 1)*dnzi( 7) + xx(i8, 1)*dnzi( 8) & + & + xx(i9, 1)*dnzi( 9) + xx(i10,1)*dnzi(10) & + & + xx(i11,1)*dnzi(11) + xx(i12,1)*dnzi(12) & + & + xx(i13,1)*dnzi(13) + xx(i14,1)*dnzi(14) & + & + xx(i15,1)*dnzi(15) + xx(i16,1)*dnzi(16) & + & + xx(i17,1)*dnzi(17) + xx(i18,1)*dnzi(18) & + & + xx(i19,1)*dnzi(19) + xx(i20,1)*dnzi(20) & + & + xx(i21,1)*dnzi(21) + xx(i22,1)*dnzi(22) & + & + xx(i23,1)*dnzi(23) + xx(i24,1)*dnzi(24) & + & + xx(i25,1)*dnzi(25) + xx(i26,1)*dnzi(26) & + & + xx(i27,1)*dnzi(27) +! +! + dyxi = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) & + & + xx(i3, 2)*dnxi( 3) + xx(i4, 2)*dnxi( 4) & + & + xx(i5, 2)*dnxi( 5) + xx(i6, 2)*dnxi( 6) & + & + xx(i7, 2)*dnxi( 7) + xx(i8, 2)*dnxi( 8) & + & + xx(i9, 2)*dnxi( 9) + xx(i10,2)*dnxi(10) & + & + xx(i11,2)*dnxi(11) + xx(i12,2)*dnxi(12) & + & + xx(i13,2)*dnxi(13) + xx(i14,2)*dnxi(14) & + & + xx(i15,2)*dnxi(15) + xx(i16,2)*dnxi(16) & + & + xx(i17,2)*dnxi(17) + xx(i18,2)*dnxi(18) & + & + xx(i19,2)*dnxi(19) + xx(i20,2)*dnxi(20) & + & + xx(i21,2)*dnxi(21) + xx(i22,2)*dnxi(22) & + & + xx(i23,2)*dnxi(23) + xx(i24,2)*dnxi(24) & + & + xx(i25,2)*dnxi(25) + xx(i26,2)*dnxi(26) & + & + xx(i27,2)*dnxi(27) +! + dyei = xx(i1, 2)*dnei( 1) + xx(i2, 2)*dnei( 2) & + & + xx(i3, 2)*dnei( 3) + xx(i4, 2)*dnei( 4) & + & + xx(i5, 2)*dnei( 5) + xx(i6, 2)*dnei( 6) & + & + xx(i7, 2)*dnei( 7) + xx(i8, 2)*dnei( 8) & + & + xx(i9, 2)*dnei( 9) + xx(i10,2)*dnei(10) & + & + xx(i11,2)*dnei(11) + xx(i12,2)*dnei(12) & + & + xx(i13,2)*dnei(13) + xx(i14,2)*dnei(14) & + & + xx(i15,2)*dnei(15) + xx(i16,2)*dnei(16) & + & + xx(i17,2)*dnei(17) + xx(i18,2)*dnei(18) & + & + xx(i19,2)*dnei(19) + xx(i20,2)*dnei(20) & + & + xx(i21,2)*dnei(21) + xx(i22,2)*dnei(22) & + & + xx(i23,2)*dnei(23) + xx(i24,2)*dnei(24) & + & + xx(i25,2)*dnei(25) + xx(i26,2)*dnei(26) & + & + xx(i27,2)*dnei(27) +! + dyzi = xx(i1, 2)*dnzi( 1) + xx(i2, 2)*dnzi( 2) & + & + xx(i3, 2)*dnzi( 3) + xx(i4, 2)*dnzi( 4) & + & + xx(i5, 2)*dnzi( 5) + xx(i6, 2)*dnzi( 6) & + & + xx(i7, 2)*dnzi( 7) + xx(i8, 2)*dnzi( 8) & + & + xx(i9, 2)*dnzi( 9) + xx(i10,2)*dnzi(10) & + & + xx(i11,2)*dnzi(11) + xx(i12,2)*dnzi(12) & + & + xx(i13,2)*dnzi(13) + xx(i14,2)*dnzi(14) & + & + xx(i15,2)*dnzi(15) + xx(i16,2)*dnzi(16) & + & + xx(i17,2)*dnzi(17) + xx(i18,2)*dnzi(18) & + & + xx(i19,2)*dnzi(19) + xx(i20,2)*dnzi(20) & + & + xx(i21,2)*dnzi(21) + xx(i22,2)*dnzi(22) & + & + xx(i23,2)*dnzi(23) + xx(i24,2)*dnzi(24) & + & + xx(i25,2)*dnzi(25) + xx(i26,2)*dnzi(26) & + & + xx(i27,2)*dnzi(27) +! +! + dzxi = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) & + & + xx(i3, 3)*dnxi( 3) + xx(i4, 3)*dnxi( 4) & + & + xx(i5, 3)*dnxi( 5) + xx(i6, 3)*dnxi( 6) & + & + xx(i7, 3)*dnxi( 7) + xx(i8, 3)*dnxi( 8) & + & + xx(i9, 3)*dnxi( 9) + xx(i10,3)*dnxi(10) & + & + xx(i11,3)*dnxi(11) + xx(i12,3)*dnxi(12) & + & + xx(i13,3)*dnxi(13) + xx(i14,3)*dnxi(14) & + & + xx(i15,3)*dnxi(15) + xx(i16,3)*dnxi(16) & + & + xx(i17,3)*dnxi(17) + xx(i18,3)*dnxi(18) & + & + xx(i19,3)*dnxi(19) + xx(i20,3)*dnxi(20) & + & + xx(i21,3)*dnxi(21) + xx(i22,3)*dnxi(22) & + & + xx(i23,3)*dnxi(23) + xx(i24,3)*dnxi(24) & + & + xx(i25,3)*dnxi(25) + xx(i26,3)*dnxi(26) & + & + xx(i27,3)*dnxi(27) +! + dzei = xx(i1, 3)*dnei( 1) + xx(i2, 3)*dnei( 2) & + & + xx(i3, 3)*dnei( 3) + xx(i4, 3)*dnei( 4) & + & + xx(i5, 3)*dnei( 5) + xx(i6, 3)*dnei( 6) & + & + xx(i7, 3)*dnei( 7) + xx(i8, 3)*dnei( 8) & + & + xx(i9, 3)*dnei( 9) + xx(i10,3)*dnei(10) & + & + xx(i11,3)*dnei(11) + xx(i12,3)*dnei(12) & + & + xx(i13,3)*dnei(13) + xx(i14,3)*dnei(14) & + & + xx(i15,3)*dnei(15) + xx(i16,3)*dnei(16) & + & + xx(i17,3)*dnei(17) + xx(i18,3)*dnei(18) & + & + xx(i19,3)*dnei(19) + xx(i20,3)*dnei(20) & + & + xx(i21,3)*dnei(21) + xx(i22,3)*dnei(22) & + & + xx(i23,3)*dnei(23) + xx(i24,3)*dnei(24) & + & + xx(i25,3)*dnei(25) + xx(i26,3)*dnei(26) & + & + xx(i27,3)*dnei(27) +! + dzzi = xx(i1, 3)*dnzi( 1) + xx(i2, 3)*dnzi( 2) & + & + xx(i3, 3)*dnzi( 3) + xx(i4, 3)*dnzi( 4) & + & + xx(i5, 3)*dnzi( 5) + xx(i6, 3)*dnzi( 6) & + & + xx(i7, 3)*dnzi( 7) + xx(i8, 3)*dnzi( 8) & + & + xx(i9, 3)*dnzi( 9) + xx(i10,3)*dnzi(10) & + & + xx(i11,3)*dnzi(11) + xx(i12,3)*dnzi(12) & + & + xx(i13,3)*dnzi(13) + xx(i14,3)*dnzi(14) & + & + xx(i15,3)*dnzi(15) + xx(i16,3)*dnzi(16) & + & + xx(i17,3)*dnzi(17) + xx(i18,3)*dnzi(18) & + & + xx(i19,3)*dnzi(19) + xx(i20,3)*dnzi(20) & + & + xx(i21,3)*dnzi(21) + xx(i22,3)*dnzi(22) & + & + xx(i23,3)*dnzi(23) + xx(i24,3)*dnzi(24) & + & + xx(i25,3)*dnzi(25) + xx(i26,3)*dnzi(26) & + & + xx(i27,3)*dnzi(27) +! +! +! + xj11 = dyei*dzzi - dyzi*dzei + xj12 = dyzi*dzxi - dyxi*dzzi + xj13 = dyxi*dzei - dyei*dzxi +! + xj21 = dzei*dxzi - dzzi*dxei + xj22 = dzzi*dxxi - dzxi*dxzi + xj23 = dzxi*dxei - dzei*dxxi +! + xj31 = dxei*dyzi - dxzi*dyei + xj32 = dxzi*dyxi - dxxi*dyzi + xj33 = dxxi*dyei - dxei*dyxi +! +! + xjac(iele) = dxxi*dyei*dzzi & + & + dxei*dyzi*dzxi & + & + dxzi*dyxi*dzei & + & - ( dxzi*dyei*dzxi & + & + dxxi*dyzi*dzei & + & + dxei*dyxi*dzzi) +! + if (xjac(iele) .eq. 0.0d0) then + axjac(iele) = 1.0d+30 + else + axjac(iele) = 1.0d00 / xjac(iele) + end if +! + dxidx(iele) = xj11 * axjac(iele) + deidx(iele) = xj12 * axjac(iele) + dzidx(iele) = xj13 * axjac(iele) +! + dxidy(iele) = xj21 * axjac(iele) + deidy(iele) = xj22 * axjac(iele) + dzidy(iele) = xj23 * axjac(iele) +! + dxidz(iele) = xj31 * axjac(iele) + deidz(iele) = xj32 * axjac(iele) + dzidz(iele) = xj33 * axjac(iele) +! +! + dnx(iele, 1)= (xj11*dnxi( 1) + xj12*dnei( 1) + xj13*dnzi( 1)) & + & * axjac(iele) + dnx(iele, 2)= (xj11*dnxi( 2) + xj12*dnei( 2) + xj13*dnzi( 2)) & + & * axjac(iele) + dnx(iele, 3)= (xj11*dnxi( 3) + xj12*dnei( 3) + xj13*dnzi( 3)) & + & * axjac(iele) + dnx(iele, 4)= (xj11*dnxi( 4) + xj12*dnei( 4) + xj13*dnzi( 4)) & + & * axjac(iele) + dnx(iele, 5)= (xj11*dnxi( 5) + xj12*dnei( 5) + xj13*dnzi( 5)) & + & * axjac(iele) + dnx(iele, 6)= (xj11*dnxi( 6) + xj12*dnei( 6) + xj13*dnzi( 6)) & + & * axjac(iele) + dnx(iele, 7)= (xj11*dnxi( 7) + xj12*dnei( 7) + xj13*dnzi( 7)) & + & * axjac(iele) + dnx(iele, 8)= (xj11*dnxi( 8) + xj12*dnei( 8) + xj13*dnzi( 8)) & + & * axjac(iele) + dnx(iele, 9)= (xj11*dnxi( 9) + xj12*dnei( 9) + xj13*dnzi( 9)) & + & * axjac(iele) + dnx(iele,10)= (xj11*dnxi(10) + xj12*dnei(10) + xj13*dnzi(10)) & + & * axjac(iele) + dnx(iele,11)= (xj11*dnxi(11) + xj12*dnei(11) + xj13*dnzi(11)) & + & * axjac(iele) + dnx(iele,12)= (xj11*dnxi(12) + xj12*dnei(12) + xj13*dnzi(12)) & + & * axjac(iele) + dnx(iele,13)= (xj11*dnxi(13) + xj12*dnei(13) + xj13*dnzi(13)) & + & * axjac(iele) + dnx(iele,14)= (xj11*dnxi(14) + xj12*dnei(14) + xj13*dnzi(14)) & + & * axjac(iele) + dnx(iele,15)= (xj11*dnxi(15) + xj12*dnei(15) + xj13*dnzi(15)) & + & * axjac(iele) + dnx(iele,16)= (xj11*dnxi(16) + xj12*dnei(16) + xj13*dnzi(16)) & + & * axjac(iele) + dnx(iele,17)= (xj11*dnxi(17) + xj12*dnei(17) + xj13*dnzi(17)) & + & * axjac(iele) + dnx(iele,18)= (xj11*dnxi(18) + xj12*dnei(18) + xj13*dnzi(18)) & + & * axjac(iele) + dnx(iele,19)= (xj11*dnxi(19) + xj12*dnei(19) + xj13*dnzi(19)) & + & * axjac(iele) + dnx(iele,20)= (xj11*dnxi(20) + xj12*dnei(20) + xj13*dnzi(20)) & + & * axjac(iele) + dnx(iele,21)= (xj11*dnxi(21) + xj12*dnei(21) + xj13*dnzi(21)) & + & * axjac(iele) + dnx(iele,22)= (xj11*dnxi(22) + xj12*dnei(22) + xj13*dnzi(22)) & + & * axjac(iele) + dnx(iele,23)= (xj11*dnxi(23) + xj12*dnei(23) + xj13*dnzi(23)) & + & * axjac(iele) + dnx(iele,24)= (xj11*dnxi(24) + xj12*dnei(24) + xj13*dnzi(24)) & + & * axjac(iele) + dnx(iele,25)= (xj11*dnxi(25) + xj12*dnei(25) + xj13*dnzi(25)) & + & * axjac(iele) + dnx(iele,26)= (xj11*dnxi(26) + xj12*dnei(26) + xj13*dnzi(26)) & + & * axjac(iele) + dnx(iele,27)= (xj11*dnxi(27) + xj12*dnei(27) + xj13*dnzi(27)) & + & * axjac(iele) +! + dny(iele, 1)= (xj21*dnxi( 1) + xj22*dnei( 1) + xj23*dnzi( 1)) & + & * axjac(iele) + dny(iele, 2)= (xj21*dnxi( 2) + xj22*dnei( 2) + xj23*dnzi( 2)) & + & * axjac(iele) + dny(iele, 3)= (xj21*dnxi( 3) + xj22*dnei( 3) + xj23*dnzi( 3)) & + & * axjac(iele) + dny(iele, 4)= (xj21*dnxi( 4) + xj22*dnei( 4) + xj23*dnzi( 4)) & + & * axjac(iele) + dny(iele, 5)= (xj21*dnxi( 5) + xj22*dnei( 5) + xj23*dnzi( 5)) & + & * axjac(iele) + dny(iele, 6)= (xj21*dnxi( 6) + xj22*dnei( 6) + xj23*dnzi( 6)) & + & * axjac(iele) + dny(iele, 7)= (xj21*dnxi( 7) + xj22*dnei( 7) + xj23*dnzi( 7)) & + & * axjac(iele) + dny(iele, 8)= (xj21*dnxi( 8) + xj22*dnei( 8) + xj23*dnzi( 8)) & + & * axjac(iele) + dny(iele, 9)= (xj21*dnxi( 9) + xj22*dnei( 9) + xj23*dnzi( 9)) & + & * axjac(iele) + dny(iele,10)= (xj21*dnxi(10) + xj22*dnei(10) + xj23*dnzi(10)) & + & * axjac(iele) + dny(iele,11)= (xj21*dnxi(11) + xj22*dnei(11) + xj23*dnzi(11)) & + & * axjac(iele) + dny(iele,12)= (xj21*dnxi(12) + xj22*dnei(12) + xj23*dnzi(12)) & + & * axjac(iele) + dny(iele,13)= (xj21*dnxi(13) + xj22*dnei(13) + xj23*dnzi(13)) & + & * axjac(iele) + dny(iele,14)= (xj21*dnxi(14) + xj22*dnei(14) + xj23*dnzi(14)) & + & * axjac(iele) + dny(iele,15)= (xj21*dnxi(15) + xj22*dnei(15) + xj23*dnzi(15)) & + & * axjac(iele) + dny(iele,16)= (xj21*dnxi(16) + xj22*dnei(16) + xj23*dnzi(16)) & + & * axjac(iele) + dny(iele,17)= (xj21*dnxi(17) + xj22*dnei(17) + xj23*dnzi(17)) & + & * axjac(iele) + dny(iele,18)= (xj21*dnxi(18) + xj22*dnei(18) + xj23*dnzi(18)) & + & * axjac(iele) + dny(iele,19)= (xj21*dnxi(19) + xj22*dnei(19) + xj23*dnzi(19)) & + & * axjac(iele) + dny(iele,20)= (xj21*dnxi(20) + xj22*dnei(20) + xj23*dnzi(20)) & + & * axjac(iele) + dny(iele,21)= (xj21*dnxi(21) + xj22*dnei(21) + xj23*dnzi(21)) & + & * axjac(iele) + dny(iele,22)= (xj21*dnxi(22) + xj22*dnei(22) + xj23*dnzi(22)) & + & * axjac(iele) + dny(iele,23)= (xj21*dnxi(23) + xj22*dnei(23) + xj23*dnzi(23)) & + & * axjac(iele) + dny(iele,24)= (xj21*dnxi(24) + xj22*dnei(24) + xj23*dnzi(24)) & + & * axjac(iele) + dny(iele,25)= (xj21*dnxi(25) + xj22*dnei(25) + xj23*dnzi(25)) & + & * axjac(iele) + dny(iele,26)= (xj21*dnxi(26) + xj22*dnei(26) + xj23*dnzi(26)) & + & * axjac(iele) + dny(iele,27)= (xj21*dnxi(27) + xj22*dnei(27) + xj23*dnzi(27)) & + & * axjac(iele) +! + dnz(iele, 1)= (xj31*dnxi( 1) + xj32*dnei( 1) + xj33*dnzi( 1)) & + & * axjac(iele) + dnz(iele, 2)= (xj31*dnxi( 2) + xj32*dnei( 2) + xj33*dnzi( 2)) & + & * axjac(iele) + dnz(iele, 3)= (xj31*dnxi( 3) + xj32*dnei( 3) + xj33*dnzi( 3)) & + & * axjac(iele) + dnz(iele, 4)= (xj31*dnxi( 4) + xj32*dnei( 4) + xj33*dnzi( 4)) & + & * axjac(iele) + dnz(iele, 5)= (xj31*dnxi( 5) + xj32*dnei( 5) + xj33*dnzi( 5)) & + & * axjac(iele) + dnz(iele, 6)= (xj31*dnxi( 6) + xj32*dnei( 6) + xj33*dnzi( 6)) & + & * axjac(iele) + dnz(iele, 7)= (xj31*dnxi( 7) + xj32*dnei( 7) + xj33*dnzi( 7)) & + & * axjac(iele) + dnz(iele, 8)= (xj31*dnxi( 8) + xj32*dnei( 8) + xj33*dnzi( 8)) & + & * axjac(iele) + dnz(iele, 9)= (xj31*dnxi( 9) + xj32*dnei( 9) + xj33*dnzi( 9)) & + & * axjac(iele) + dnz(iele,10)= (xj31*dnxi(10) + xj32*dnei(10) + xj33*dnzi(10)) & + & * axjac(iele) + dnz(iele,11)= (xj31*dnxi(11) + xj32*dnei(11) + xj33*dnzi(11)) & + & * axjac(iele) + dnz(iele,12)= (xj31*dnxi(12) + xj32*dnei(12) + xj33*dnzi(12)) & + & * axjac(iele) + dnz(iele,13)= (xj31*dnxi(13) + xj32*dnei(13) + xj33*dnzi(13)) & + & * axjac(iele) + dnz(iele,14)= (xj31*dnxi(14) + xj32*dnei(14) + xj33*dnzi(14)) & + & * axjac(iele) + dnz(iele,15)= (xj31*dnxi(15) + xj32*dnei(15) + xj33*dnzi(15)) & + & * axjac(iele) + dnz(iele,16)= (xj31*dnxi(16) + xj32*dnei(16) + xj33*dnzi(16)) & + & * axjac(iele) + dnz(iele,17)= (xj31*dnxi(17) + xj32*dnei(17) + xj33*dnzi(17)) & + & * axjac(iele) + dnz(iele,18)= (xj31*dnxi(18) + xj32*dnei(18) + xj33*dnzi(18)) & + & * axjac(iele) + dnz(iele,19)= (xj31*dnxi(19) + xj32*dnei(19) + xj33*dnzi(19)) & + & * axjac(iele) + dnz(iele,20)= (xj31*dnxi(20) + xj32*dnei(20) + xj33*dnzi(20)) & + & * axjac(iele) + dnz(iele,21)= (xj31*dnxi(21) + xj32*dnei(21) + xj33*dnzi(21)) & + & * axjac(iele) + dnz(iele,22)= (xj31*dnxi(22) + xj32*dnei(22) + xj33*dnzi(22)) & + & * axjac(iele) + dnz(iele,23)= (xj31*dnxi(23) + xj32*dnei(23) + xj33*dnzi(23)) & + & * axjac(iele) + dnz(iele,24)= (xj31*dnxi(24) + xj32*dnei(24) + xj33*dnzi(24)) & + & * axjac(iele) + dnz(iele,25)= (xj31*dnxi(25) + xj32*dnei(25) + xj33*dnzi(25)) & + & * axjac(iele) + dnz(iele,26)= (xj31*dnxi(26) + xj32*dnei(26) + xj33*dnzi(26)) & + & * axjac(iele) + dnz(iele,27)= (xj31*dnxi(27) + xj32*dnei(27) + xj33*dnzi(27)) & + & * axjac(iele) +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_3d_27 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_3d_lag diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_linear.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_linear.f90 new file mode 100644 index 00000000..3c9dfe78 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_linear.f90 @@ -0,0 +1,243 @@ +! +! module cal_jacobian_3d_linear +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June, 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_3d_8(numnod, numele, & +! & np_smp, iele_smp_stack, ie, xx, xjac, axjac, & +! & dnx, dny, dnz, dxidx, deidx, dzidx, dxidy, deidy, & +! & dzidy, dxidz, deidz, dzidz, dnxi, dnei, dnzi) +! +!> \brief Caliculate jacobian by linear shape function + module cal_jacobian_3d_linear +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! +!> Caliculate jacobian by 3-d linear shape function + subroutine s_cal_jacobian_3d_8(numnod, numele, & + & np_smp, iele_smp_stack, ie, xx, xjac, axjac, & + & dnx, dny, dnz, dxidx, deidx, dzidx, dxidy, deidy, & + & dzidy, dxidz, deidz, dzidz, dnxi, dnei, dnzi) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numele + integer(kind = kint), intent(in) :: ie(numele, num_t_linear) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iele_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_t_linear) + real(kind = kreal), intent(in) :: dnei(num_t_linear) + real(kind = kreal), intent(in) :: dnzi(num_t_linear) +! + real(kind = kreal), intent(inout) :: dxidx(numele) + real(kind = kreal), intent(inout) :: deidx(numele) + real(kind = kreal), intent(inout) :: dzidx(numele) + real(kind = kreal), intent(inout) :: dxidy(numele) + real(kind = kreal), intent(inout) :: deidy(numele) + real(kind = kreal), intent(inout) :: dzidy(numele) + real(kind = kreal), intent(inout) :: dxidz(numele) + real(kind = kreal), intent(inout) :: deidz(numele) + real(kind = kreal), intent(inout) :: dzidz(numele) +! + real(kind = kreal), intent(inout) :: xjac(numele) + real(kind = kreal), intent(inout) :: axjac(numele) + real(kind = kreal), intent(inout) :: dnx(numele,num_t_linear) + real(kind = kreal), intent(inout) :: dny(numele,num_t_linear) + real(kind = kreal), intent(inout) :: dnz(numele,num_t_linear) +! + integer(kind = kint) :: ip, ist, ied, iele +! + real(kind = kreal) :: dxxi, dxei, dxzi + real(kind = kreal) :: dyxi, dyei, dyzi + real(kind = kreal) :: dzxi, dzei, dzzi + real(kind = kreal) :: xj11, xj12, xj13 + real(kind = kreal) :: xj21, xj22, xj23 + real(kind = kreal) :: xj31, xj32, xj33 +! + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 +! +! +!$omp parallel do private & +!$omp& (ist,ied,iele,i1,i2,i3,i4,i5,i6,i7,i8, & +!$omp& dxxi,dxei,dxzi,dyxi,dyei,dyzi,dzxi,dzei,dzzi, & +!$omp& xj11,xj12,xj13,xj21,xj22,xj23,xj31,xj32,xj33) + do ip = 1, np_smp + ist = iele_smp_stack(ip-1) + 1 + ied = iele_smp_stack(ip) +! +!cdir nodep noloopchg + do iele = ist, ied +! + i1 = ie(iele, 1) + i2 = ie(iele, 2) + i3 = ie(iele, 3) + i4 = ie(iele, 4) + i5 = ie(iele, 5) + i6 = ie(iele, 6) + i7 = ie(iele, 7) + i8 = ie(iele, 8) +! + dxxi = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) & + & + xx(i3, 1)*dnxi( 3) + xx(i4, 1)*dnxi( 4) & + & + xx(i5, 1)*dnxi( 5) + xx(i6, 1)*dnxi( 6) & + & + xx(i7, 1)*dnxi( 7) + xx(i8, 1)*dnxi( 8) +! + dxei = xx(i1, 1)*dnei( 1) + xx(i2, 1)*dnei( 2) & + & + xx(i3, 1)*dnei( 3) + xx(i4, 1)*dnei( 4) & + & + xx(i5, 1)*dnei( 5) + xx(i6, 1)*dnei( 6) & + & + xx(i7, 1)*dnei( 7) + xx(i8, 1)*dnei( 8) +! + dxzi = xx(i1, 1)*dnzi( 1) + xx(i2, 1)*dnzi( 2) & + & + xx(i3, 1)*dnzi( 3) + xx(i4, 1)*dnzi( 4) & + & + xx(i5, 1)*dnzi( 5) + xx(i6, 1)*dnzi( 6) & + & + xx(i7, 1)*dnzi( 7) + xx(i8, 1)*dnzi( 8) +! +! + dyxi = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) & + & + xx(i3, 2)*dnxi( 3) + xx(i4, 2)*dnxi( 4) & + & + xx(i5, 2)*dnxi( 5) + xx(i6, 2)*dnxi( 6) & + & + xx(i7, 2)*dnxi( 7) + xx(i8, 2)*dnxi( 8) +! + dyei = xx(i1, 2)*dnei( 1) + xx(i2, 2)*dnei( 2) & + & + xx(i3, 2)*dnei( 3) + xx(i4, 2)*dnei( 4) & + & + xx(i5, 2)*dnei( 5) + xx(i6, 2)*dnei( 6) & + & + xx(i7, 2)*dnei( 7) + xx(i8, 2)*dnei( 8) +! + dyzi = xx(i1, 2)*dnzi( 1) + xx(i2, 2)*dnzi( 2) & + & + xx(i3, 2)*dnzi( 3) + xx(i4, 2)*dnzi( 4) & + & + xx(i5, 2)*dnzi( 5) + xx(i6, 2)*dnzi( 6) & + & + xx(i7, 2)*dnzi( 7) + xx(i8, 2)*dnzi( 8) +! +! + dzxi = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) & + & + xx(i3, 3)*dnxi( 3) + xx(i4, 3)*dnxi( 4) & + & + xx(i5, 3)*dnxi( 5) + xx(i6, 3)*dnxi( 6) & + & + xx(i7, 3)*dnxi( 7) + xx(i8, 3)*dnxi( 8) +! + dzei = xx(i1, 3)*dnei( 1) + xx(i2, 3)*dnei( 2) & + & + xx(i3, 3)*dnei( 3) + xx(i4, 3)*dnei( 4) & + & + xx(i5, 3)*dnei( 5) + xx(i6, 3)*dnei( 6) & + & + xx(i7, 3)*dnei( 7) + xx(i8, 3)*dnei( 8) +! + dzzi = xx(i1, 3)*dnzi( 1) + xx(i2, 3)*dnzi( 2) & + & + xx(i3, 3)*dnzi( 3) + xx(i4, 3)*dnzi( 4) & + & + xx(i5, 3)*dnzi( 5) + xx(i6, 3)*dnzi( 6) & + & + xx(i7, 3)*dnzi( 7) + xx(i8, 3)*dnzi( 8) +! +! +! + xj11 = dyei*dzzi - dyzi*dzei + xj12 = dyzi*dzxi - dyxi*dzzi + xj13 = dyxi*dzei - dyei*dzxi +! + xj21 = dzei*dxzi - dzzi*dxei + xj22 = dzzi*dxxi - dzxi*dxzi + xj23 = dzxi*dxei - dzei*dxxi +! + xj31 = dxei*dyzi - dxzi*dyei + xj32 = dxzi*dyxi - dxxi*dyzi + xj33 = dxxi*dyei - dxei*dyxi +! +! + xjac(iele) = dxxi*dyei*dzzi & + & + dxei*dyzi*dzxi & + & + dxzi*dyxi*dzei & + & - ( dxzi*dyei*dzxi & + & + dxxi*dyzi*dzei & + & + dxei*dyxi*dzzi) +! + if (xjac(iele) .eq. 0.0d0) then + axjac(iele) = 1.0d+30 + else + axjac(iele) = 1.0d00 / xjac(iele) + end if +! +! + dxidx(iele) = xj11 * axjac(iele) + deidx(iele) = xj12 * axjac(iele) + dzidx(iele) = xj13 * axjac(iele) +! + dxidy(iele) = xj21 * axjac(iele) + deidy(iele) = xj22 * axjac(iele) + dzidy(iele) = xj23 * axjac(iele) +! + dxidz(iele) = xj31 * axjac(iele) + deidz(iele) = xj32 * axjac(iele) + dzidz(iele) = xj33 * axjac(iele) +! +! + dnx(iele, 1)= (xj11*dnxi( 1) + xj12*dnei( 1) + xj13*dnzi( 1)) & + & * axjac(iele) + dnx(iele, 2)= (xj11*dnxi( 2) + xj12*dnei( 2) + xj13*dnzi( 2)) & + & * axjac(iele) + dnx(iele, 3)= (xj11*dnxi( 3) + xj12*dnei( 3) + xj13*dnzi( 3)) & + & * axjac(iele) + dnx(iele, 4)= (xj11*dnxi( 4) + xj12*dnei( 4) + xj13*dnzi( 4)) & + & * axjac(iele) + dnx(iele, 5)= (xj11*dnxi( 5) + xj12*dnei( 5) + xj13*dnzi( 5)) & + & * axjac(iele) + dnx(iele, 6)= (xj11*dnxi( 6) + xj12*dnei( 6) + xj13*dnzi( 6)) & + & * axjac(iele) + dnx(iele, 7)= (xj11*dnxi( 7) + xj12*dnei( 7) + xj13*dnzi( 7)) & + & * axjac(iele) + dnx(iele, 8)= (xj11*dnxi( 8) + xj12*dnei( 8) + xj13*dnzi( 8)) & + & * axjac(iele) +! + dny(iele, 1)= (xj21*dnxi( 1) + xj22*dnei( 1) + xj23*dnzi( 1)) & + & * axjac(iele) + dny(iele, 2)= (xj21*dnxi( 2) + xj22*dnei( 2) + xj23*dnzi( 2)) & + & * axjac(iele) + dny(iele, 3)= (xj21*dnxi( 3) + xj22*dnei( 3) + xj23*dnzi( 3)) & + & * axjac(iele) + dny(iele, 4)= (xj21*dnxi( 4) + xj22*dnei( 4) + xj23*dnzi( 4)) & + & * axjac(iele) + dny(iele, 5)= (xj21*dnxi( 5) + xj22*dnei( 5) + xj23*dnzi( 5)) & + & * axjac(iele) + dny(iele, 6)= (xj21*dnxi( 6) + xj22*dnei( 6) + xj23*dnzi( 6)) & + & * axjac(iele) + dny(iele, 7)= (xj21*dnxi( 7) + xj22*dnei( 7) + xj23*dnzi( 7)) & + & * axjac(iele) + dny(iele, 8)= (xj21*dnxi( 8) + xj22*dnei( 8) + xj23*dnzi( 8)) & + & * axjac(iele) +! + dnz(iele, 1)= (xj31*dnxi( 1) + xj32*dnei( 1) + xj33*dnzi( 1)) & + & * axjac(iele) + dnz(iele, 2)= (xj31*dnxi( 2) + xj32*dnei( 2) + xj33*dnzi( 2)) & + & * axjac(iele) + dnz(iele, 3)= (xj31*dnxi( 3) + xj32*dnei( 3) + xj33*dnzi( 3)) & + & * axjac(iele) + dnz(iele, 4)= (xj31*dnxi( 4) + xj32*dnei( 4) + xj33*dnzi( 4)) & + & * axjac(iele) + dnz(iele, 5)= (xj31*dnxi( 5) + xj32*dnei( 5) + xj33*dnzi( 5)) & + & * axjac(iele) + dnz(iele, 6)= (xj31*dnxi( 6) + xj32*dnei( 6) + xj33*dnzi( 6)) & + & * axjac(iele) + dnz(iele, 7)= (xj31*dnxi( 7) + xj32*dnei( 7) + xj33*dnzi( 7)) & + & * axjac(iele) + dnz(iele, 8)= (xj31*dnxi( 8) + xj32*dnei( 8) + xj33*dnzi( 8)) & + & * axjac(iele) +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_3d_8 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_3d_linear diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_linear_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_linear_quad.f90 new file mode 100644 index 00000000..2a79f15e --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_linear_quad.f90 @@ -0,0 +1,449 @@ +!cal_jacobian_3d_linear_quad.f90 +! module cal_jacobian_3d_linear_quad +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_3d_8_20(numnod, numele, & +! & np_smp, iele_smp_stack, ie, xx, xjac, axjac, & +! & dnx, dny, dnz, dxidx, deidx, dzidx, dxidy, deidy, & +! & dzidy, dxidz, deidz, dzidz, dnxi, dnei, dnzi) +! +!> \brief Caliculate jacobian by quadrature shape function +!> for linear element +! + module cal_jacobian_3d_linear_quad +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! +!> Caliculate jacobian by quadrature shape function +!> for linear element + subroutine s_cal_jacobian_3d_8_20(numnod, numele, & + & np_smp, iele_smp_stack, ie, xx, xjac, axjac, & + & dnx, dny, dnz, dxidx, deidx, dzidx, dxidy, deidy, & + & dzidy, dxidz, deidz, dzidz, dnxi, dnei, dnzi) +! + use m_constants + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numele + integer(kind = kint), intent(in) :: ie(numele, num_t_linear) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iele_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_t_quad) + real(kind = kreal), intent(in) :: dnei(num_t_quad) + real(kind = kreal), intent(in) :: dnzi(num_t_quad) +! + real(kind = kreal), intent(inout) :: dxidx(numele) + real(kind = kreal), intent(inout) :: deidx(numele) + real(kind = kreal), intent(inout) :: dzidx(numele) + real(kind = kreal), intent(inout) :: dxidy(numele) + real(kind = kreal), intent(inout) :: deidy(numele) + real(kind = kreal), intent(inout) :: dzidy(numele) + real(kind = kreal), intent(inout) :: dxidz(numele) + real(kind = kreal), intent(inout) :: deidz(numele) + real(kind = kreal), intent(inout) :: dzidz(numele) +! + real(kind = kreal), intent(inout) :: xjac(numele) + real(kind = kreal), intent(inout) :: axjac(numele) + real(kind = kreal), intent(inout) :: dnx(numele,num_t_quad) + real(kind = kreal), intent(inout) :: dny(numele,num_t_quad) + real(kind = kreal), intent(inout) :: dnz(numele,num_t_quad) +! + integer(kind = kint) :: ip, ist, ied, iele +! + real(kind = kreal) :: dxxi, dxei, dxzi + real(kind = kreal) :: dyxi, dyei, dyzi + real(kind = kreal) :: dzxi, dzei, dzzi + real(kind = kreal) :: xj11, xj12, xj13 + real(kind = kreal) :: xj21, xj22, xj23 + real(kind = kreal) :: xj31, xj32, xj33 +! + real(kind = kreal) :: x01, x02, x03, x04, x05, x06, x07, x08 + real(kind = kreal) :: x09, x10, x11, x12, x13, x14, x15, x16 + real(kind = kreal) :: x17, x18, x19, x20 + real(kind = kreal) :: y01, y02, y03, y04, y05, y06, y07, y08 + real(kind = kreal) :: y09, y10, y11, y12, y13, y14, y15, y16 + real(kind = kreal) :: y17, y18, y19, y20 + real(kind = kreal) :: z01, z02, z03, z04, z05, z06, z07, z08 + real(kind = kreal) :: z09, z10, z11, z12, z13, z14, z15, z16 + real(kind = kreal) :: z17, z18, z19, z20 + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 +! +! +!$omp parallel do private & +!$omp& (ist,ied,iele,i1,i2,i3,i4,i5,i6,i7,i8, & +!$omp& dxxi,dxei,dxzi,dyxi,dyei,dyzi, & +!$omp& dzxi,dzei,dzzi,xj11,xj12,xj13,xj21,xj22,xj23,xj31,xj32,xj33, & +!$omp& x01,x02,x03,x04,x05,x06,x07,x08,x09,x10,x11,x12,x13,x14,x15, & +!$omp& x16,x17,x18,x19,x20,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & +!$omp& y11,y12,y13,y14,y15,y16,y17,y18,y19,y20,z01,z02,z03,z04,z05, & +!$omp& z06,z07,z08,z09,z10,z11,z12,z13,z14,z15,z16,z17,z18,z19,z20) + do ip = 1, np_smp + ist = iele_smp_stack(ip-1) + 1 + ied = iele_smp_stack(ip) +! +!cdir nodep noloopchg + do iele = ist, ied +! + i1 = ie(iele, 1) + i2 = ie(iele, 2) + i3 = ie(iele, 3) + i4 = ie(iele, 4) + i5 = ie(iele, 5) + i6 = ie(iele, 6) + i7 = ie(iele, 7) + i8 = ie(iele, 8) +! + x01 = xx(i1,1) + x02 = xx(i2,1) + x03 = xx(i3,1) + x04 = xx(i4,1) + x05 = xx(i5,1) + x06 = xx(i6,1) + x07 = xx(i7,1) + x08 = xx(i8,1) + x09 = half * (xx(i1,1) + xx(i2,1)) + x10 = half * (xx(i2,1) + xx(i3,1)) + x11 = half * (xx(i3,1) + xx(i4,1)) + x12 = half * (xx(i4,1) + xx(i1,1)) + x13 = half * (xx(i5,1) + xx(i6,1)) + x14 = half * (xx(i6,1) + xx(i7,1)) + x15 = half * (xx(i7,1) + xx(i8,1)) + x16 = half * (xx(i8,1) + xx(i5,1)) + x17 = half * (xx(i1,1) + xx(i5,1)) + x18 = half * (xx(i2,1) + xx(i6,1)) + x19 = half * (xx(i3,1) + xx(i7,1)) + x20 = half * (xx(i4,1) + xx(i8,1)) +! + y01 = xx(i1,2) + y02 = xx(i2,2) + y03 = xx(i3,2) + y04 = xx(i4,2) + y05 = xx(i5,2) + y06 = xx(i6,2) + y07 = xx(i7,2) + y08 = xx(i8,2) + y09 = half * (xx(i1,2) + xx(i2,2)) + y10 = half * (xx(i2,2) + xx(i3,2)) + y11 = half * (xx(i3,2) + xx(i4,2)) + y12 = half * (xx(i4,2) + xx(i1,2)) + y13 = half * (xx(i5,2) + xx(i6,2)) + y14 = half * (xx(i6,2) + xx(i7,2)) + y15 = half * (xx(i7,2) + xx(i8,2)) + y16 = half * (xx(i8,2) + xx(i5,2)) + y17 = half * (xx(i1,2) + xx(i5,2)) + y18 = half * (xx(i2,2) + xx(i6,2)) + y19 = half * (xx(i3,2) + xx(i7,2)) + y20 = half * (xx(i4,2) + xx(i8,2)) +! + z01 = xx(i1,3) + z02 = xx(i2,3) + z03 = xx(i3,3) + z04 = xx(i4,3) + z05 = xx(i5,3) + z06 = xx(i6,3) + z07 = xx(i7,3) + z08 = xx(i8,3) + z09 = half * (xx(i1,3) + xx(i2,3)) + z10 = half * (xx(i2,3) + xx(i3,3)) + z11 = half * (xx(i3,3) + xx(i4,3)) + z12 = half * (xx(i4,3) + xx(i1,3)) + z13 = half * (xx(i5,3) + xx(i6,3)) + z14 = half * (xx(i6,3) + xx(i7,3)) + z15 = half * (xx(i7,3) + xx(i8,3)) + z16 = half * (xx(i8,3) + xx(i5,3)) + z17 = half * (xx(i1,3) + xx(i5,3)) + z18 = half * (xx(i2,3) + xx(i6,3)) + z19 = half * (xx(i3,3) + xx(i7,3)) + z20 = half * (xx(i4,3) + xx(i8,3)) +! + dxxi = x01*dnxi( 1) + x02*dnxi( 2) & + & + x03*dnxi( 3) + x04*dnxi( 4) & + & + x05*dnxi( 5) + x06*dnxi( 6) & + & + x07*dnxi( 7) + x08*dnxi( 8) & + & + x09*dnxi( 9) + x10*dnxi(10) & + & + x11*dnxi(11) + x12*dnxi(12) & + & + x13*dnxi(13) + x14*dnxi(14) & + & + x15*dnxi(15) + x16*dnxi(16) & + & + x17*dnxi(17) + x18*dnxi(18) & + & + x19*dnxi(19) + x20*dnxi(20) +! + dxei = x01*dnei( 1) + x02*dnei( 2) & + & + x03*dnei( 3) + x04*dnei( 4) & + & + x05*dnei( 5) + x06*dnei( 6) & + & + x07*dnei( 7) + x08*dnei( 8) & + & + x09*dnei( 9) + x10*dnei(10) & + & + x11*dnei(11) + x12*dnei(12) & + & + x13*dnei(13) + x14*dnei(14) & + & + x15*dnei(15) + x16*dnei(16) & + & + x17*dnei(17) + x18*dnei(18) & + & + x19*dnei(19) + x20*dnei(20) +! + dxzi = x01*dnzi( 1) + x02*dnzi( 2) & + & + x03*dnzi( 3) + x04*dnzi( 4) & + & + x05*dnzi( 5) + x06*dnzi( 6) & + & + x07*dnzi( 7) + x08*dnzi( 8) & + & + x09*dnzi( 9) + x10*dnzi(10) & + & + x11*dnzi(11) + x12*dnzi(12) & + & + x13*dnzi(13) + x14*dnzi(14) & + & + x15*dnzi(15) + x16*dnzi(16) & + & + x17*dnzi(17) + x18*dnzi(18) & + & + x19*dnzi(19) + x20*dnzi(20) +! +! + dyxi = y01*dnxi( 1) + y02*dnxi( 2) & + & + y03*dnxi( 3) + y04*dnxi( 4) & + & + y05*dnxi( 5) + y06*dnxi( 6) & + & + y07*dnxi( 7) + y08*dnxi( 8) & + & + y09*dnxi( 9) + y10*dnxi(10) & + & + y11*dnxi(11) + y12*dnxi(12) & + & + y13*dnxi(13) + y14*dnxi(14) & + & + y15*dnxi(15) + y16*dnxi(16) & + & + y17*dnxi(17) + y18*dnxi(18) & + & + y19*dnxi(19) + y20*dnxi(20) +! + dyei = y01*dnei( 1) + y02*dnei( 2) & + & + y03*dnei( 3) + y04*dnei( 4) & + & + y05*dnei( 5) + y06*dnei( 6) & + & + y07*dnei( 7) + y08*dnei( 8) & + & + y09*dnei( 9) + y10*dnei(10) & + & + y11*dnei(11) + y12*dnei(12) & + & + y13*dnei(13) + y14*dnei(14) & + & + y15*dnei(15) + y16*dnei(16) & + & + y17*dnei(17) + y18*dnei(18) & + & + y19*dnei(19) + y20*dnei(20) +! + dyzi = y01*dnzi( 1) + y02*dnzi( 2) & + & + y03*dnzi( 3) + y04*dnzi( 4) & + & + y05*dnzi( 5) + y06*dnzi( 6) & + & + y07*dnzi( 7) + y08*dnzi( 8) & + & + y09*dnzi( 9) + y10*dnzi(10) & + & + y11*dnzi(11) + y12*dnzi(12) & + & + y13*dnzi(13) + y14*dnzi(14) & + & + y15*dnzi(15) + y16*dnzi(16) & + & + y17*dnzi(17) + y18*dnzi(18) & + & + y19*dnzi(19) + y20*dnzi(20) +! +! + dzxi = z01*dnxi( 1) + z02*dnxi( 2) & + & + z03*dnxi( 3) + z04*dnxi( 4) & + & + z05*dnxi( 5) + z06*dnxi( 6) & + & + z07*dnxi( 7) + z08*dnxi( 8) & + & + z09*dnxi( 9) + z10*dnxi(10) & + & + z11*dnxi(11) + z12*dnxi(12) & + & + z13*dnxi(13) + z14*dnxi(14) & + & + z15*dnxi(15) + z16*dnxi(16) & + & + z17*dnxi(17) + z18*dnxi(18) & + & + z19*dnxi(19) + z20*dnxi(20) +! + dzei = z01*dnei( 1) + z02*dnei( 2) & + & + z03*dnei( 3) + z04*dnei( 4) & + & + z05*dnei( 5) + z06*dnei( 6) & + & + z07*dnei( 7) + z08*dnei( 8) & + & + z09*dnei( 9) + z10*dnei(10) & + & + z11*dnei(11) + z12*dnei(12) & + & + z13*dnei(13) + z14*dnei(14) & + & + z15*dnei(15) + z16*dnei(16) & + & + z17*dnei(17) + z18*dnei(18) & + & + z19*dnei(19) + z20*dnei(20) +! + dzzi = z01*dnzi( 1) + z02*dnzi( 2) & + & + z03*dnzi( 3) + z04*dnzi( 4) & + & + z05*dnzi( 5) + z06*dnzi( 6) & + & + z07*dnzi( 7) + z08*dnzi( 8) & + & + z09*dnzi( 9) + z10*dnzi(10) & + & + z11*dnzi(11) + z12*dnzi(12) & + & + z13*dnzi(13) + z14*dnzi(14) & + & + z15*dnzi(15) + z16*dnzi(16) & + & + z17*dnzi(17) + z18*dnzi(18) & + & + z19*dnzi(19) + z20*dnzi(20) +! +! +! + xj11 = dyei*dzzi - dyzi*dzei + xj12 = dyzi*dzxi - dyxi*dzzi + xj13 = dyxi*dzei - dyei*dzxi +! + xj21 = dzei*dxzi - dzzi*dxei + xj22 = dzzi*dxxi - dzxi*dxzi + xj23 = dzxi*dxei - dzei*dxxi +! + xj31 = dxei*dyzi - dxzi*dyei + xj32 = dxzi*dyxi - dxxi*dyzi + xj33 = dxxi*dyei - dxei*dyxi +! +! + xjac(iele) = dxxi*dyei*dzzi & + & + dxei*dyzi*dzxi & + & + dxzi*dyxi*dzei & + & - ( dxzi*dyei*dzxi & + & + dxxi*dyzi*dzei & + & + dxei*dyxi*dzzi) +! + if (xjac(iele) .eq. 0.0d0) then + axjac(iele) = 1.0d+30 + else + axjac(iele) = 1.0d00 / xjac(iele) + end if +! +! + dxidx(iele) = xj11 * axjac(iele) + deidx(iele) = xj12 * axjac(iele) + dzidx(iele) = xj13 * axjac(iele) +! + dxidy(iele) = xj21 * axjac(iele) + deidy(iele) = xj22 * axjac(iele) + dzidy(iele) = xj23 * axjac(iele) +! + dxidz(iele) = xj31 * axjac(iele) + deidz(iele) = xj32 * axjac(iele) + dzidz(iele) = xj33 * axjac(iele) +! +! + dnx(iele, 1)= (xj11*dnxi( 1) + xj12*dnei( 1) + xj13*dnzi( 1)) & + & * axjac(iele) + dnx(iele, 2)= (xj11*dnxi( 2) + xj12*dnei( 2) + xj13*dnzi( 2)) & + & * axjac(iele) + dnx(iele, 3)= (xj11*dnxi( 3) + xj12*dnei( 3) + xj13*dnzi( 3)) & + & * axjac(iele) + dnx(iele, 4)= (xj11*dnxi( 4) + xj12*dnei( 4) + xj13*dnzi( 4)) & + & * axjac(iele) + dnx(iele, 5)= (xj11*dnxi( 5) + xj12*dnei( 5) + xj13*dnzi( 5)) & + & * axjac(iele) + dnx(iele, 6)= (xj11*dnxi( 6) + xj12*dnei( 6) + xj13*dnzi( 6)) & + & * axjac(iele) + dnx(iele, 7)= (xj11*dnxi( 7) + xj12*dnei( 7) + xj13*dnzi( 7)) & + & * axjac(iele) + dnx(iele, 8)= (xj11*dnxi( 8) + xj12*dnei( 8) + xj13*dnzi( 8)) & + & * axjac(iele) + dnx(iele, 9)= (xj11*dnxi( 9) + xj12*dnei( 9) + xj13*dnzi( 9)) & + & * axjac(iele) + dnx(iele,10)= (xj11*dnxi(10) + xj12*dnei(10) + xj13*dnzi(10)) & + & * axjac(iele) + dnx(iele,11)= (xj11*dnxi(11) + xj12*dnei(11) + xj13*dnzi(11)) & + & * axjac(iele) + dnx(iele,12)= (xj11*dnxi(12) + xj12*dnei(12) + xj13*dnzi(12)) & + & * axjac(iele) + dnx(iele,13)= (xj11*dnxi(13) + xj12*dnei(13) + xj13*dnzi(13)) & + & * axjac(iele) + dnx(iele,14)= (xj11*dnxi(14) + xj12*dnei(14) + xj13*dnzi(14)) & + & * axjac(iele) + dnx(iele,15)= (xj11*dnxi(15) + xj12*dnei(15) + xj13*dnzi(15)) & + & * axjac(iele) + dnx(iele,16)= (xj11*dnxi(16) + xj12*dnei(16) + xj13*dnzi(16)) & + & * axjac(iele) + dnx(iele,17)= (xj11*dnxi(17) + xj12*dnei(17) + xj13*dnzi(17)) & + & * axjac(iele) + dnx(iele,18)= (xj11*dnxi(18) + xj12*dnei(18) + xj13*dnzi(18)) & + & * axjac(iele) + dnx(iele,19)= (xj11*dnxi(19) + xj12*dnei(19) + xj13*dnzi(19)) & + & * axjac(iele) + dnx(iele,20)= (xj11*dnxi(20) + xj12*dnei(20) + xj13*dnzi(20)) & + & * axjac(iele) +! + dny(iele, 1)= (xj21*dnxi( 1) + xj22*dnei( 1) + xj23*dnzi( 1)) & + & * axjac(iele) + dny(iele, 2)= (xj21*dnxi( 2) + xj22*dnei( 2) + xj23*dnzi( 2)) & + & * axjac(iele) + dny(iele, 3)= (xj21*dnxi( 3) + xj22*dnei( 3) + xj23*dnzi( 3)) & + & * axjac(iele) + dny(iele, 4)= (xj21*dnxi( 4) + xj22*dnei( 4) + xj23*dnzi( 4)) & + & * axjac(iele) + dny(iele, 5)= (xj21*dnxi( 5) + xj22*dnei( 5) + xj23*dnzi( 5)) & + & * axjac(iele) + dny(iele, 6)= (xj21*dnxi( 6) + xj22*dnei( 6) + xj23*dnzi( 6)) & + & * axjac(iele) + dny(iele, 7)= (xj21*dnxi( 7) + xj22*dnei( 7) + xj23*dnzi( 7)) & + & * axjac(iele) + dny(iele, 8)= (xj21*dnxi( 8) + xj22*dnei( 8) + xj23*dnzi( 8)) & + & * axjac(iele) + dny(iele, 9)= (xj21*dnxi( 9) + xj22*dnei( 9) + xj23*dnzi( 9)) & + & * axjac(iele) + dny(iele,10)= (xj21*dnxi(10) + xj22*dnei(10) + xj23*dnzi(10)) & + & * axjac(iele) + dny(iele,11)= (xj21*dnxi(11) + xj22*dnei(11) + xj23*dnzi(11)) & + & * axjac(iele) + dny(iele,12)= (xj21*dnxi(12) + xj22*dnei(12) + xj23*dnzi(12)) & + & * axjac(iele) + dny(iele,13)= (xj21*dnxi(13) + xj22*dnei(13) + xj23*dnzi(13)) & + & * axjac(iele) + dny(iele,14)= (xj21*dnxi(14) + xj22*dnei(14) + xj23*dnzi(14)) & + & * axjac(iele) + dny(iele,15)= (xj21*dnxi(15) + xj22*dnei(15) + xj23*dnzi(15)) & + & * axjac(iele) + dny(iele,16)= (xj21*dnxi(16) + xj22*dnei(16) + xj23*dnzi(16)) & + & * axjac(iele) + dny(iele,17)= (xj21*dnxi(17) + xj22*dnei(17) + xj23*dnzi(17)) & + & * axjac(iele) + dny(iele,18)= (xj21*dnxi(18) + xj22*dnei(18) + xj23*dnzi(18)) & + & * axjac(iele) + dny(iele,19)= (xj21*dnxi(19) + xj22*dnei(19) + xj23*dnzi(19)) & + & * axjac(iele) + dny(iele,20)= (xj21*dnxi(20) + xj22*dnei(20) + xj23*dnzi(20)) & + & * axjac(iele) +! + dnz(iele, 1)= (xj31*dnxi( 1) + xj32*dnei( 1) + xj33*dnzi( 1)) & + & * axjac(iele) + dnz(iele, 2)= (xj31*dnxi( 2) + xj32*dnei( 2) + xj33*dnzi( 2)) & + & * axjac(iele) + dnz(iele, 3)= (xj31*dnxi( 3) + xj32*dnei( 3) + xj33*dnzi( 3)) & + & * axjac(iele) + dnz(iele, 4)= (xj31*dnxi( 4) + xj32*dnei( 4) + xj33*dnzi( 4)) & + & * axjac(iele) + dnz(iele, 5)= (xj31*dnxi( 5) + xj32*dnei( 5) + xj33*dnzi( 5)) & + & * axjac(iele) + dnz(iele, 6)= (xj31*dnxi( 6) + xj32*dnei( 6) + xj33*dnzi( 6)) & + & * axjac(iele) + dnz(iele, 7)= (xj31*dnxi( 7) + xj32*dnei( 7) + xj33*dnzi( 7)) & + & * axjac(iele) + dnz(iele, 8)= (xj31*dnxi( 8) + xj32*dnei( 8) + xj33*dnzi( 8)) & + & * axjac(iele) + dnz(iele, 9)= (xj31*dnxi( 9) + xj32*dnei( 9) + xj33*dnzi( 9)) & + & * axjac(iele) + dnz(iele,10)= (xj31*dnxi(10) + xj32*dnei(10) + xj33*dnzi(10)) & + & * axjac(iele) + dnz(iele,11)= (xj31*dnxi(11) + xj32*dnei(11) + xj33*dnzi(11)) & + & * axjac(iele) + dnz(iele,12)= (xj31*dnxi(12) + xj32*dnei(12) + xj33*dnzi(12)) & + & * axjac(iele) + dnz(iele,13)= (xj31*dnxi(13) + xj32*dnei(13) + xj33*dnzi(13)) & + & * axjac(iele) + dnz(iele,14)= (xj31*dnxi(14) + xj32*dnei(14) + xj33*dnzi(14)) & + & * axjac(iele) + dnz(iele,15)= (xj31*dnxi(15) + xj32*dnei(15) + xj33*dnzi(15)) & + & * axjac(iele) + dnz(iele,16)= (xj31*dnxi(16) + xj32*dnei(16) + xj33*dnzi(16)) & + & * axjac(iele) + dnz(iele,17)= (xj31*dnxi(17) + xj32*dnei(17) + xj33*dnzi(17)) & + & * axjac(iele) + dnz(iele,18)= (xj31*dnxi(18) + xj32*dnei(18) + xj33*dnzi(18)) & + & * axjac(iele) + dnz(iele,19)= (xj31*dnxi(19) + xj32*dnei(19) + xj33*dnzi(19)) & + & * axjac(iele) + dnz(iele,20)= (xj31*dnxi(20) + xj32*dnei(20) + xj33*dnzi(20)) & + & * axjac(iele) +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_3d_8_20 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_3d_linear_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_quad.f90 new file mode 100644 index 00000000..af5beaa1 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_3d_quad.f90 @@ -0,0 +1,383 @@ +! +! module cal_jacobian_3d_quad +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_3d_20(numnod, numele, & +! & np_smp, iele_smp_stack, ie, xx, xjac, axjac, & +! & dnx, dny, dnz, dxidx, deidx, dzidx, dxidy, deidy, & +! & dzidy, dxidz, deidz, dzidz, dnxi, dnei, dnzi) +! +!> \brief Caliculate jacobian by quadrature quadrature shape function + module cal_jacobian_3d_quad +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! +!> Caliculate jacobian by 3-d quadrature shape function + subroutine s_cal_jacobian_3d_20(numnod, numele, & + & np_smp, iele_smp_stack, ie, xx, xjac, axjac, & + & dnx, dny, dnz, dxidx, deidx, dzidx, dxidy, deidy, & + & dzidy, dxidz, deidz, dzidz, dnxi, dnei, dnzi) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + integer(kind = kint), intent(in) :: numele + integer(kind = kint), intent(in) :: ie(numele, num_t_quad) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer(kind = kint), intent(in) :: np_smp + integer(kind = kint), intent(in) :: iele_smp_stack(0:np_smp) +! + real(kind = kreal), intent(in) :: dnxi(num_t_quad) + real(kind = kreal), intent(in) :: dnei(num_t_quad) + real(kind = kreal), intent(in) :: dnzi(num_t_quad) +! + real(kind = kreal), intent(inout) :: dxidx(numele) + real(kind = kreal), intent(inout) :: deidx(numele) + real(kind = kreal), intent(inout) :: dzidx(numele) + real(kind = kreal), intent(inout) :: dxidy(numele) + real(kind = kreal), intent(inout) :: deidy(numele) + real(kind = kreal), intent(inout) :: dzidy(numele) + real(kind = kreal), intent(inout) :: dxidz(numele) + real(kind = kreal), intent(inout) :: deidz(numele) + real(kind = kreal), intent(inout) :: dzidz(numele) +! + real(kind = kreal), intent(inout) :: xjac(numele) + real(kind = kreal), intent(inout) :: axjac(numele) + real(kind = kreal), intent(inout) :: dnx(numele,num_t_quad) + real(kind = kreal), intent(inout) :: dny(numele,num_t_quad) + real(kind = kreal), intent(inout) :: dnz(numele,num_t_quad) +! + integer(kind = kint) :: ip, ist, ied, iele +! + real(kind = kreal) :: dxxi, dxei, dxzi + real(kind = kreal) :: dyxi, dyei, dyzi + real(kind = kreal) :: dzxi, dzei, dzzi + real(kind = kreal) :: xj11, xj12, xj13 + real(kind = kreal) :: xj21, xj22, xj23 + real(kind = kreal) :: xj31, xj32, xj33 +! + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 + integer(kind = kint) :: i9, i10, i11, i12, i13, i14, i15, i16 + integer(kind = kint) :: i17, i18, i19, i20 +! +! +!$omp parallel do private & +!$omp& (ist,ied,iele,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12,i13,i14, & +!$omp& i15,i16,i17,i18,i19,dxxi,dxei,dxzi,dyxi,dyei,dyzi, & +!$omp& dzxi,dzei,dzzi,xj11,xj12,xj13,xj21,xj22,xj23,xj31,xj32,xj33) + do ip = 1, np_smp + ist = iele_smp_stack(ip-1) + 1 + ied = iele_smp_stack(ip) +! +!cdir nodep noloopchg + do iele = ist, ied +! + i1 = ie(iele, 1) + i2 = ie(iele, 2) + i3 = ie(iele, 3) + i4 = ie(iele, 4) + i5 = ie(iele, 5) + i6 = ie(iele, 6) + i7 = ie(iele, 7) + i8 = ie(iele, 8) + i9 = ie(iele, 9) + i10 = ie(iele,10) + i11 = ie(iele,11) + i12 = ie(iele,12) + i13 = ie(iele,13) + i14 = ie(iele,14) + i15 = ie(iele,15) + i16 = ie(iele,16) + i17 = ie(iele,17) + i18 = ie(iele,18) + i19 = ie(iele,19) + i20 = ie(iele,20) +! + dxxi = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) & + & + xx(i3, 1)*dnxi( 3) + xx(i4, 1)*dnxi( 4) & + & + xx(i5, 1)*dnxi( 5) + xx(i6, 1)*dnxi( 6) & + & + xx(i7, 1)*dnxi( 7) + xx(i8, 1)*dnxi( 8) & + & + xx(i9, 1)*dnxi( 9) + xx(i10,1)*dnxi(10) & + & + xx(i11,1)*dnxi(11) + xx(i12,1)*dnxi(12) & + & + xx(i13,1)*dnxi(13) + xx(i14,1)*dnxi(14) & + & + xx(i15,1)*dnxi(15) + xx(i16,1)*dnxi(16) & + & + xx(i17,1)*dnxi(17) + xx(i18,1)*dnxi(18) & + & + xx(i19,1)*dnxi(19) + xx(i20,1)*dnxi(20) +! + dxei = xx(i1, 1)*dnei( 1) + xx(i2, 1)*dnei( 2) & + & + xx(i3, 1)*dnei( 3) + xx(i4, 1)*dnei( 4) & + & + xx(i5, 1)*dnei( 5) + xx(i6, 1)*dnei( 6) & + & + xx(i7, 1)*dnei( 7) + xx(i8, 1)*dnei( 8) & + & + xx(i9, 1)*dnei( 9) + xx(i10,1)*dnei(10) & + & + xx(i11,1)*dnei(11) + xx(i12,1)*dnei(12) & + & + xx(i13,1)*dnei(13) + xx(i14,1)*dnei(14) & + & + xx(i15,1)*dnei(15) + xx(i16,1)*dnei(16) & + & + xx(i17,1)*dnei(17) + xx(i18,1)*dnei(18) & + & + xx(i19,1)*dnei(19) + xx(i20,1)*dnei(20) +! + dxzi = xx(i1, 1)*dnzi( 1) + xx(i2, 1)*dnzi( 2) & + & + xx(i3, 1)*dnzi( 3) + xx(i4, 1)*dnzi( 4) & + & + xx(i5, 1)*dnzi( 5) + xx(i6, 1)*dnzi( 6) & + & + xx(i7, 1)*dnzi( 7) + xx(i8, 1)*dnzi( 8) & + & + xx(i9, 1)*dnzi( 9) + xx(i10,1)*dnzi(10) & + & + xx(i11,1)*dnzi(11) + xx(i12,1)*dnzi(12) & + & + xx(i13,1)*dnzi(13) + xx(i14,1)*dnzi(14) & + & + xx(i15,1)*dnzi(15) + xx(i16,1)*dnzi(16) & + & + xx(i17,1)*dnzi(17) + xx(i18,1)*dnzi(18) & + & + xx(i19,1)*dnzi(19) + xx(i20,1)*dnzi(20) +! +! + dyxi = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) & + & + xx(i3, 2)*dnxi( 3) + xx(i4, 2)*dnxi( 4) & + & + xx(i5, 2)*dnxi( 5) + xx(i6, 2)*dnxi( 6) & + & + xx(i7, 2)*dnxi( 7) + xx(i8, 2)*dnxi( 8) & + & + xx(i9, 2)*dnxi( 9) + xx(i10,2)*dnxi(10) & + & + xx(i11,2)*dnxi(11) + xx(i12,2)*dnxi(12) & + & + xx(i13,2)*dnxi(13) + xx(i14,2)*dnxi(14) & + & + xx(i15,2)*dnxi(15) + xx(i16,2)*dnxi(16) & + & + xx(i17,2)*dnxi(17) + xx(i18,2)*dnxi(18) & + & + xx(i19,2)*dnxi(19) + xx(i20,2)*dnxi(20) +! + dyei = xx(i1, 2)*dnei( 1) + xx(i2, 2)*dnei( 2) & + & + xx(i3, 2)*dnei( 3) + xx(i4, 2)*dnei( 4) & + & + xx(i5, 2)*dnei( 5) + xx(i6, 2)*dnei( 6) & + & + xx(i7, 2)*dnei( 7) + xx(i8, 2)*dnei( 8) & + & + xx(i9, 2)*dnei( 9) + xx(i10,2)*dnei(10) & + & + xx(i11,2)*dnei(11) + xx(i12,2)*dnei(12) & + & + xx(i13,2)*dnei(13) + xx(i14,2)*dnei(14) & + & + xx(i15,2)*dnei(15) + xx(i16,2)*dnei(16) & + & + xx(i17,2)*dnei(17) + xx(i18,2)*dnei(18) & + & + xx(i19,2)*dnei(19) + xx(i20,2)*dnei(20) +! + dyzi = xx(i1, 2)*dnzi( 1) + xx(i2, 2)*dnzi( 2) & + & + xx(i3, 2)*dnzi( 3) + xx(i4, 2)*dnzi( 4) & + & + xx(i5, 2)*dnzi( 5) + xx(i6, 2)*dnzi( 6) & + & + xx(i7, 2)*dnzi( 7) + xx(i8, 2)*dnzi( 8) & + & + xx(i9, 2)*dnzi( 9) + xx(i10,2)*dnzi(10) & + & + xx(i11,2)*dnzi(11) + xx(i12,2)*dnzi(12) & + & + xx(i13,2)*dnzi(13) + xx(i14,2)*dnzi(14) & + & + xx(i15,2)*dnzi(15) + xx(i16,2)*dnzi(16) & + & + xx(i17,2)*dnzi(17) + xx(i18,2)*dnzi(18) & + & + xx(i19,2)*dnzi(19) + xx(i20,2)*dnzi(20) +! +! + dzxi = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) & + & + xx(i3, 3)*dnxi( 3) + xx(i4, 3)*dnxi( 4) & + & + xx(i5, 3)*dnxi( 5) + xx(i6, 3)*dnxi( 6) & + & + xx(i7, 3)*dnxi( 7) + xx(i8, 3)*dnxi( 8) & + & + xx(i9, 3)*dnxi( 9) + xx(i10,3)*dnxi(10) & + & + xx(i11,3)*dnxi(11) + xx(i12,3)*dnxi(12) & + & + xx(i13,3)*dnxi(13) + xx(i14,3)*dnxi(14) & + & + xx(i15,3)*dnxi(15) + xx(i16,3)*dnxi(16) & + & + xx(i17,3)*dnxi(17) + xx(i18,3)*dnxi(18) & + & + xx(i19,3)*dnxi(19) + xx(i20,3)*dnxi(20) +! + dzei = xx(i1, 3)*dnei( 1) + xx(i2, 3)*dnei( 2) & + & + xx(i3, 3)*dnei( 3) + xx(i4, 3)*dnei( 4) & + & + xx(i5, 3)*dnei( 5) + xx(i6, 3)*dnei( 6) & + & + xx(i7, 3)*dnei( 7) + xx(i8, 3)*dnei( 8) & + & + xx(i9, 3)*dnei( 9) + xx(i10,3)*dnei(10) & + & + xx(i11,3)*dnei(11) + xx(i12,3)*dnei(12) & + & + xx(i13,3)*dnei(13) + xx(i14,3)*dnei(14) & + & + xx(i15,3)*dnei(15) + xx(i16,3)*dnei(16) & + & + xx(i17,3)*dnei(17) + xx(i18,3)*dnei(18) & + & + xx(i19,3)*dnei(19) + xx(i20,3)*dnei(20) +! + dzzi = xx(i1, 3)*dnzi( 1) + xx(i2, 3)*dnzi( 2) & + & + xx(i3, 3)*dnzi( 3) + xx(i4, 3)*dnzi( 4) & + & + xx(i5, 3)*dnzi( 5) + xx(i6, 3)*dnzi( 6) & + & + xx(i7, 3)*dnzi( 7) + xx(i8, 3)*dnzi( 8) & + & + xx(i9, 3)*dnzi( 9) + xx(i10,3)*dnzi(10) & + & + xx(i11,3)*dnzi(11) + xx(i12,3)*dnzi(12) & + & + xx(i13,3)*dnzi(13) + xx(i14,3)*dnzi(14) & + & + xx(i15,3)*dnzi(15) + xx(i16,3)*dnzi(16) & + & + xx(i17,3)*dnzi(17) + xx(i18,3)*dnzi(18) & + & + xx(i19,3)*dnzi(19) + xx(i20,3)*dnzi(20) +! +! +! + xj11 = dyei*dzzi - dyzi*dzei + xj12 = dyzi*dzxi - dyxi*dzzi + xj13 = dyxi*dzei - dyei*dzxi +! + xj21 = dzei*dxzi - dzzi*dxei + xj22 = dzzi*dxxi - dzxi*dxzi + xj23 = dzxi*dxei - dzei*dxxi +! + xj31 = dxei*dyzi - dxzi*dyei + xj32 = dxzi*dyxi - dxxi*dyzi + xj33 = dxxi*dyei - dxei*dyxi +! +! + xjac(iele) = dxxi*dyei*dzzi & + & + dxei*dyzi*dzxi & + & + dxzi*dyxi*dzei & + & - ( dxzi*dyei*dzxi & + & + dxxi*dyzi*dzei & + & + dxei*dyxi*dzzi) +! + if (xjac(iele) .eq. 0.0d0) then + axjac(iele) = 1.0d+30 + else + axjac(iele) = 1.0d00 / xjac(iele) + end if +! +! + dxidx(iele) = xj11 * axjac(iele) + deidx(iele) = xj12 * axjac(iele) + dzidx(iele) = xj13 * axjac(iele) +! + dxidy(iele) = xj21 * axjac(iele) + deidy(iele) = xj22 * axjac(iele) + dzidy(iele) = xj23 * axjac(iele) +! + dxidz(iele) = xj31 * axjac(iele) + deidz(iele) = xj32 * axjac(iele) + dzidz(iele) = xj33 * axjac(iele) +! +! + dnx(iele, 1)= (xj11*dnxi( 1) + xj12*dnei( 1) + xj13*dnzi( 1)) & + & * axjac(iele) + dnx(iele, 2)= (xj11*dnxi( 2) + xj12*dnei( 2) + xj13*dnzi( 2)) & + & * axjac(iele) + dnx(iele, 3)= (xj11*dnxi( 3) + xj12*dnei( 3) + xj13*dnzi( 3)) & + & * axjac(iele) + dnx(iele, 4)= (xj11*dnxi( 4) + xj12*dnei( 4) + xj13*dnzi( 4)) & + & * axjac(iele) + dnx(iele, 5)= (xj11*dnxi( 5) + xj12*dnei( 5) + xj13*dnzi( 5)) & + & * axjac(iele) + dnx(iele, 6)= (xj11*dnxi( 6) + xj12*dnei( 6) + xj13*dnzi( 6)) & + & * axjac(iele) + dnx(iele, 7)= (xj11*dnxi( 7) + xj12*dnei( 7) + xj13*dnzi( 7)) & + & * axjac(iele) + dnx(iele, 8)= (xj11*dnxi( 8) + xj12*dnei( 8) + xj13*dnzi( 8)) & + & * axjac(iele) + dnx(iele, 9)= (xj11*dnxi( 9) + xj12*dnei( 9) + xj13*dnzi( 9)) & + & * axjac(iele) + dnx(iele,10)= (xj11*dnxi(10) + xj12*dnei(10) + xj13*dnzi(10)) & + & * axjac(iele) + dnx(iele,11)= (xj11*dnxi(11) + xj12*dnei(11) + xj13*dnzi(11)) & + & * axjac(iele) + dnx(iele,12)= (xj11*dnxi(12) + xj12*dnei(12) + xj13*dnzi(12)) & + & * axjac(iele) + dnx(iele,13)= (xj11*dnxi(13) + xj12*dnei(13) + xj13*dnzi(13)) & + & * axjac(iele) + dnx(iele,14)= (xj11*dnxi(14) + xj12*dnei(14) + xj13*dnzi(14)) & + & * axjac(iele) + dnx(iele,15)= (xj11*dnxi(15) + xj12*dnei(15) + xj13*dnzi(15)) & + & * axjac(iele) + dnx(iele,16)= (xj11*dnxi(16) + xj12*dnei(16) + xj13*dnzi(16)) & + & * axjac(iele) + dnx(iele,17)= (xj11*dnxi(17) + xj12*dnei(17) + xj13*dnzi(17)) & + & * axjac(iele) + dnx(iele,18)= (xj11*dnxi(18) + xj12*dnei(18) + xj13*dnzi(18)) & + & * axjac(iele) + dnx(iele,19)= (xj11*dnxi(19) + xj12*dnei(19) + xj13*dnzi(19)) & + & * axjac(iele) + dnx(iele,20)= (xj11*dnxi(20) + xj12*dnei(20) + xj13*dnzi(20)) & + & * axjac(iele) +! + dny(iele, 1)= (xj21*dnxi( 1) + xj22*dnei( 1) + xj23*dnzi( 1)) & + & * axjac(iele) + dny(iele, 2)= (xj21*dnxi( 2) + xj22*dnei( 2) + xj23*dnzi( 2)) & + & * axjac(iele) + dny(iele, 3)= (xj21*dnxi( 3) + xj22*dnei( 3) + xj23*dnzi( 3)) & + & * axjac(iele) + dny(iele, 4)= (xj21*dnxi( 4) + xj22*dnei( 4) + xj23*dnzi( 4)) & + & * axjac(iele) + dny(iele, 5)= (xj21*dnxi( 5) + xj22*dnei( 5) + xj23*dnzi( 5)) & + & * axjac(iele) + dny(iele, 6)= (xj21*dnxi( 6) + xj22*dnei( 6) + xj23*dnzi( 6)) & + & * axjac(iele) + dny(iele, 7)= (xj21*dnxi( 7) + xj22*dnei( 7) + xj23*dnzi( 7)) & + & * axjac(iele) + dny(iele, 8)= (xj21*dnxi( 8) + xj22*dnei( 8) + xj23*dnzi( 8)) & + & * axjac(iele) + dny(iele, 9)= (xj21*dnxi( 9) + xj22*dnei( 9) + xj23*dnzi( 9)) & + & * axjac(iele) + dny(iele,10)= (xj21*dnxi(10) + xj22*dnei(10) + xj23*dnzi(10)) & + & * axjac(iele) + dny(iele,11)= (xj21*dnxi(11) + xj22*dnei(11) + xj23*dnzi(11)) & + & * axjac(iele) + dny(iele,12)= (xj21*dnxi(12) + xj22*dnei(12) + xj23*dnzi(12)) & + & * axjac(iele) + dny(iele,13)= (xj21*dnxi(13) + xj22*dnei(13) + xj23*dnzi(13)) & + & * axjac(iele) + dny(iele,14)= (xj21*dnxi(14) + xj22*dnei(14) + xj23*dnzi(14)) & + & * axjac(iele) + dny(iele,15)= (xj21*dnxi(15) + xj22*dnei(15) + xj23*dnzi(15)) & + & * axjac(iele) + dny(iele,16)= (xj21*dnxi(16) + xj22*dnei(16) + xj23*dnzi(16)) & + & * axjac(iele) + dny(iele,17)= (xj21*dnxi(17) + xj22*dnei(17) + xj23*dnzi(17)) & + & * axjac(iele) + dny(iele,18)= (xj21*dnxi(18) + xj22*dnei(18) + xj23*dnzi(18)) & + & * axjac(iele) + dny(iele,19)= (xj21*dnxi(19) + xj22*dnei(19) + xj23*dnzi(19)) & + & * axjac(iele) + dny(iele,20)= (xj21*dnxi(20) + xj22*dnei(20) + xj23*dnzi(20)) & + & * axjac(iele) +! + dnz(iele, 1)= (xj31*dnxi( 1) + xj32*dnei( 1) + xj33*dnzi( 1)) & + & * axjac(iele) + dnz(iele, 2)= (xj31*dnxi( 2) + xj32*dnei( 2) + xj33*dnzi( 2)) & + & * axjac(iele) + dnz(iele, 3)= (xj31*dnxi( 3) + xj32*dnei( 3) + xj33*dnzi( 3)) & + & * axjac(iele) + dnz(iele, 4)= (xj31*dnxi( 4) + xj32*dnei( 4) + xj33*dnzi( 4)) & + & * axjac(iele) + dnz(iele, 5)= (xj31*dnxi( 5) + xj32*dnei( 5) + xj33*dnzi( 5)) & + & * axjac(iele) + dnz(iele, 6)= (xj31*dnxi( 6) + xj32*dnei( 6) + xj33*dnzi( 6)) & + & * axjac(iele) + dnz(iele, 7)= (xj31*dnxi( 7) + xj32*dnei( 7) + xj33*dnzi( 7)) & + & * axjac(iele) + dnz(iele, 8)= (xj31*dnxi( 8) + xj32*dnei( 8) + xj33*dnzi( 8)) & + & * axjac(iele) + dnz(iele, 9)= (xj31*dnxi( 9) + xj32*dnei( 9) + xj33*dnzi( 9)) & + & * axjac(iele) + dnz(iele,10)= (xj31*dnxi(10) + xj32*dnei(10) + xj33*dnzi(10)) & + & * axjac(iele) + dnz(iele,11)= (xj31*dnxi(11) + xj32*dnei(11) + xj33*dnzi(11)) & + & * axjac(iele) + dnz(iele,12)= (xj31*dnxi(12) + xj32*dnei(12) + xj33*dnzi(12)) & + & * axjac(iele) + dnz(iele,13)= (xj31*dnxi(13) + xj32*dnei(13) + xj33*dnzi(13)) & + & * axjac(iele) + dnz(iele,14)= (xj31*dnxi(14) + xj32*dnei(14) + xj33*dnzi(14)) & + & * axjac(iele) + dnz(iele,15)= (xj31*dnxi(15) + xj32*dnei(15) + xj33*dnzi(15)) & + & * axjac(iele) + dnz(iele,16)= (xj31*dnxi(16) + xj32*dnei(16) + xj33*dnzi(16)) & + & * axjac(iele) + dnz(iele,17)= (xj31*dnxi(17) + xj32*dnei(17) + xj33*dnzi(17)) & + & * axjac(iele) + dnz(iele,18)= (xj31*dnxi(18) + xj32*dnei(18) + xj33*dnzi(18)) & + & * axjac(iele) + dnz(iele,19)= (xj31*dnxi(19) + xj32*dnei(19) + xj33*dnzi(19)) & + & * axjac(iele) + dnz(iele,20)= (xj31*dnxi(20) + xj32*dnei(20) + xj33*dnzi(20)) & + & * axjac(iele) +! + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_3d_20 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_3d_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_l_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_l_quad.f90 new file mode 100644 index 00000000..b4023410 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_l_quad.f90 @@ -0,0 +1,179 @@ +!cal_jacobian_sf_grp_l_quad.f90 +! module cal_jacobian_sf_grp_l_quad +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! +! subroutine s_cal_jacobian_sf_grp_4_8(numnod, numele, & +! & ie, xx, num_surf, num_surf_bc, surf_item, & +! & np_smp, num_surf_smp, isurf_grp_smp_stack, & +! & xjac, axjac, xsf, ysf, zsf, dnxi, dnei) +! + module cal_jacobian_sf_grp_l_quad +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_sf_grp_4_8(numnod, numele, & + & ie, xx, num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & xjac, axjac, xsf, ysf, zsf, dnxi, dnei) +! + use m_constants + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod, numele + integer(kind = kint), intent(in) :: ie(numele, num_t_linear) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: np_smp + integer (kind=kint), intent(in) :: num_surf_smp + integer (kind=kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer (kind=kint), intent(in) :: num_surf + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + real(kind = kreal), intent(in) :: dnxi(num_quad_sf) + real(kind = kreal), intent(in) :: dnei(num_quad_sf) +! + real(kind = kreal), intent(inout) :: xjac(num_surf_bc) + real(kind = kreal), intent(inout) :: axjac(num_surf_bc) + real(kind = kreal), intent(inout) :: xsf(num_surf_bc) + real(kind = kreal), intent(inout) :: ysf(num_surf_bc) + real(kind = kreal), intent(inout) :: zsf(num_surf_bc) +! + integer(kind = kint) :: ip, igrp, ist, ied, inum, iele, isf, jp +! + real(kind = kreal) :: dxxi, dxei + real(kind = kreal) :: dyxi, dyei + real(kind = kreal) :: dzxi, dzei +! + real(kind = kreal) :: x1, x2, x3, x4, x5, x6, x7, x8 + real(kind = kreal) :: y1, y2, y3, y4, y5, y6, y7, y8 + real(kind = kreal) :: z1, z2, z3, z4, z5, z6, z7, z8 + integer(kind = kint) :: i1, i2, i3, i4 + integer(kind = kint) :: il1, il2, il3, il4 +! +! +!$omp parallel do private & +!$omp& (ist,ied,igrp,jp,inum,iele,isf, & +!$omp& i1,i2,i3,i4,il1,il2,il3,il4, & +!$omp& dxxi,dxei,dyxi,dyei,dzxi,dzei,x1,x2,x3,x4,x5,x6,x7,x8, & +!$omp& y1,y2,y3,y4,y5,y6,y7,y8,z1,z2,z3,z4,z5,z6,z7,z8) + do ip = 1, np_smp + do igrp = 1, num_surf + jp = np_smp*(igrp-1) + ip + ist = isurf_grp_smp_stack(jp-1) + 1 + ied = isurf_grp_smp_stack(jp) +! +!cdir nodep noloopchg + do inum = ist, ied +! + iele = surf_item(1,inum) + isf = surf_item(2,inum) +! + il1 = node_on_sf_4(1,isf) + il2 = node_on_sf_4(2,isf) + il3 = node_on_sf_4(3,isf) + il4 = node_on_sf_4(4,isf) +! + i1 = ie(iele,il1) + i2 = ie(iele,il2) + i3 = ie(iele,il3) + i4 = ie(iele,il4) +! + x1 = xx(i1,1) + x2 = xx(i2,1) + x3 = xx(i3,1) + x4 = xx(i4,1) + x5 = half * (xx(i1,1) + xx(i2,1)) + x6 = half * (xx(i2,1) + xx(i3,1)) + x7 = half * (xx(i3,1) + xx(i4,1)) + x8 = half * (xx(i4,1) + xx(i1,1)) +! + y1 = xx(i1,2) + y2 = xx(i2,2) + y3 = xx(i3,2) + y4 = xx(i4,2) + y5 = half * (xx(i1,2) + xx(i2,2)) + y6 = half * (xx(i2,2) + xx(i3,2)) + y7 = half * (xx(i3,2) + xx(i4,2)) + y8 = half * (xx(i4,2) + xx(i1,2)) +! + z1 = xx(i1,3) + z2 = xx(i2,3) + z3 = xx(i3,3) + z4 = xx(i4,3) + z5 = half * (xx(i1,3) + xx(i2,3)) + z6 = half * (xx(i2,3) + xx(i3,3)) + z7 = half * (xx(i3,3) + xx(i4,3)) + z8 = half * (xx(i4,3) + xx(i1,3)) +! + dxxi = x1*dnxi( 1) + x2*dnxi( 2) & + & + x3*dnxi( 3) + x4*dnxi( 4) & + & + x5*dnxi( 5) + x6*dnxi( 6) & + & + x7*dnxi( 7) + x8*dnxi( 8) +! + dxei = x1*dnei( 1) + x2*dnei( 2) & + & + x3*dnei( 3) + x4*dnei( 4) & + & + x5*dnei( 5) + x6*dnei( 6) & + & + x7*dnei( 7) + x8*dnei( 8) +! +! + dyxi = y1*dnxi( 1) + y2*dnxi( 2) & + & + y3*dnxi( 3) + y4*dnxi( 4) & + & + y5*dnxi( 5) + y6*dnxi( 6) & + & + y7*dnxi( 7) + y8*dnxi( 8) +! + dyei = y1*dnei( 1) + y2*dnei( 2) & + & + y3*dnei( 3) + y4*dnei( 4) & + & + y5*dnei( 5) + y6*dnei( 6) & + & + y7*dnei( 7) + y8*dnei( 8) +! +! + dzxi = z1*dnxi( 1) + z2*dnxi( 2) & + & + z3*dnxi( 3) + z4*dnxi( 4) & + & + z5*dnxi( 5) + z6*dnxi( 6) & + & + z7*dnxi( 7) + z8*dnxi( 8) +! + dzei = z1*dnei( 1) + z2*dnei( 2) & + & + z3*dnei( 3) + z4*dnei( 4) & + & + z5*dnei( 5) + z6*dnei( 6) & + & + z7*dnei( 7) + z8*dnei( 8) +! +! +! + xsf(inum) = dyxi*dzei - dzxi*dyei + ysf(inum) = dzxi*dxei - dxxi*dzei + zsf(inum) = dxxi*dyei - dyxi*dxei +! + xjac(inum) = sqrt( xsf(inum)*xsf(inum) & + & + ysf(inum)*ysf(inum) & + & + zsf(inum)*zsf(inum) ) +! + if (xjac(inum) .eq. 0.0d0) then + axjac(inum) = 1.0d+30 + else + axjac(inum) = 1.0d00 / xjac(inum) + end if +! + end do + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_sf_grp_4_8 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_sf_grp_l_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_lag.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_lag.f90 new file mode 100644 index 00000000..2fa95657 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_lag.f90 @@ -0,0 +1,166 @@ +! +! module cal_jacobian_sf_grp_lag +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! modified by H. Matsui on Dec., 2008 +! +! subroutine s_cal_jacobian_sf_grp_9(numnod, numele, & +! & ie, xx, num_surf, num_surf_bc, surf_item, & +! & np_smp, num_surf_smp, isurf_grp_smp_stack, & +! & xjac, axjac, xsf, ysf, zsf, dnxi, dnei) +! + module cal_jacobian_sf_grp_lag +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_sf_grp_9(numnod, numele, & + & ie, xx, num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & xjac, axjac, xsf, ysf, zsf, dnxi, dnei) +! + use m_constants + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod, numele + integer(kind = kint), intent(in) :: ie(numele, num_t_lag) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: np_smp + integer (kind=kint), intent(in) :: num_surf_smp + integer (kind=kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer (kind=kint), intent(in) :: num_surf + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + real(kind = kreal), intent(in) :: dnxi(num_lag_sf) + real(kind = kreal), intent(in) :: dnei(num_lag_sf) +! + real(kind = kreal), intent(inout) :: xjac(num_surf_bc) + real(kind = kreal), intent(inout) :: axjac(num_surf_bc) + real(kind = kreal), intent(inout) :: xsf(num_surf_bc) + real(kind = kreal), intent(inout) :: ysf(num_surf_bc) + real(kind = kreal), intent(inout) :: zsf(num_surf_bc) +! + integer(kind = kint) :: ip, igrp, ist, ied, inum, iele, isf, jp +! + real(kind = kreal) :: dxxi, dxei + real(kind = kreal) :: dyxi, dyei + real(kind = kreal) :: dzxi, dzei +! + integer(kind=kint) :: i1, i2, i3, i4, i5, i6, i7, i8, i9 + integer(kind=kint) :: il1, il2, il3, il4, il5, il6, il7, il8, il9 +! +! +!$omp parallel do private & +!$omp& (ist,ied,igrp,jp,inum,iele,isf, & +!$omp& i1,i2,i3,i4,i5,i6,i7,i8,i9, & +!$omp& il1,il2,il3,il4,il5,il6,il7,il8,il9, & +!$omp& dxxi,dxei,dyxi,dyei,dzxi,dzei) + do ip = 1, np_smp + do igrp = 1, num_surf + jp = np_smp*(igrp-1) + ip + ist = isurf_grp_smp_stack(jp-1) + 1 + ied = isurf_grp_smp_stack(jp) +! +!cdir nodep noloopchg + do inum = ist, ied +! + iele = surf_item(1,inum) + isf = surf_item(2,inum) +! + il1 = node_on_sf_9(1,isf) + il2 = node_on_sf_9(2,isf) + il3 = node_on_sf_9(3,isf) + il4 = node_on_sf_9(4,isf) + il5 = node_on_sf_9(5,isf) + il6 = node_on_sf_9(6,isf) + il7 = node_on_sf_9(7,isf) + il8 = node_on_sf_9(8,isf) + il9 = node_on_sf_9(9,isf) +! + i1 = ie(iele,il1) + i2 = ie(iele,il2) + i3 = ie(iele,il3) + i4 = ie(iele,il4) + i5 = ie(iele,il5) + i6 = ie(iele,il6) + i7 = ie(iele,il7) + i8 = ie(iele,il8) + i9 = ie(iele,il9) +! + dxxi = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) & + & + xx(i3, 1)*dnxi( 3) + xx(i4, 1)*dnxi( 4) & + & + xx(i5, 1)*dnxi( 5) + xx(i6, 1)*dnxi( 6) & + & + xx(i7, 1)*dnxi( 7) + xx(i8, 1)*dnxi( 8) & + & + xx(i9, 1)*dnxi( 9) +! + dxei = xx(i1, 1)*dnei( 1) + xx(i2, 1)*dnei( 2) & + & + xx(i3, 1)*dnei( 3) + xx(i4, 1)*dnei( 4) & + & + xx(i5, 1)*dnei( 5) + xx(i6, 1)*dnei( 6) & + & + xx(i7, 1)*dnei( 7) + xx(i8, 1)*dnei( 8) & + & + xx(i9, 1)*dnei( 9) +! +! + dyxi = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) & + & + xx(i3, 2)*dnxi( 3) + xx(i4, 2)*dnxi( 4) & + & + xx(i5, 2)*dnxi( 5) + xx(i6, 2)*dnxi( 6) & + & + xx(i7, 2)*dnxi( 7) + xx(i8, 2)*dnxi( 8) & + & + xx(i9, 2)*dnxi( 9) +! + dyei = xx(i1, 2)*dnei( 1) + xx(i2, 2)*dnei( 2) & + & + xx(i3, 2)*dnei( 3) + xx(i4, 2)*dnei( 4) & + & + xx(i5, 2)*dnei( 5) + xx(i6, 2)*dnei( 6) & + & + xx(i7, 2)*dnei( 7) + xx(i8, 2)*dnei( 8) & + & + xx(i9, 2)*dnei( 9) +! +! + dzxi = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) & + & + xx(i3, 3)*dnxi( 3) + xx(i4, 3)*dnxi( 4) & + & + xx(i5, 3)*dnxi( 5) + xx(i6, 3)*dnxi( 6) & + & + xx(i7, 3)*dnxi( 7) + xx(i8, 3)*dnxi( 8) & + & + xx(i9, 3)*dnxi( 9) +! + dzei = xx(i1, 3)*dnei( 1) + xx(i2, 3)*dnei( 2) & + & + xx(i3, 3)*dnei( 3) + xx(i4, 3)*dnei( 4) & + & + xx(i5, 3)*dnei( 5) + xx(i6, 3)*dnei( 6) & + & + xx(i7, 3)*dnei( 7) + xx(i8, 3)*dnei( 8) & + & + xx(i9, 3)*dnei( 9) +! +! +! + xsf(inum) = dyxi*dzei - dzxi*dyei + ysf(inum) = dzxi*dxei - dxxi*dzei + zsf(inum) = dxxi*dyei - dyxi*dxei +! + xjac(inum) = sqrt( xsf(inum)*xsf(inum) & + & + ysf(inum)*ysf(inum) & + & + zsf(inum)*zsf(inum) ) +! + if (xjac(inum) .eq. 0.0d0) then + axjac(inum) = 1.0d+30 + else + axjac(inum) = 1.0d00 / xjac(inum) + end if +! + end do + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_sf_grp_9 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_sf_grp_lag diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_linear.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_linear.f90 new file mode 100644 index 00000000..7b0cb50c --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_linear.f90 @@ -0,0 +1,136 @@ +! +! module cal_jacobian_sf_grp_linear +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! +! subroutine s_cal_jacobian_sf_grp_4(numnod, numele, & +! & ie, xx, num_surf, num_surf_bc, surf_item, & +! & np_smp, num_surf_smp, isurf_grp_smp_stack, & +! & xjac, axjac, xsf, ysf, zsf, dnxi, dnei) +! + module cal_jacobian_sf_grp_linear +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_sf_grp_4(numnod, numele, & + & ie, xx, num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & xjac, axjac, xsf, ysf, zsf, dnxi, dnei) +! + use m_constants + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod, numele + integer(kind = kint), intent(in) :: ie(numele, num_t_linear) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: np_smp + integer (kind=kint), intent(in) :: num_surf_smp + integer (kind=kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer (kind=kint), intent(in) :: num_surf + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + real(kind = kreal), intent(in) :: dnxi(num_linear_sf) + real(kind = kreal), intent(in) :: dnei(num_linear_sf) +! + real(kind = kreal), intent(inout) :: xjac(num_surf_bc) + real(kind = kreal), intent(inout) :: axjac(num_surf_bc) + real(kind = kreal), intent(inout) :: xsf(num_surf_bc) + real(kind = kreal), intent(inout) :: ysf(num_surf_bc) + real(kind = kreal), intent(inout) :: zsf(num_surf_bc) +! + integer(kind = kint) :: ip, igrp, ist, ied, inum, iele, isf, jp +! + real(kind = kreal) :: dxxi, dxei + real(kind = kreal) :: dyxi, dyei + real(kind = kreal) :: dzxi, dzei +! + integer(kind = kint) :: i1, i2, i3, i4 + integer(kind = kint) :: il1, il2, il3, il4 +! +! +!$omp parallel do private & +!$omp& (ist,ied,igrp,jp,inum,iele,isf, & +!$omp& i1,i2,i3,i4,il1,il2,il3,il4, & +!$omp& dxxi,dxei,dyxi,dyei,dzxi,dzei) + do ip = 1, np_smp + do igrp = 1, num_surf + jp = np_smp*(igrp-1) + ip + ist = isurf_grp_smp_stack(jp-1) + 1 + ied = isurf_grp_smp_stack(jp) +! +!cdir nodep noloopchg + do inum = ist, ied +! + iele = surf_item(1,inum) + isf = surf_item(2,inum) +! + il1 = node_on_sf_4(1,isf) + il2 = node_on_sf_4(2,isf) + il3 = node_on_sf_4(3,isf) + il4 = node_on_sf_4(4,isf) +! + i1 = ie(iele,il1) + i2 = ie(iele,il2) + i3 = ie(iele,il3) + i4 = ie(iele,il4) +! + dxxi = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) & + & + xx(i3, 1)*dnxi( 3) + xx(i4, 1)*dnxi( 4) +! + dxei = xx(i1, 1)*dnei( 1) + xx(i2, 1)*dnei( 2) & + & + xx(i3, 1)*dnei( 3) + xx(i4, 1)*dnei( 4) +! +! + dyxi = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) & + & + xx(i3, 2)*dnxi( 3) + xx(i4, 2)*dnxi( 4) +! + dyei = xx(i1, 2)*dnei( 1) + xx(i2, 2)*dnei( 2) & + & + xx(i3, 2)*dnei( 3) + xx(i4, 2)*dnei( 4) +! +! + dzxi = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) & + & + xx(i3, 3)*dnxi( 3) + xx(i4, 3)*dnxi( 4) +! + dzei = xx(i1, 3)*dnei( 1) + xx(i2, 3)*dnei( 2) & + & + xx(i3, 3)*dnei( 3) + xx(i4, 3)*dnei( 4) +! +! +! + xsf(inum) = dyxi*dzei - dzxi*dyei + ysf(inum) = dzxi*dxei - dxxi*dzei + zsf(inum) = dxxi*dyei - dyxi*dxei +! + xjac(inum) = sqrt( xsf(inum)*xsf(inum) & + & + ysf(inum)*ysf(inum) & + & + zsf(inum)*zsf(inum) ) +! + if (xjac(inum) .eq. 0.0d0) then + axjac(inum) = 1.0d+30 + else + axjac(inum) = 1.0d00 / xjac(inum) + end if +! + end do + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_sf_grp_4 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_sf_grp_linear diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_quad.f90 new file mode 100644 index 00000000..595a79eb --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_jacobian_sf_grp_quad.f90 @@ -0,0 +1,157 @@ +! +! module cal_jacobian_sf_grp_quad +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! +! subroutine s_cal_jacobian_sf_grp_8(numnod, numele, & +! & ie, xx, num_surf, num_surf_bc, surf_item, & +! & np_smp, num_surf_smp, isurf_grp_smp_stack, & +! & xjac, axjac, xsf, ysf, zsf, dnxi, dnei) +! + module cal_jacobian_sf_grp_quad +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_jacobian_sf_grp_8(numnod, numele, & + & ie, xx, num_surf, num_surf_bc, surf_item, & + & np_smp, num_surf_smp, isurf_grp_smp_stack, & + & xjac, axjac, xsf, ysf, zsf, dnxi, dnei) +! + use m_constants + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod, numele + integer(kind = kint), intent(in) :: ie(numele, num_t_quad) + real(kind = kreal), intent(in) :: xx(numnod,3) +! + integer (kind=kint), intent(in) :: np_smp + integer (kind=kint), intent(in) :: num_surf_smp + integer (kind=kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) +! + integer (kind=kint), intent(in) :: num_surf + integer (kind=kint), intent(in) :: num_surf_bc + integer (kind=kint), intent(in) :: surf_item(2,num_surf_bc) +! + real(kind = kreal), intent(in) :: dnxi(num_quad_sf) + real(kind = kreal), intent(in) :: dnei(num_quad_sf) +! + real(kind = kreal), intent(inout) :: xjac(num_surf_bc) + real(kind = kreal), intent(inout) :: axjac(num_surf_bc) + real(kind = kreal), intent(inout) :: xsf(num_surf_bc) + real(kind = kreal), intent(inout) :: ysf(num_surf_bc) + real(kind = kreal), intent(inout) :: zsf(num_surf_bc) +! + integer(kind = kint) :: ip, igrp, ist, ied, inum, iele, isf, jp +! + real(kind = kreal) :: dxxi, dxei + real(kind = kreal) :: dyxi, dyei + real(kind = kreal) :: dzxi, dzei +! + integer(kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 + integer(kind = kint) :: il1, il2, il3, il4, il5, il6, il7, il8 +! +! +!$omp parallel do private & +!$omp& (ist,ied,igrp,jp,inum,iele,isf, & +!$omp& i1,i2,i3,i4,i5,i6,i7,i8, & +!$omp& il1,il2,il3,il4,il5,il6,il7,il8, & +!$omp& dxxi,dxei,dyxi,dyei,dzxi,dzei) + do ip = 1, np_smp + do igrp = 1, num_surf + jp = np_smp*(igrp-1) + ip + ist = isurf_grp_smp_stack(jp-1) + 1 + ied = isurf_grp_smp_stack(jp) +! +!cdir nodep noloopchg + do inum = ist, ied +! + iele = surf_item(1,inum) + isf = surf_item(2,inum) +! + il1 = node_on_sf_8(1,isf) + il2 = node_on_sf_8(2,isf) + il3 = node_on_sf_8(3,isf) + il4 = node_on_sf_8(4,isf) + il5 = node_on_sf_8(5,isf) + il6 = node_on_sf_8(6,isf) + il7 = node_on_sf_8(7,isf) + il8 = node_on_sf_8(8,isf) +! + i1 = ie(iele,il1) + i2 = ie(iele,il2) + i3 = ie(iele,il3) + i4 = ie(iele,il4) + i5 = ie(iele,il5) + i6 = ie(iele,il6) + i7 = ie(iele,il7) + i8 = ie(iele,il8) +! + dxxi = xx(i1, 1)*dnxi( 1) + xx(i2, 1)*dnxi( 2) & + & + xx(i3, 1)*dnxi( 3) + xx(i4, 1)*dnxi( 4) & + & + xx(i5, 1)*dnxi( 5) + xx(i6, 1)*dnxi( 6) & + & + xx(i7, 1)*dnxi( 7) + xx(i8, 1)*dnxi( 8) +! + dxei = xx(i1, 1)*dnei( 1) + xx(i2, 1)*dnei( 2) & + & + xx(i3, 1)*dnei( 3) + xx(i4, 1)*dnei( 4) & + & + xx(i5, 1)*dnei( 5) + xx(i6, 1)*dnei( 6) & + & + xx(i7, 1)*dnei( 7) + xx(i8, 1)*dnei( 8) +! +! + dyxi = xx(i1, 2)*dnxi( 1) + xx(i2, 2)*dnxi( 2) & + & + xx(i3, 2)*dnxi( 3) + xx(i4, 2)*dnxi( 4) & + & + xx(i5, 2)*dnxi( 5) + xx(i6, 2)*dnxi( 6) & + & + xx(i7, 2)*dnxi( 7) + xx(i8, 2)*dnxi( 8) +! + dyei = xx(i1, 2)*dnei( 1) + xx(i2, 2)*dnei( 2) & + & + xx(i3, 2)*dnei( 3) + xx(i4, 2)*dnei( 4) & + & + xx(i5, 2)*dnei( 5) + xx(i6, 2)*dnei( 6) & + & + xx(i7, 2)*dnei( 7) + xx(i8, 2)*dnei( 8) +! +! + dzxi = xx(i1, 3)*dnxi( 1) + xx(i2, 3)*dnxi( 2) & + & + xx(i3, 3)*dnxi( 3) + xx(i4, 3)*dnxi( 4) & + & + xx(i5, 3)*dnxi( 5) + xx(i6, 3)*dnxi( 6) & + & + xx(i7, 3)*dnxi( 7) + xx(i8, 3)*dnxi( 8) +! + dzei = xx(i1, 3)*dnei( 1) + xx(i2, 3)*dnei( 2) & + & + xx(i3, 3)*dnei( 3) + xx(i4, 3)*dnei( 4) & + & + xx(i5, 3)*dnei( 5) + xx(i6, 3)*dnei( 6) & + & + xx(i7, 3)*dnei( 7) + xx(i8, 3)*dnei( 8) +! +! +! + xsf(inum) = dyxi*dzei - dzxi*dyei + ysf(inum) = dzxi*dxei - dxxi*dzei + zsf(inum) = dxxi*dyei - dyxi*dxei +! + xjac(inum) = sqrt( xsf(inum)*xsf(inum) & + & + ysf(inum)*ysf(inum) & + & + zsf(inum)*zsf(inum) ) +! + if (xjac(inum) .eq. 0.0d0) then + axjac(inum) = 1.0d+30 + else + axjac(inum) = 1.0d00 / xjac(inum) + end if +! + end do + end do + end do +!$omp end parallel do +! + end subroutine s_cal_jacobian_sf_grp_8 +! +!----------------------------------------------------------------------- +! + end module cal_jacobian_sf_grp_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_layered_volumes.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_layered_volumes.f90 new file mode 100644 index 00000000..9532a65c --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_layered_volumes.f90 @@ -0,0 +1,267 @@ +! +! module cal_layered_volumes +! +! Written by H. Matsui on Aug., 2007 +! +! Volume integration: s_cal_layered_volumes +! subroutine s_cal_layered_volumes +! + module cal_layered_volumes +! + use m_precision +! + use m_constants + use m_machine_parameter +! + implicit none +! + real(kind = kreal), allocatable :: vol_l(:) + real(kind = kreal), allocatable :: vol_l_smp(:) + real(kind = kreal) :: vol_w + private :: vol_l_smp, vol_l, vol_w +! + private :: int_volume_4_sgs_layer, int_volume_dynamic_grpsmp + private :: allocate_work_layerd_volume + private :: deallocate_work_layerd_volume + private :: sum_volumes_4_layerd, cal_a_vol_4_layerd +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_cal_layered_volumes(ele, layer_tbl) +! + use t_geometry_data + use t_layering_ele_list +! + type(element_data), intent(in) :: ele + type(layering_tbl), intent(inout) :: layer_tbl +! + integer (kind = kint) :: inum +! +! + call alloc_layering_volumes_type(layer_tbl) + call allocate_work_layerd_volume(layer_tbl%e_grp%num_grp) +! +! if(layer_tbl%minlayer_4_smp & +! & .gt. layer_tbl%min_item_layer_d_smp) then + if (iflag_debug.eq.1) write(*,*) 'int_volume_4_sgs_layer' + call int_volume_4_sgs_layer & + & (ele%numele, ele%interior_ele, ele%volume_ele, & + & layer_tbl%e_grp%num_grp, layer_tbl%e_grp%num_item, & + & layer_tbl%e_grp%istack_grp_smp, layer_tbl%e_grp%item_grp) +! else +! if (iflag_debug.eq.1) write(*,*) 'int_volume_dynamic_grpsmp' +! call int_volume_dynamic_grpsmp & +! & (ele%numele, ele%interior_ele, ele%volume_ele, & +! & layer_tbl%e_grp%num_grp, layer_tbl%e_grp%num_item, & +! & layer_tbl%e_grp%istack_grp, layer_tbl%istack_item_layer_d_smp, & +! & layer_tbl%e_grp%item_grp) +! end if +! + if (iflag_debug.eq.1) write(*,*) 'sum_volumes_4_layerd' + call sum_volumes_4_layerd(layer_tbl%e_grp%num_grp, & + & layer_tbl%volumes_layer, layer_tbl%vol_total_layer) + if (iflag_debug.eq.1) write(*,*) 'cal_a_vol_4_layerd' + call cal_a_vol_4_layerd & + & (layer_tbl%e_grp%num_grp, layer_tbl%volumes_layer, & + & layer_tbl%vol_total_layer, layer_tbl%a_vol_layer, & + & layer_tbl%a_vol_total_layer) +! + call deallocate_work_layerd_volume +! + if (iflag_debug.eq.1) then + write(*,*) 'vol_total_layer: ', layer_tbl%vol_total_layer(1) + write(*,*) 'layer, volumes_layer' + do inum = 1, layer_tbl%e_grp%num_grp + write(*,*) inum, layer_tbl%volumes_layer(inum) + end do + end if +! + end subroutine s_cal_layered_volumes +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine allocate_work_layerd_volume(n_layer_d) +! + integer (kind = kint), intent(in) :: n_layer_d +! +! + allocate (vol_l(n_layer_d)) + allocate (vol_l_smp(np_smp)) +! + if(n_layer_d .gt. 0) vol_l = zero + vol_l_smp = zero +! + end subroutine allocate_work_layerd_volume +! +! --------------------------------------------------------------------- +! + subroutine deallocate_work_layerd_volume +! +! + deallocate (vol_l, vol_l_smp) +! + end subroutine deallocate_work_layerd_volume +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine int_volume_4_sgs_layer(numele, interior_ele, & + & volume_ele, n_layer_d, n_item_layer_d, & + & layer_stack_smp, item_layer) +! + integer (kind = kint), intent(in) :: numele + integer (kind = kint), intent(in) :: interior_ele(numele) + real(kind = kreal), intent(in) :: volume_ele(numele) +! + integer (kind = kint), intent(in) :: n_layer_d, n_item_layer_d + integer (kind = kint), intent(in) & + & :: layer_stack_smp(0:n_layer_d*np_smp) + integer (kind = kint), intent(in) :: item_layer(n_item_layer_d) +! + integer (kind = kint) :: iproc, iele, iele0 + integer (kind = kint) :: is, ist, ied, igrp +! +! + vol_w = zero + vol_l(1:n_layer_d) = zero +! + do igrp = 1, n_layer_d +! + vol_l_smp(1:np_smp) = zero +!$omp parallel do private(is,ist,ied,iele0,iele) + do iproc = 1, np_smp + is = (igrp-1)*np_smp + iproc + ist = layer_stack_smp(is-1) + 1 + ied = layer_stack_smp(is ) +! +!$cdir nodep + do iele0 = ist, ied + iele = item_layer(iele0) + vol_l_smp(iproc) = vol_l_smp(iproc) + volume_ele(iele) & + & * dble(interior_ele(iele)) + end do + end do +!$omp end parallel do +! + do iproc = 1, np_smp + vol_l(igrp) = vol_l(igrp) + vol_l_smp(iproc) + end do + vol_w = vol_w + vol_l(igrp) + end do +! + end subroutine int_volume_4_sgs_layer +! +! --------------------------------------------------------------------- +! + subroutine int_volume_dynamic_grpsmp(numele, interior_ele, & + & volume_ele, n_layer_d, n_item_layer_d, & + & layer_stack, istack_item_layer_d_smp, item_layer) +! + integer (kind = kint), intent(in) :: numele + integer (kind = kint), intent(in) :: interior_ele(numele) + real(kind = kreal), intent(in) :: volume_ele(numele) +! + integer (kind = kint), intent(in) :: n_layer_d, n_item_layer_d + integer (kind = kint), intent(in) :: layer_stack(0:n_layer_d) + integer (kind = kint), intent(in) & + & :: istack_item_layer_d_smp(0:np_smp) + integer (kind = kint), intent(in) :: item_layer(n_item_layer_d) +! + integer (kind = kint) :: igrp, iele, iele0, iproc + integer (kind = kint) :: ist, ied, ist_num, ied_num +! +! + vol_l = zero + vol_w = zero + vol_l_smp = zero +! +!$omp parallel do & +!$omp& private(ist_num,ied_num,igrp,ist,ied,iele,iele0) + do iproc = 1, np_smp + ist_num = istack_item_layer_d_smp(iproc-1) + 1 + ied_num = istack_item_layer_d_smp(iproc ) +! + vol_l(ist_num:ied_num) = zero + do igrp = ist_num, ied_num + ist = layer_stack(igrp-1) + 1 + ied = layer_stack(igrp) +! +!$cdir nodep + do iele0 = ist, ied + iele = item_layer(iele0) + vol_l(igrp) = vol_l(igrp) + volume_ele(iele) & + & * dble(interior_ele(iele)) + end do + vol_l_smp(iproc) = vol_l_smp(iproc) + vol_l(igrp) + end do + end do +!$omp end parallel do +! + do iproc = 1, np_smp + vol_w = vol_w + vol_l_smp(iproc) + end do +! + end subroutine int_volume_dynamic_grpsmp +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine sum_volumes_4_layerd & + & (n_layer_d, volumes_layer, vol_total_layer) +! + use calypso_mpi + use calypso_mpi_real + use transfer_to_long_integers +! + integer (kind = kint), intent(in) :: n_layer_d + real(kind = kreal), intent(inout) :: volumes_layer(n_layer_d) + real(kind = kreal), intent(inout) :: vol_total_layer(1) +! +! + volumes_layer = zero + vol_total_layer(1) = zero + call calypso_mpi_allreduce_real & + & (vol_l, volumes_layer, cast_long(n_layer_d), MPI_SUM) + call calypso_mpi_allreduce_one_real & + & (vol_w, vol_total_layer(1), MPI_SUM) +! + end subroutine sum_volumes_4_layerd +! +! --------------------------------------------------------------------- +! + subroutine cal_a_vol_4_layerd(n_layer_d, volumes_layer, & + & vol_total_layer, a_vol_layer, a_vol_total_layer) +! + integer (kind = kint), intent(in) :: n_layer_d + real(kind = kreal), intent(in) :: volumes_layer(n_layer_d) + real(kind = kreal), intent(in) :: vol_total_layer(1) + real(kind = kreal), intent(inout) :: a_vol_layer(n_layer_d) + real(kind = kreal), intent(inout) :: a_vol_total_layer(1) +! + integer (kind = kint) :: inum +! +! + do inum = 1, n_layer_d + if (volumes_layer(inum) .eq. zero) then + a_vol_layer(inum) = 1.0d30 + else + a_vol_layer(inum) = one / volumes_layer(inum) + end if + end do +! + if (vol_total_layer(1) .eq. zero) then + a_vol_total_layer(1) = 1.0d30 + else + a_vol_total_layer(1) = one / vol_total_layer(1) + end if +! + end subroutine cal_a_vol_4_layerd +! +! --------------------------------------------------------------------- +! + end module cal_layered_volumes diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_func_infty_3d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_func_infty_3d.f90 new file mode 100644 index 00000000..ccb83d01 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_func_infty_3d.f90 @@ -0,0 +1,191 @@ +! +! module cal_shape_func_infty_3d +! +! modified by H. Matsui on Aug., 2006 +! +! subroutine s_cal_shape_func_infty_linear(ntot_int_3d, xk, & +! & an_infty, dnxi_infty, dnei_infty, dnzi_infty, & +! & xi, ei, zi) +! subroutine s_cal_shape_func_infty_quad(ntot_int_3d, xk, an_infty,& +! & dnxi_infty, dnei_infty, dnzi_infty, xi, ei, zi) +! subroutine s_cal_shape_func_infty_lag(ntot_int_3d, xk, an_infty, & +! & dnxi_infty, dnei_infty, dnzi_infty, xi, ei, zi) +! + module cal_shape_func_infty_3d +! + use m_precision +! + use m_geometry_constants + use set_shape_elements_infty_sf +! + implicit none +! + real (kind=kreal) :: xi_nega, ei_nega, zi_nega + real (kind=kreal) :: xi_posi, ei_posi, zi_posi + real (kind=kreal) :: xi_sqre, ei_sqre, zi_sqre + real (kind=kreal) :: xi_inf, ei_inf, zi_inf + real (kind=kreal) :: dxi_inf, dei_inf, dzi_inf +! + private :: xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi + private :: xi_sqre, ei_sqre, zi_sqre + private :: xi_inf, ei_inf, zi_inf, dxi_inf, dei_inf, dzi_inf +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_func_infty_linear(ntot_int_3d, xk, & + & an_infty, dnxi_infty, dnei_infty, dnzi_infty, & + & xi, ei, zi) +! + use shape_func_3d_linear +! + integer (kind=kint), intent(in) :: ntot_int_3d + real (kind=kreal), intent(in) :: xk + real (kind=kreal), intent(in) :: xi(ntot_int_3d) + real (kind=kreal), intent(in) :: ei(ntot_int_3d) + real (kind=kreal), intent(in) :: zi(ntot_int_3d) +! + real (kind=kreal), intent(inout) & + & :: an_infty(num_t_linear,nsurf_4_ele,ntot_int_3d) + real (kind=kreal), intent(inout) & + & :: dnxi_infty(num_t_linear,nsurf_4_ele,ntot_int_3d) + real (kind=kreal), intent(inout) & + & :: dnei_infty(num_t_linear,nsurf_4_ele,ntot_int_3d) + real (kind=kreal), intent(inout) & + & :: dnzi_infty(num_t_linear,nsurf_4_ele,ntot_int_3d) +! + integer (kind=kint) :: isf, ix +! +! + do isf = 1, nsurf_4_ele + do ix = 1, ntot_int_3d + call s_shape_elenents_inf_aw_3d(isf, xk, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, xi_inf, ei_inf, zi_inf, & + & dxi_inf, dei_inf, dzi_inf, xi(ix), ei(ix), zi(ix) ) +! + call shape_function_an_1( an_infty(1,isf,ix), & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi) + call shape_function_dnxi_1( dnxi_infty(1,isf,ix), & + & ei_nega, zi_nega, ei_posi, zi_posi, dxi_inf) + call shape_function_dnei_1( dnei_infty(1,isf,ix), & + & xi_nega, zi_nega, xi_posi, zi_posi, dei_inf) + call shape_function_dnzi_1( dnzi_infty(1,isf,ix), & + & xi_nega, ei_nega, xi_posi, ei_posi, dzi_inf) + end do + end do +! +! + end subroutine s_cal_shape_func_infty_linear +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_func_infty_quad(ntot_int_3d, xk, an_infty, & + & dnxi_infty, dnei_infty, dnzi_infty, xi, ei, zi) +! + use shape_func_3d_quad +! + integer (kind=kint), intent(in) :: ntot_int_3d + real (kind=kreal), intent(in) :: xk + real (kind=kreal), intent(in) :: xi(ntot_int_3d) + real (kind=kreal), intent(in) :: ei(ntot_int_3d) + real (kind=kreal), intent(in) :: zi(ntot_int_3d) +! + real (kind=kreal), intent(inout) & + & :: an_infty(num_t_quad,nsurf_4_ele,ntot_int_3d) + real (kind=kreal), intent(inout) & + & :: dnxi_infty(num_t_quad,nsurf_4_ele,ntot_int_3d) + real (kind=kreal), intent(inout) & + & :: dnei_infty(num_t_quad,nsurf_4_ele,ntot_int_3d) + real (kind=kreal), intent(inout) & + & :: dnzi_infty(num_t_quad,nsurf_4_ele,ntot_int_3d) +! + integer (kind=kint) :: isf, ix +! +! + do isf = 1, nsurf_4_ele + do ix = 1, ntot_int_3d + call s_shape_elenents_inf_aw_3d(isf, xk, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, xi_inf, ei_inf, zi_inf, & + & dxi_inf, dei_inf, dzi_inf, xi(ix), ei(ix), zi(ix) ) +! + call shape_function_an_20( an_infty(1,isf,ix), & + & xi_inf, ei_inf, zi_inf, xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre) + call shape_function_dnxi_20( dnxi_infty(1,isf,ix), & + & xi_inf, ei_inf, zi_inf, xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & + & dxi_inf) + call shape_function_dnei_20( dnei_infty(1,isf,ix), & + & xi_inf, ei_inf, zi_inf, xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & + & dei_inf) + call shape_function_dnzi_20( dnzi_infty(1,isf,ix), & + & xi_inf, ei_inf, zi_inf, xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & + & dzi_inf) + end do + end do +! +! + end subroutine s_cal_shape_func_infty_quad +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_func_infty_lag(ntot_int_3d, xk, an_infty, & + & dnxi_infty, dnei_infty, dnzi_infty, xi, ei, zi) +! + use shape_func_3d_lag +! + integer (kind=kint), intent(in) :: ntot_int_3d + real (kind=kreal), intent(in) :: xk + real (kind=kreal), intent(in) :: xi(ntot_int_3d) + real (kind=kreal), intent(in) :: ei(ntot_int_3d) + real (kind=kreal), intent(in) :: zi(ntot_int_3d) +! + real (kind=kreal), intent(inout) & + & :: an_infty(num_t_lag,nsurf_4_ele,ntot_int_3d) + real (kind=kreal), intent(inout) & + & :: dnxi_infty(num_t_lag,nsurf_4_ele,ntot_int_3d) + real (kind=kreal), intent(inout) & + & :: dnei_infty(num_t_lag,nsurf_4_ele,ntot_int_3d) + real (kind=kreal), intent(inout) & + & :: dnzi_infty(num_t_lag,nsurf_4_ele,ntot_int_3d) +! + integer (kind=kint) :: isf, ix +! +! + do isf = 1, nsurf_4_ele + do ix = 1, ntot_int_3d + call s_shape_elenents_inf_aw_3d(isf, xk, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, xi_inf, ei_inf, zi_inf, & + & dxi_inf, dei_inf, dzi_inf, xi(ix), ei(ix), zi(ix) ) +! + call shape_function_an_27( an_infty(1,isf,ix), & + & xi_inf, ei_inf, zi_inf, xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre) + call shape_function_dnxi_27( dnxi_infty(1,isf,ix), & + & xi_inf, ei_inf, zi_inf, xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & + & dxi_inf) + call shape_function_dnei_27( dnei_infty(1,isf,ix), & + & xi_inf, ei_inf, zi_inf, xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & + & dei_inf) + call shape_function_dnzi_27( dnzi_infty(1,isf,ix), & + & xi_inf, ei_inf, zi_inf, xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & + & dzi_inf) + end do + end do +! + end subroutine s_cal_shape_func_infty_lag +! +!----------------------------------------------------------------------- +! + end module cal_shape_func_infty_3d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_function_1d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_function_1d.f90 new file mode 100644 index 00000000..317a9885 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_function_1d.f90 @@ -0,0 +1,88 @@ +!>@file cal_shape_function_1d.f90 +!! module cal_shape_function_1d +!! +!!@author H. Matsui +!!@date Programmed in Dec., 2008 +! +!> @brief caliculate shape function and differences at Gauss points +!! +!!@verbatim +!! subroutine s_cal_shape_function_1d_linear(ntot_int_1d, & +!! & an, dnxi, xi) +!! subroutine s_cal_shape_function_1d_quad(ntot_int_1d, & +!! & an, dnxi, xi) +!!@endverbatim +! + module cal_shape_function_1d +! + use m_precision +! + use m_constants + use m_geometry_constants + use shape_func_elements +! + implicit none +! + real (kind=kreal) :: xi_nega, xi_posi, xi_sqre + private :: xi_nega, xi_posi, xi_sqre +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_function_1d_linear(ntot_int_1d, an, dnxi, & + & xi) +! + use shape_func_1d_linear +! + integer (kind=kint), intent(in) :: ntot_int_1d + real(kind=kreal), intent(in) :: xi(ntot_int_1d) +! + real(kind=kreal), intent(inout) & + & :: an(num_linear_edge,ntot_int_1d) + real(kind=kreal), intent(inout) & + & :: dnxi(num_linear_edge,ntot_int_1d) +! + integer (kind=kint) :: ix +! +! + do ix = 1, ntot_int_1d + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi(ix) ) +! + call shape_function_an_1d_1( an(1,ix), xi_nega, xi_posi) + call shape_function_dnxi_1d_1( dnxi(1,ix), one) + end do +! + end subroutine s_cal_shape_function_1d_linear +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_function_1d_quad(ntot_int_1d, an, dnxi, & + & xi) +! + use shape_func_1d_quad +! + integer (kind=kint), intent(in) :: ntot_int_1d + real(kind=kreal), intent(in) :: xi(ntot_int_1d) +! + real(kind=kreal), intent(inout) :: an(num_quad_edge,ntot_int_1d) + real(kind=kreal), intent(inout) :: dnxi(num_quad_edge,ntot_int_1d) +! + integer (kind=kint) :: ix +! +! + do ix = 1, ntot_int_1d + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi(ix) ) +! + call shape_function_an_1d_20( an(1,ix), xi(ix), & + & xi_nega, xi_posi, xi_sqre) + call shape_function_dnxi_1d_20(dnxi(1,ix), xi(ix), one ) + end do +! + end subroutine s_cal_shape_function_1d_quad +! +!----------------------------------------------------------------------- +! + end module cal_shape_function_1d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_function_2d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_function_2d.f90 new file mode 100644 index 00000000..1b9885d9 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_function_2d.f90 @@ -0,0 +1,134 @@ +! +! module cal_shape_function_2d +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on Aug., 2006 +! +! subroutine s_cal_shape_function_2d_linear(ntot_int_2d, an, dnxi, & +! & dnei, xi, ei) +! subroutine s_cal_shape_function_2d_quad(ntot_int_2d, an, dnxi, & +! & dnei, xi, ei) +! subroutine s_cal_shape_function_2d_lag(ntot_int_2d, an, dnxi, & +! & dnei, xi, ei) +! + module cal_shape_function_2d +! + use m_precision +! + use m_constants + use m_geometry_constants + use shape_func_elements +! + implicit none +! + real (kind=kreal) :: xi_nega, ei_nega + real (kind=kreal) :: xi_posi, ei_posi + real (kind=kreal) :: xi_sqre, ei_sqre +! + private :: xi_nega, ei_nega, xi_posi, ei_posi + private :: xi_sqre, ei_sqre +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_function_2d_linear(ntot_int_2d, an, dnxi, & + & dnei, xi, ei) +! + use shape_func_2d_linear +! + integer (kind=kint), intent(in) :: ntot_int_2d + real(kind=kreal), intent(in) :: xi(ntot_int_2d) + real(kind=kreal), intent(in) :: ei(ntot_int_2d) +! + real(kind=kreal), intent(inout) :: an(num_linear_sf,ntot_int_2d) + real(kind=kreal), intent(inout) :: dnxi(num_linear_sf,ntot_int_2d) + real(kind=kreal), intent(inout) :: dnei(num_linear_sf,ntot_int_2d) +! + integer (kind=kint) :: ix +! +! + do ix = 1, ntot_int_2d + call s_shape_elenents_aw_2d(xi_nega, ei_nega, & + & xi_posi, ei_posi, xi_sqre, ei_sqre, xi(ix), ei(ix) ) +! + call shape_function_an_sf_1( an(1,ix), xi_nega, ei_nega, & + & xi_posi, ei_posi) + call shape_function_dnxi_sf_1( dnxi(1,ix), ei_nega, ei_posi, & + & one) + call shape_function_dnei_sf_1( dnei(1,ix), xi_nega, xi_posi, & + & one) + end do +! + end subroutine s_cal_shape_function_2d_linear +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_function_2d_quad(ntot_int_2d, an, dnxi, & + & dnei, xi, ei) +! + use shape_func_2d_quad +! + integer (kind=kint), intent(in) :: ntot_int_2d + real(kind=kreal), intent(in) :: xi(ntot_int_2d) + real(kind=kreal), intent(in) :: ei(ntot_int_2d) +! + real(kind=kreal), intent(inout) :: an(num_quad_sf,ntot_int_2d) + real(kind=kreal), intent(inout) :: dnxi(num_quad_sf,ntot_int_2d) + real(kind=kreal), intent(inout) :: dnei(num_quad_sf,ntot_int_2d) +! + integer (kind=kint) :: ix +! +! + do ix = 1, ntot_int_2d + call s_shape_elenents_aw_2d(xi_nega, ei_nega, & + & xi_posi, ei_posi, xi_sqre, ei_sqre, xi(ix), ei(ix) ) +! + call shape_function_an_sf20( an(1,ix), xi(ix), ei(ix), & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre) + call shape_function_dnxi_sf20( dnxi(1,ix), xi(ix), ei(ix), & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, one) + call shape_function_dnei_sf20( dnei(1,ix), xi(ix), ei(ix), & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, one) + end do +! + end subroutine s_cal_shape_function_2d_quad +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_function_2d_lag(ntot_int_2d, an, dnxi, & + & dnei, xi, ei) +! + use shape_func_2d_lag +! + integer (kind=kint), intent(in) :: ntot_int_2d + real (kind=kreal), intent(in) :: xi(ntot_int_2d) + real (kind=kreal), intent(in) :: ei(ntot_int_2d) +! + real (kind=kreal), intent(inout) :: an(num_lag_sf,ntot_int_2d) + real (kind=kreal), intent(inout) :: dnxi(num_lag_sf,ntot_int_2d) + real (kind=kreal), intent(inout) :: dnei(num_lag_sf,ntot_int_2d) +! + integer (kind=kint) :: ix +! +! + do ix = 1, ntot_int_2d + call s_shape_elenents_aw_2d(xi_nega, ei_nega, & + & xi_posi, ei_posi, xi_sqre, ei_sqre, xi(ix), ei(ix) ) +! + call shape_function_an_sf27( an(1,ix), xi(ix), ei(ix), & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre) + call shape_function_dnxi_sf27( dnxi(1,ix), xi(ix), ei(ix), & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, one) + call shape_function_dnei_sf27( dnei(1,ix), xi(ix), ei(ix), & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, one) + end do +! + end subroutine s_cal_shape_function_2d_lag +! +!----------------------------------------------------------------------- +! + end module cal_shape_function_2d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_function_3d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_function_3d.f90 new file mode 100644 index 00000000..71e92b68 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/cal_shape_function_3d.f90 @@ -0,0 +1,157 @@ +! +! module cal_shape_function_3d +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on Aug., 2006 +! +! subroutine s_cal_shape_function_linear(ntot_int_3d, an, dnxi, & +! & dnei, dnzi, xi, ei, zi) +! subroutine s_cal_shape_function_quad(ntot_int_3d, an, dnxi, & +! & dnei, dnzi, xi, ei, zi) +! subroutine s_cal_shape_function_lag(ntot_int_3d, an, dnxi, & +! & dnei, dnzi, xi, ei, zi) +! + module cal_shape_function_3d +! + use m_precision +! + use m_constants + use m_geometry_constants + use shape_func_elements +! + implicit none +! + real (kind=kreal) :: xi_nega, ei_nega, zi_nega + real (kind=kreal) :: xi_posi, ei_posi, zi_posi + real (kind=kreal) :: xi_sqre, ei_sqre, zi_sqre +! + private :: xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi + private :: xi_sqre, ei_sqre, zi_sqre +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_function_linear(ntot_int_3d, an, dnxi, & + & dnei, dnzi, xi, ei, zi) +! + use shape_func_3d_linear +! + integer (kind=kint), intent(in) :: ntot_int_3d + real (kind=kreal), intent(in) :: xi(ntot_int_3d) + real (kind=kreal), intent(in) :: ei(ntot_int_3d) + real (kind=kreal), intent(in) :: zi(ntot_int_3d) +! + real (kind=kreal), intent(inout) :: an(num_t_linear,ntot_int_3d) + real (kind=kreal), intent(inout) :: dnxi(num_t_linear,ntot_int_3d) + real (kind=kreal), intent(inout) :: dnei(num_t_linear,ntot_int_3d) + real (kind=kreal), intent(inout) :: dnzi(num_t_linear,ntot_int_3d) +! + integer (kind=kint) :: ix +! +! + do ix = 1, ntot_int_3d + call s_shape_elenents_aw_3d(xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & + & xi(ix), ei(ix), zi(ix) ) +! + call shape_function_an_1( an(1,ix), & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi) + call shape_function_dnxi_1( dnxi(1,ix), & + & ei_nega, zi_nega, ei_posi, zi_posi, one) + call shape_function_dnei_1( dnei(1,ix), & + & xi_nega, zi_nega, xi_posi, zi_posi, one) + call shape_function_dnzi_1( dnzi(1,ix), & + & xi_nega, ei_nega, xi_posi, ei_posi, one) + end do +! + end subroutine s_cal_shape_function_linear +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_function_quad(ntot_int_3d, an, dnxi, & + & dnei, dnzi, xi, ei, zi) +! + use shape_func_3d_quad +! + integer (kind=kint), intent(in) :: ntot_int_3d + real (kind=kreal), intent(in) :: xi(ntot_int_3d) + real (kind=kreal), intent(in) :: ei(ntot_int_3d) + real (kind=kreal), intent(in) :: zi(ntot_int_3d) +! + real (kind=kreal), intent(inout) :: an(num_t_quad,ntot_int_3d) + real (kind=kreal), intent(inout) :: dnxi(num_t_quad,ntot_int_3d) + real (kind=kreal), intent(inout) :: dnei(num_t_quad,ntot_int_3d) + real (kind=kreal), intent(inout) :: dnzi(num_t_quad,ntot_int_3d) +! + integer (kind=kint) :: ix +! +! + do ix = 1, ntot_int_3d + call s_shape_elenents_aw_3d(xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & + & xi(ix), ei(ix), zi(ix) ) +! + call shape_function_an_20( an(1,ix), xi(ix), ei(ix), zi(ix), & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre) + call shape_function_dnxi_20(dnxi(1,ix), xi(ix), ei(ix), zi(ix), & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, one) + call shape_function_dnei_20(dnei(1,ix), xi(ix), ei(ix), zi(ix), & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, one) + call shape_function_dnzi_20(dnzi(1,ix), xi(ix), ei(ix), zi(ix), & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, one) + end do +! + end subroutine s_cal_shape_function_quad +! +!----------------------------------------------------------------------- +! + subroutine s_cal_shape_function_lag(ntot_int_3d, an, dnxi, & + & dnei, dnzi, xi, ei, zi) +! + use shape_func_3d_lag +! + integer (kind=kint), intent(in) :: ntot_int_3d + real (kind=kreal), intent(in) :: xi(ntot_int_3d) + real (kind=kreal), intent(in) :: ei(ntot_int_3d) + real (kind=kreal), intent(in) :: zi(ntot_int_3d) +! + real (kind=kreal), intent(inout) :: an(num_t_lag,ntot_int_3d) + real (kind=kreal), intent(inout) :: dnxi(num_t_lag,ntot_int_3d) + real (kind=kreal), intent(inout) :: dnei(num_t_lag,ntot_int_3d) + real (kind=kreal), intent(inout) :: dnzi(num_t_lag,ntot_int_3d) +! + integer (kind=kint) :: ix +! +! + do ix = 1, ntot_int_3d + call s_shape_elenents_aw_3d(xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & + & xi(ix), ei(ix), zi(ix) ) +! + call shape_function_an_27( an(1,ix), xi(ix), ei(ix), zi(ix), & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre) + call shape_function_dnxi_27(dnxi(1,ix), xi(ix), ei(ix), zi(ix), & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, one) + call shape_function_dnei_27(dnei(1,ix), xi(ix), ei(ix), zi(ix), & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, one) + call shape_function_dnzi_27(dnzi(1,ix), xi(ix), ei(ix), zi(ix), & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, one) + end do +! + end subroutine s_cal_shape_function_lag +! +!----------------------------------------------------------------------- +! + end module cal_shape_function_3d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_1d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_1d.f90 new file mode 100644 index 00000000..0cde1051 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_1d.f90 @@ -0,0 +1,174 @@ +!>@file const_jacobians_1d.f90 +!! module const_jacobians_1d +!! +!!@author H. Matsui +!!@date Programmed in Dec., 2008 +! +!> @brief Construct Jacobians on edge +!! +!!@verbatim +!! subroutine sel_jacobian_edge(node, edge, g_FEM, spf_1d, jac_1d) +!! subroutine cal_jacobian_edge_linear & +!! & (node, edge, g_FEM, spf_1d_8, jac_1d) +!! subroutine cal_jacobian_edge_quad_on_l & +!! & (node, edge, g_FEM, spf_1d_20, jac_1d) +!! type(node_data), intent(in) :: node +!! type(edge_data), intent(in) :: edge +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(edge_shape_function), intent(inout) :: spf_1d +!! type(jacobians_1d), intent(inout) :: jac_1d +!!@endverbatim +! + module const_jacobians_1d +! + use m_precision + use m_machine_parameter + use m_geometry_constants +! + use t_geometry_data + use t_edge_data + use t_fem_gauss_int_coefs + use t_shape_functions + use t_jacobian_1d +! + implicit none +! + private :: cal_jacobian_edge_quad +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine sel_jacobian_edge(node, edge, g_FEM, spf_1d, jac_1d) +! + type(node_data), intent(in) :: node + type(edge_data), intent(in) :: edge + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(edge_shape_function), intent(inout) :: spf_1d + type(jacobians_1d), intent(inout) :: jac_1d +! +! + if (edge%nnod_4_edge .eq. num_linear_edge) then + call cal_jacobian_edge_linear & + & (node, edge, g_FEM, spf_1d, jac_1d) + else if (edge%nnod_4_edge .eq. num_quad_edge) then + call cal_jacobian_edge_quad & + & (node, edge, g_FEM, spf_1d, jac_1d) + end if +! + end subroutine sel_jacobian_edge +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_edge_linear & + & (node, edge, g_FEM, spf_1d_8, jac_1d) +! + use cal_1edge_jacobians + use cal_shape_function_1d +! + type(node_data), intent(in) :: node + type(edge_data), intent(in) :: edge + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(edge_shape_function), intent(inout) :: spf_1d_8 + type(jacobians_1d), intent(inout) :: jac_1d +! +! + call s_cal_shape_function_1d_linear & + & (jac_1d%ntot_int, jac_1d%an_edge, & + & spf_1d_8%dnxi_ed, spf_1d_8%xi) +! +! jacobian for tri-linear elaments + call cal_jacobian_1d_2 & + & (node%numnod, edge%numedge, edge%nnod_4_edge, edge%ie_edge, & + & node%xx, np_smp, edge%istack_edge_smp, & + & g_FEM%max_int_point, g_FEM%int_start1, & + & jac_1d%ntot_int, jac_1d%xj_edge, jac_1d%axj_edge, & + & jac_1d%xeg_edge, spf_1d_8%dnxi_ed) +! + end subroutine cal_jacobian_edge_linear +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_edge_quad & + & (node, edge, g_FEM, spf_1d_20, jac_1d) +! + use cal_1edge_jacobians + use cal_shape_function_1d +! + type(node_data), intent(in) :: node + type(edge_data), intent(in) :: edge + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(edge_shape_function), intent(inout) :: spf_1d_20 + type(jacobians_1d), intent(inout) :: jac_1d +! +! + call s_cal_shape_function_1d_quad & + & (jac_1d%ntot_int, jac_1d%an_edge, & + & spf_1d_20%dnxi_ed, spf_1d_20%xi) +! +! jacobian for quadrature elaments +! + call cal_jacobian_1d_3 & + & (node%numnod, edge%numedge, edge%nnod_4_edge, edge%ie_edge, & + & node%xx, np_smp, edge%istack_edge_smp, & + & g_FEM%max_int_point, g_FEM%int_start1, & + & jac_1d%ntot_int, jac_1d%xj_edge, jac_1d%axj_edge, & + & jac_1d%xeg_edge, spf_1d_20%dnxi_ed) +! + end subroutine cal_jacobian_edge_quad +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_edge_quad_on_l & + & (node, edge, g_FEM, spf_1d_20, jac_1d) +! + use cal_1edge_jacobians + use cal_shape_function_1d +! + type(node_data), intent(in) :: node + type(edge_data), intent(in) :: edge + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(edge_shape_function), intent(inout) :: spf_1d_20 + type(jacobians_1d), intent(inout) :: jac_1d +! +! + call s_cal_shape_function_1d_quad(jac_1d%ntot_int, & + & jac_1d%an_edge, spf_1d_20%dnxi_ed, spf_1d_20%xi) +! +! jacobian for quadrature elaments + call cal_jacobian_1d_2_3 & + & (node%numnod, edge%numedge, edge%nnod_4_edge, & + & edge%ie_edge, node%xx, np_smp, edge%istack_edge_smp, & + & g_FEM%max_int_point, g_FEM%int_start1, & + & jac_1d%ntot_int, jac_1d%xj_edge, jac_1d%axj_edge, & + & jac_1d%xeg_edge, spf_1d_20%dnxi_ed) +! + end subroutine cal_jacobian_edge_quad_on_l +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine copy_shape_func_from_array(ntot_int_1d, nnod_4_edge, & + & an_org, an_tgt) +! + integer(kind = kint), intent(in) :: ntot_int_1d, nnod_4_edge + real(kind=kreal), intent(in) :: an_org(nnod_4_edge,ntot_int_1d) + real(kind=kreal), intent(inout) & + & :: an_tgt(nnod_4_edge,ntot_int_1d) + integer(kind = kint) :: ix, k1 +! +! + do ix = 1, ntot_int_1d + do k1 = 1, nnod_4_edge + an_tgt(k1,ix) = an_org(k1,ix) + end do + end do +! + end subroutine copy_shape_func_from_array +! +!----------------------------------------------------------------------- +! + end module const_jacobians_1d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_2d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_2d.f90 new file mode 100644 index 00000000..3ddd5be0 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_2d.f90 @@ -0,0 +1,211 @@ +!>@file const_jacobians_2d.f90 +!! module const_jacobians_2d +!! +!!@author H. Matsui +!!@date Programmed on Nov., 2008 +!!@n Modified by H. Matsui on Feb., 2012 +! +!> @brief Construct Jacobians on surfaces +!! +!!@verbatim +!! subroutine sel_jacobian_surface & +!! & (node, surf, g_FEM, spf_2d, jac_2d) +!! subroutine cal_jacobian_surface_linear & +!! & (node, surf, g_FEM, spf_2d_8, jac_2d) +!! subroutine cal_jacobian_surface_quad_on_l & +!! & (node, surf, g_FEM, spf_2d_20, jac_2d) +!! type(node_data), intent(in) :: node +!! type(surface_data), intent(in) :: surf +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(surface_shape_function), intent(inout) :: spf_2d_20 +!! type(jacobians_2d), intent(inout) :: jac_2d +!!@endverbatim +! + module const_jacobians_2d +! + use m_precision + use m_machine_parameter + use m_geometry_constants +! + use t_geometry_data + use t_surface_data + use t_group_data + use t_fem_gauss_int_coefs + use t_shape_functions + use t_jacobian_2d +! + implicit none +! + private :: cal_jacobian_surface_quad, cal_jacobian_surface_lag +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine sel_jacobian_surface & + & (node, surf, g_FEM, spf_2d, jac_2d) +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d + type(jacobians_2d), intent(inout) :: jac_2d +! +! + if (surf%nnod_4_surf .eq. num_linear_sf) then + call cal_jacobian_surface_linear & + & (node, surf, g_FEM, spf_2d, jac_2d) + else if (surf%nnod_4_surf .eq. num_quad_sf) then + call cal_jacobian_surface_quad & + & (node, surf, g_FEM, spf_2d, jac_2d) + else if (surf%nnod_4_surf .eq. num_lag_sf) then + call cal_jacobian_surface_lag & + & (node, surf, g_FEM, spf_2d, jac_2d) + end if +! + end subroutine sel_jacobian_surface +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_surface_linear & + & (node, surf, g_FEM, spf_2d_8, jac_2d) +! + use cal_1surf_jacobians + use cal_shape_function_2d +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d_8 + type(jacobians_2d), intent(inout) :: jac_2d +! +! + call s_cal_shape_function_2d_linear(jac_2d%ntot_int, & + & jac_2d%an_sf, spf_2d_8%dnxi_sf, spf_2d_8%dnei_sf, & + & spf_2d_8%xi, spf_2d_8%ei) +! +! jacobian for tri-linear elaments + call cal_jacobian_2d_4 & + & (node%numnod, surf%numsurf, surf%nnod_4_surf, & + & surf%ie_surf, node%xx, np_smp, surf%istack_surf_smp, & + & g_FEM%max_int_point, g_FEM%int_start2, & + & jac_2d%ntot_int, jac_2d%xj_sf, jac_2d%axj_sf, jac_2d%xsf_sf, & + & spf_2d_8%dnxi_sf, spf_2d_8%dnei_sf) + + end subroutine cal_jacobian_surface_linear +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_surface_quad & + & (node, surf, g_FEM, spf_2d_20, jac_2d) +! + use cal_1surf_jacobians + use cal_shape_function_2d +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d_20 + type(jacobians_2d), intent(inout) :: jac_2d +! +! + call s_cal_shape_function_2d_quad(jac_2d%ntot_int, & + & jac_2d%an_sf, spf_2d_20%dnxi_sf, spf_2d_20%dnei_sf, & + & spf_2d_20%xi, spf_2d_20%ei) +! +! jacobian for quadrature elaments + call cal_jacobian_2d_8 & + & (node%numnod, surf%numsurf, surf%nnod_4_surf, & + & surf%ie_surf, node%xx, np_smp, surf%istack_surf_smp, & + & g_FEM%max_int_point, g_FEM%int_start2, & + & jac_2d%ntot_int, jac_2d%xj_sf, jac_2d%axj_sf, jac_2d%xsf_sf , & + & spf_2d_20%dnxi_sf, spf_2d_20%dnei_sf) +! + end subroutine cal_jacobian_surface_quad +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_surface_lag & + & (node, surf, g_FEM, spf_2d_27, jac_2d) +! + use cal_1surf_jacobians + use cal_shape_function_2d +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d_27 + type(jacobians_2d), intent(inout) :: jac_2d +! +! + call s_cal_shape_function_2d_lag(jac_2d%ntot_int, & + & jac_2d%an_sf, spf_2d_27%dnxi_sf, spf_2d_27%dnei_sf, & + & spf_2d_27%xi, spf_2d_27%ei) +! +! jacobian for quadrature elaments + call cal_jacobian_2d_9 & + & (node%numnod, surf%numsurf, surf%nnod_4_surf, & + & surf%ie_surf, node%xx, np_smp, surf%istack_surf_smp, & + & g_FEM%max_int_point, g_FEM%int_start2, & + & jac_2d%ntot_int, jac_2d%xj_sf, jac_2d%axj_sf, jac_2d%xsf_sf, & + & spf_2d_27%dnxi_sf, spf_2d_27%dnei_sf) +! + end subroutine cal_jacobian_surface_lag +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_surface_quad_on_l & + & (node, surf, g_FEM, spf_2d_20, jac_2d) +! + use cal_1surf_jacobians + use cal_shape_function_2d +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d_20 + type(jacobians_2d), intent(inout) :: jac_2d +! +! + call s_cal_shape_function_2d_quad(jac_2d%ntot_int, & + & jac_2d%an_sf, spf_2d_20%dnxi_sf, spf_2d_20%dnei_sf, & + & spf_2d_20%xi, spf_2d_20%ei) +! +! jacobian for quadrature elaments + call cal_jacobian_2d_4_8 & + & (node%numnod, surf%numsurf, surf%nnod_4_surf, & + & surf%ie_surf, node%xx, np_smp, surf%istack_surf_smp, & + & g_FEM%max_int_point, g_FEM%int_start2, & + & jac_2d%ntot_int, jac_2d%xj_sf, jac_2d%axj_sf, jac_2d%xsf_sf, & + & spf_2d_20%dnxi_sf, spf_2d_20%dnei_sf) +! + end subroutine cal_jacobian_surface_quad_on_l +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine copy_shape_func_from_array(ntot_int_2d, nnod_4_surf, & + & an_org, an_tgt) +! + integer(kind = kint), intent(in) :: ntot_int_2d, nnod_4_surf + real(kind=kreal), intent(in) :: an_org(nnod_4_surf,ntot_int_2d) + real(kind=kreal), intent(inout) & + & :: an_tgt(nnod_4_surf,ntot_int_2d) + integer(kind = kint) :: ix, k1 +! +! + do ix = 1, ntot_int_2d + do k1 = 1, nnod_4_surf + an_tgt(k1,ix) = an_org(k1,ix) + end do + end do +! + end subroutine copy_shape_func_from_array +! +!----------------------------------------------------------------------- +! + end module const_jacobians_2d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_3d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_3d.f90 new file mode 100644 index 00000000..3e6f8a29 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_3d.f90 @@ -0,0 +1,283 @@ +!>@file const_jacobians_3d.f90 +!!@brief module const_jacobians_3d +!! +!!@author H. Matsui and H. Okuda +!!@date programmed in July 2000 (ver 1.1) +!> Modified in June, 2006 (ver 1.2) +!! +!>@brief Initialize parameters for FEM integration +!! +!!@verbatim +!! subroutine initialize_FEM_integration & +!! & (g_FEM, spf_3d, spf_2d, spf_1d) +!! subroutine finalize_FEM_integration & +!! & (g_FEM, spf_3d, spf_2d, spf_1d) +!! +!! subroutine sel_jacobian_type(node, ele, g_FEM, spf_3d, jac_3d) +!! subroutine cal_jacobian_trilinear & +!! & (node, ele, g_FEM, spf_3d_8, jac_3d) +!! subroutine cal_jacobian_quad_on_linear & +!! & (node, ele, g_FEM, spf_3d_20, jac_3d) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(surface_group_data), intent(in) :: sf_grp +!! type(scalar_surf_BC_list), intent(in) :: infinity_list +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(jacobians_3d), intent(inout) :: jac_3d +!!@endverbatim +! + module const_jacobians_3d +! + use m_precision + use m_machine_parameter + use m_geometry_constants +! + use t_geometry_data + use t_shape_functions + use t_fem_gauss_int_coefs + use t_jacobian_3d + use t_group_data + use t_surface_boundary +! + use cal_1ele_jacobians + use cal_shape_function_3d +! + implicit none +! + private :: cal_jacobian_quad, cal_jacobian_lag +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +!> Construct shape function, difference of shape function, and Jacobian +!> for hexadedral element +! + subroutine initialize_FEM_integration & + & (g_FEM, spf_3d, spf_2d, spf_1d) +! + use set_gauss_int_parameters + use set_integration_indices +! + type(FEM_gauss_int_coefs), intent(inout) :: g_FEM + type(volume_shape_function), intent(inout) :: spf_3d + type(surface_shape_function), intent(inout) :: spf_2d + type(edge_shape_function), intent(inout) :: spf_1d +! +! set constant for gauss integration with roots +! + call init_gauss_int_parameters +! +! data allocation +! + call num_of_int_points(g_FEM) +! +! set indices for gauss integration +! + call alloc_1d_gauss_point_id(g_FEM, spf_1d) + call alloc_2d_gauss_point_id(g_FEM, spf_2d) + call alloc_3d_gauss_point_id(g_FEM, spf_3d) +! + call set_integrate_indices_1d & + & (g_FEM%maxtot_int_1d, g_FEM%max_int_point, spf_1d%l_int) + call set_integrate_indices_2d & + & (g_FEM%maxtot_int_2d, g_FEM%max_int_point, spf_2d%l_int) + call set_integrate_indices_3d & + & (g_FEM%maxtot_int_3d, g_FEM%max_int_point, spf_3d%l_int) +! +! set weighting for integration +! + call alloc_gauss_coef_4_fem(g_FEM) + call set_start_addres_4_FEM_int(g_FEM) +! + call set_gauss_coefs_4_1d & + & (g_FEM%max_int_point, g_FEM%maxtot_int_1d, g_FEM%int_start1, & + & spf_1d%xi, g_FEM%owe) + call set_gauss_coefs_4_2d & + & (g_FEM%max_int_point, g_FEM%maxtot_int_1d, g_FEM%int_start1, & + & spf_1d%xi, g_FEM%owe, g_FEM%maxtot_int_2d, g_FEM%int_start2, & + & spf_2d%l_int, spf_2d%xi, spf_2d%ei, g_FEM%owe2d) + call set_gauss_coefs_4_3d & + & (g_FEM%max_int_point, g_FEM%maxtot_int_1d, g_FEM%int_start1, & + & spf_1d%xi, g_FEM%owe, g_FEM%maxtot_int_3d, g_FEM%int_start3, & + & spf_3d%l_int, spf_3d%xi, spf_3d%ei, spf_3d%zi, g_FEM%owe3d) +! + end subroutine initialize_FEM_integration +! +!----------------------------------------------------------------------- +! + subroutine finalize_FEM_integration & + & (g_FEM, spf_3d, spf_2d, spf_1d) +! + type(FEM_gauss_int_coefs), intent(inout) :: g_FEM + type(volume_shape_function), intent(inout) :: spf_3d + type(surface_shape_function), intent(inout) :: spf_2d + type(edge_shape_function), intent(inout) :: spf_1d +! +! + call dealloc_gauss_coef_4_fem(g_FEM) + call dealloc_gauss_point_id(spf_3d, spf_2d, spf_1d) +! + end subroutine finalize_FEM_integration +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine sel_jacobian_type(node, ele, g_FEM, spf_3d, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(inout) :: spf_3d + type(jacobians_3d), intent(inout) :: jac_3d +! +! set jacobians +! + if (ele%nnod_4_ele .eq. num_t_linear) then + call cal_jacobian_trilinear(node, ele, g_FEM, spf_3d, jac_3d) + else if (ele%nnod_4_ele .eq. num_t_quad) then + call cal_jacobian_quad(node, ele, g_FEM, spf_3d, jac_3d) + else if (ele%nnod_4_ele .eq. num_t_lag) then + call cal_jacobian_lag(node, ele, g_FEM, spf_3d, jac_3d) + end if +! + end subroutine sel_jacobian_type +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_trilinear & + & (node, ele, g_FEM, spf_3d_8, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(inout) :: spf_3d_8 + type(jacobians_3d), intent(inout) :: jac_3d +! +! + call s_cal_shape_function_linear(jac_3d%ntot_int, jac_3d%an, & + & spf_3d_8%dnxi, spf_3d_8%dnei, spf_3d_8%dnzi, & + & spf_3d_8%xi, spf_3d_8%ei, spf_3d_8%zi) +! +! jacobian for tri-linear elaments +! + call cal_jacobian_3d_8 & + & (node%numnod, ele%numele, ele%nnod_4_ele, & + & np_smp, ele%istack_ele_smp, ele%ie, node%xx, & + & g_FEM%max_int_point, g_FEM%int_start3, & + & jac_3d%ntot_int, jac_3d%xjac, jac_3d%axjac, & + & jac_3d%dnx, jac_3d%dxidx_3d, & + & spf_3d_8%dnxi, spf_3d_8%dnei, spf_3d_8%dnzi) +! + end subroutine cal_jacobian_trilinear +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_quad & + & (node, ele, g_FEM, spf_3d_20, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(inout) :: spf_3d_20 + type(jacobians_3d), intent(inout) :: jac_3d +! +! + call s_cal_shape_function_quad(jac_3d%ntot_int, jac_3d%an, & + & spf_3d_20%dnxi, spf_3d_20%dnei, spf_3d_20%dnzi, & + & spf_3d_20%xi, spf_3d_20%ei, spf_3d_20%zi) +! +! jacobian for tri-linear elaments +! + call cal_jacobian_3d_20 & + & (node%numnod, ele%numele, ele%nnod_4_ele, & + & np_smp, ele%istack_ele_smp, ele%ie, node%xx, & + & g_FEM%max_int_point, g_FEM%int_start3, & + & jac_3d%ntot_int, jac_3d%xjac, jac_3d%axjac, & + & jac_3d%dnx, jac_3d%dxidx_3d, & + & spf_3d_20%dnxi, spf_3d_20%dnei, spf_3d_20%dnzi) +! + end subroutine cal_jacobian_quad +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_lag & + & (node, ele, g_FEM, spf_3d_27, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(inout) :: spf_3d_27 + type(jacobians_3d), intent(inout) :: jac_3d +! +! + call s_cal_shape_function_lag(jac_3d%ntot_int, jac_3d%an, & + & spf_3d_27%dnxi, spf_3d_27%dnei, spf_3d_27%dnzi, & + & spf_3d_27%xi, spf_3d_27%ei, spf_3d_27%zi) +! +! jacobian for tri-linear elaments +! + call cal_jacobian_3d_27 & + & (node%numnod, ele%numele, ele%nnod_4_ele, & + & np_smp, ele%istack_ele_smp, ele%ie, node%xx, & + & g_FEM%max_int_point, g_FEM%int_start3, & + & jac_3d%ntot_int, jac_3d%xjac, jac_3d%axjac, & + & jac_3d%dnx, jac_3d%dxidx_3d, & + & spf_3d_27%dnxi, spf_3d_27%dnei, spf_3d_27%dnzi) +! + end subroutine cal_jacobian_lag +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_quad_on_linear & + & (node, ele, g_FEM, spf_3d_20, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(inout) :: spf_3d_20 + type(jacobians_3d), intent(inout) :: jac_3d +! +! + call s_cal_shape_function_quad(jac_3d%ntot_int, jac_3d%an, & + & spf_3d_20%dnxi, spf_3d_20%dnei, spf_3d_20%dnzi, & + & spf_3d_20%xi, spf_3d_20%ei, spf_3d_20%zi) +! +! jacobian for quadrature elaments +! + call cal_jacobian_3d_8_20 & + & (node%numnod, ele%numele, ele%nnod_4_ele, & + & np_smp, ele%istack_ele_smp, ele%ie, node%xx, & + & g_FEM%max_int_point, g_FEM%int_start3, & + & jac_3d%ntot_int, jac_3d%xjac, jac_3d%axjac, & + & jac_3d%dnx, jac_3d%dxidx_3d, & + & spf_3d_20%dnxi, spf_3d_20%dnei, spf_3d_20%dnzi) +! + end subroutine cal_jacobian_quad_on_linear +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine copy_shape_func_from_array(ntot_int_3d, nnod_4_ele, & + & an_org, an_tgt) +! + integer(kind = kint), intent(in) :: ntot_int_3d, nnod_4_ele + real(kind=kreal), intent(in) :: an_org(nnod_4_ele,ntot_int_3d) + real(kind=kreal), intent(inout) :: an_tgt(nnod_4_ele,ntot_int_3d) + integer(kind = kint) :: ix, k1 +! +! + do ix = 1, ntot_int_3d + do k1 = 1, nnod_4_ele + an_tgt(k1,ix) = an_org(k1,ix) + end do + end do +! + end subroutine copy_shape_func_from_array +! +!----------------------------------------------------------------------- +! + end module const_jacobians_3d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_infinity.f90 b/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_infinity.f90 new file mode 100644 index 00000000..b6455460 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_infinity.f90 @@ -0,0 +1,278 @@ +!const_jacobians_infinity.f90 +! module const_jacobians_infinity +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! modified by H. Matsui on June. 2006 +! +!! subroutine sel_jacobian_infinity(node, ele, & +!! & surf_grp, infty_grp, g_FEM, spf_3d, jac_3d) +!! subroutine const_linear_jacobian_infinity(node, ele, & +!! & surf_grp, infty_grp, g_FEM, spf_3d_8, jac_3d) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(surface_group_data), intent(in) :: surf_grp +!! type(scalar_surf_BC_list), intent(in) :: infty_grp +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(volume_shape_function), intent(in) :: spf_3d +!! type(jacobians_3d), intent(inout) :: jac_3d +!! +!! subroutine cal_jacobian_infty_l_quad(node, ele, sf_grp, & +!! & infty_grp, g_FEM, spf_3d_20, jac_3d) +!! type(mesh_geometry), intent(in) :: mesh +!! type(volume_shape_function), intent(in) :: spf_3d_20 +!! type(jacobians_3d), intent(inout) :: jac_3d +!! +!! subroutine copy_shape_func_inf_from_array(ntot_int_3d, & +!! & nnod_4_ele, an_infty_org, an_infty_dest) +! + module const_jacobians_infinity +! + use m_precision + use m_machine_parameter + use m_geometry_constants +! + use t_mesh_data + use t_geometry_data + use t_group_data + use t_fem_gauss_int_coefs + use t_shape_functions + use t_jacobian_3d + use cal_1ele_jacobians_infinte +! + implicit none +! + type(infty_shape_function), save, private :: spf_infty +! + private :: cal_jacobian_infty_linear, cal_jacobian_infty_quad + private :: cal_jacobian_infty_lag +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine sel_jacobian_infinity(node, ele, & + & surf_grp, infty_grp, g_FEM, spf_3d, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: surf_grp + type(scalar_surf_BC_list), intent(in) :: infty_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(in) :: spf_3d + type(jacobians_3d), intent(inout) :: jac_3d +! +! + if(infty_grp%ngrp_sf .le. 0) return +! + call alloc_shape_func_infty & + & (ele%nnod_4_ele, nsurf_4_ele, g_FEM, spf_infty) +! + if (ele%nnod_4_ele .eq. num_t_linear) then + call cal_jacobian_infty_linear(node, ele, surf_grp, infty_grp, & + & g_FEM, spf_3d, spf_infty, jac_3d) + else if (ele%nnod_4_ele .eq. num_t_quad) then + call cal_jacobian_infty_quad(node, ele, surf_grp, infty_grp, & + & g_FEM, spf_3d, spf_infty, jac_3d) + else if (ele%nnod_4_ele .eq. num_t_lag) then + call cal_jacobian_infty_lag(node, ele, surf_grp, infty_grp, & + & g_FEM, spf_3d, spf_infty, jac_3d) + end if +! + call dealloc_shape_func_infty(spf_infty) +! + end subroutine sel_jacobian_infinity +! +!----------------------------------------------------------------------- +! + subroutine const_linear_jacobian_infinity(node, ele, & + & surf_grp, infty_grp, g_FEM, spf_3d_8, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: surf_grp + type(scalar_surf_BC_list), intent(in) :: infty_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(in) :: spf_3d_8 + type(jacobians_3d), intent(inout) :: jac_3d +! +! + if(infty_grp%ngrp_sf .le. 0) return +! + call alloc_shape_func_infty & + & (num_t_linear, nsurf_4_ele, g_FEM, spf_infty) + call cal_jacobian_infty_linear(node, ele, surf_grp, infty_grp, & + & g_FEM, spf_3d_8, spf_infty, jac_3d) + call dealloc_shape_func_infty(spf_infty) +! + end subroutine const_linear_jacobian_infinity +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_infty_linear(node, ele, sf_grp, & + & infty_grp, g_FEM, spf_3d_8, spf_inf8, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: sf_grp + type(scalar_surf_BC_list), intent(in) :: infty_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(in) :: spf_3d_8 + type(infty_shape_function), intent(inout) :: spf_inf8 + type(jacobians_3d), intent(inout) :: jac_3d +! +! + if(infty_grp%ngrp_sf .le. 0) return +! + call s_cal_shape_func_infty_linear & + & (jac_3d%ntot_int, infty_grp%sf_apt(1), jac_3d%an_infty, & + & spf_inf8%dnxi_inf, spf_inf8%dnei_inf, spf_inf8%dnzi_inf, & + & spf_3d_8%xi, spf_3d_8%ei, spf_3d_8%zi) +! + call cal_jacobian_3d_inf_8(node%numnod, ele%numele, & + & ele%nnod_4_ele, np_smp, ele%ie, node%xx, & + & sf_grp%num_item, sf_grp%item_sf_grp, & + & infty_grp%ngrp_sf, infty_grp%igrp_sf, & + & sf_grp%num_grp_smp, sf_grp%istack_grp_smp, & + & g_FEM%max_int_point, g_FEM%int_start3, & + & jac_3d%ntot_int, jac_3d%xjac, jac_3d%axjac, & + & jac_3d%dnx, jac_3d%dxidx_3d, & + & spf_3d_8%dnxi, spf_3d_8%dnei, spf_3d_8%dnzi, & + & spf_inf8%dnxi_inf, spf_inf8%dnei_inf, spf_inf8%dnzi_inf) +! + end subroutine cal_jacobian_infty_linear +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_infty_quad(node, ele, sf_grp, infty_grp, & + & g_FEM, spf_3d_20, spf_inf20, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: sf_grp + type(scalar_surf_BC_list), intent(in) :: infty_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(in) :: spf_3d_20 + type(infty_shape_function), intent(inout) :: spf_inf20 + type(jacobians_3d), intent(inout) :: jac_3d +! +! + call s_cal_shape_func_infty_quad(jac_3d%ntot_int, & + & infty_grp%sf_apt(1), jac_3d%an_infty, & + & spf_inf20%dnxi_inf, spf_inf20%dnei_inf, spf_inf20%dnzi_inf, & + & spf_3d_20%xi, spf_3d_20%ei, spf_3d_20%zi) +! + call cal_jacobian_3d_inf_20(node%numnod, ele%numele, & + & ele%nnod_4_ele, np_smp, ele%ie, node%xx, & + & sf_grp%num_item, sf_grp%item_sf_grp, & + & infty_grp%ngrp_sf, infty_grp%igrp_sf, & + & sf_grp%num_grp_smp, sf_grp%istack_grp_smp, & + & g_FEM%max_int_point, g_FEM%int_start3, & + & jac_3d%ntot_int, jac_3d%xjac, jac_3d%axjac, & + & jac_3d%dnx, jac_3d%dxidx_3d, & + & spf_3d_20%dnxi, spf_3d_20%dnei, spf_3d_20%dnzi, & + & spf_inf20%dnxi_inf, spf_inf20%dnei_inf, spf_inf20%dnzi_inf) +! + end subroutine cal_jacobian_infty_quad +! +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_infty_lag(node, ele, sf_grp, infty_grp, & + & g_FEM, spf_3d_27, spf_inf27, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: sf_grp + type(scalar_surf_BC_list), intent(in) :: infty_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(in) :: spf_3d_27 + type(infty_shape_function), intent(inout) :: spf_inf27 + type(jacobians_3d), intent(inout) :: jac_3d +! +! + call s_cal_shape_func_infty_lag & + & (jac_3d%ntot_int, infty_grp%sf_apt(1), jac_3d%an_infty, & + & spf_inf27%dnxi_inf, spf_inf27%dnei_inf, spf_inf27%dnzi_inf, & + & spf_3d_27%xi, spf_3d_27%ei, spf_3d_27%zi) +! + call cal_jacobian_3d_inf_27(node%numnod, ele%numele, & + & ele%nnod_4_ele, np_smp, ele%ie, node%xx, & + & sf_grp%num_item, sf_grp%item_sf_grp, & + & infty_grp%ngrp_sf, infty_grp%igrp_sf, & + & sf_grp%num_grp_smp, sf_grp%istack_grp_smp, & + & g_FEM%max_int_point, g_FEM%int_start3, & + & jac_3d%ntot_int, jac_3d%xjac, jac_3d%axjac, & + & jac_3d%dnx, jac_3d%dxidx_3d, & + & spf_3d_27%dnxi, spf_3d_27%dnei, spf_3d_27%dnzi, & + & spf_inf27%dnxi_inf, spf_inf27%dnei_inf, spf_inf27%dnzi_inf) +! + end subroutine cal_jacobian_infty_lag +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine cal_jacobian_infty_l_quad(node, ele, sf_grp, & + & infty_grp, g_FEM, spf_3d_20, jac_3d) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: sf_grp + type(scalar_surf_BC_list), intent(in) :: infty_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(in) :: spf_3d_20 + type(jacobians_3d), intent(inout) :: jac_3d +! +! + call alloc_shape_func_infty & + & (ele%nnod_4_ele, nsurf_4_ele, g_FEM, spf_infty) +! + call s_cal_shape_func_infty_quad(jac_3d%ntot_int, & + & infty_grp%sf_apt(1), jac_3d%an_infty, & + & spf_infty%dnxi_inf, spf_infty%dnei_inf, spf_infty%dnzi_inf, & + & spf_3d_20%xi, spf_3d_20%ei, spf_3d_20%zi) +! + call cal_jacobian_3d_inf_8_20(node%numnod, ele%numele, & + & ele%nnod_4_ele, np_smp, ele%ie, node%xx, & + & sf_grp%num_item, sf_grp%item_sf_grp, & + & infty_grp%ngrp_sf, infty_grp%igrp_sf, & + & sf_grp%num_grp_smp, sf_grp%istack_grp_smp, & + & g_FEM%max_int_point, g_FEM%int_start3, & + & jac_3d%ntot_int, jac_3d%xjac, jac_3d%axjac, & + & jac_3d%dnx, jac_3d%dxidx_3d, & + & spf_3d_20%dnxi, spf_3d_20%dnei, spf_3d_20%dnzi, & + & spf_infty%dnxi_inf, spf_infty%dnei_inf, spf_infty%dnzi_inf) +! + call dealloc_shape_func_infty(spf_infty) +! + end subroutine cal_jacobian_infty_l_quad +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine copy_shape_func_inf_from_array(ntot_int_3d, & + & nnod_4_ele, an_infty_org, an_infty_dest) +! + integer (kind=kint), intent(in) :: ntot_int_3d, nnod_4_ele + real(kind=kreal), intent(in) & + & :: an_infty_org(nnod_4_ele,nsurf_4_ele,ntot_int_3d) + real(kind=kreal), intent(inout) & + & :: an_infty_dest(nnod_4_ele,nsurf_4_ele,ntot_int_3d) +! + integer (kind=kint) :: ix, isf, k1 +! + do ix = 1, ntot_int_3d + do isf = 1, nsurf_4_ele + do k1 = 1, nnod_4_ele + an_infty_dest(k1,isf,ix) = an_infty_org(k1,isf,ix) + end do + end do + end do +! + end subroutine copy_shape_func_inf_from_array +! +!----------------------------------------------------------------------- +! + end module const_jacobians_infinity diff --git a/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_sf_grp.f90 b/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_sf_grp.f90 new file mode 100644 index 00000000..885a68bd --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/const_jacobians_sf_grp.f90 @@ -0,0 +1,207 @@ +!>@file const_jacobians_sf_grp.f90 +!! module const_jacobians_sf_grp +!! +!!@author H. Matsui +!!@date Programmed on Nov., 2008 +!!@n Modified by H. Matsui on Feb., 2012 +! +!> @brief Construct Jacobians on surfaces +!! +!!@verbatim +!! subroutine sel_jacobian_surface_grp(node, ele, surf, & +!! & surf_grp, g_FEM, spf_2d, jac_sf_grp) +!! subroutine const_jacobian_sf_grp_linear(node, ele, surf_grp, & +!! & g_FEM, spf_2d_8, jac_sf_grp) +!! subroutine const_jacobian_sf_grp_l_quad(node, ele, surf_grp, & +!! & g_FEM, spf_2d_20, jac_sf_grp) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(surface_group_data), intent(in) :: surf_grp +!! type(jacobians_2d), intent(inout) :: jac_sf_grp +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(surface_shape_function), intent(inout) :: spf_2d +!! type(jacobians_2d), intent(inout) :: jac_sf_grp +!!@endverbatim +! + module const_jacobians_sf_grp +! + use m_precision + use m_machine_parameter + use m_geometry_constants +! + use t_geometry_data + use t_surface_data + use t_group_data + use t_fem_gauss_int_coefs + use t_shape_functions + use t_jacobian_2d +! + implicit none +! + private :: const_jacobian_sf_grp_quad, const_jacobian_sf_grp_lag +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine sel_jacobian_surface_grp(node, ele, surf, & + & surf_grp, g_FEM, spf_2d, jac_sf_grp) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: surf_grp + type(surface_data), intent(in) :: surf + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d + type(jacobians_2d), intent(inout) :: jac_sf_grp +! +! + if (surf_grp%num_grp .gt. 0) then + if (surf%nnod_4_surf .eq. num_linear_sf) then + call const_jacobian_sf_grp_linear(node, ele, & + & surf_grp, g_FEM, spf_2d, jac_sf_grp) + else if (surf%nnod_4_surf .eq. num_quad_sf) then + call const_jacobian_sf_grp_quad(node, ele, & + & surf_grp, g_FEM, spf_2d, jac_sf_grp) + else if (surf%nnod_4_surf .eq. num_lag_sf) then + call const_jacobian_sf_grp_lag(node, ele, & + & surf_grp, g_FEM, spf_2d, jac_sf_grp) + end if + end if +! + end subroutine sel_jacobian_surface_grp +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine const_jacobian_sf_grp_linear(node, ele, surf_grp, & + & g_FEM, spf_2d_8, jac_sf_grp) +! + use cal_1surf_grp_jacobians + use cal_shape_function_2d +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: surf_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d_8 + type(jacobians_2d), intent(inout) :: jac_sf_grp +! +! + call s_cal_shape_function_2d_linear(jac_sf_grp%ntot_int, & + & jac_sf_grp%an_sf, spf_2d_8%dnxi_sf, spf_2d_8%dnei_sf, & + & spf_2d_8%xi, spf_2d_8%ei) +! +! jacobian for tri-linear elaments + call cal_jacobian_sf_grp_4 & + & (node%numnod, ele%numele, ele%nnod_4_ele, ele%ie, node%xx, & + & surf_grp%num_grp, surf_grp%num_item, surf_grp%item_sf_grp, & + & np_smp, surf_grp%num_grp_smp, surf_grp%istack_grp_smp, & + & g_FEM%max_int_point, g_FEM%int_start2, & + & jac_sf_grp%ntot_int, jac_sf_grp%xj_sf, jac_sf_grp%axj_sf, & + & jac_sf_grp%xsf_sf, spf_2d_8%dnxi_sf, spf_2d_8%dnei_sf) +! + end subroutine const_jacobian_sf_grp_linear +! +!----------------------------------------------------------------------- +! + subroutine const_jacobian_sf_grp_quad(node, ele, surf_grp, & + & g_FEM, spf_2d_20, jac_sf_grp) +! + use cal_1surf_grp_jacobians + use cal_shape_function_2d +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: surf_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d_20 + type(jacobians_2d), intent(inout) :: jac_sf_grp +! +! + call s_cal_shape_function_2d_quad(jac_sf_grp%ntot_int, & + & jac_sf_grp%an_sf, spf_2d_20%dnxi_sf, spf_2d_20%dnei_sf, & + & spf_2d_20%xi, spf_2d_20%ei) +! +! jacobian for quadrature elaments + call cal_jacobian_sf_grp_8 & + & (node%numnod, ele%numele, ele%nnod_4_ele, ele%ie, node%xx, & + & surf_grp%num_grp, surf_grp%num_item, surf_grp%item_sf_grp, & + & np_smp, surf_grp%num_grp_smp, surf_grp%istack_grp_smp, & + & g_FEM%max_int_point, g_FEM%int_start2, & + & jac_sf_grp%ntot_int, jac_sf_grp%xj_sf, jac_sf_grp%axj_sf, & + & jac_sf_grp%xsf_sf, spf_2d_20%dnxi_sf, spf_2d_20%dnei_sf) +! + end subroutine const_jacobian_sf_grp_quad +! +!----------------------------------------------------------------------- +! + subroutine const_jacobian_sf_grp_lag(node, ele, surf_grp, & + & g_FEM, spf_2d_27, jac_sf_grp) +! + use m_geometry_constants + use cal_1surf_grp_jacobians + use cal_shape_function_2d +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: surf_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d_27 + type(jacobians_2d), intent(inout) :: jac_sf_grp +! +! + call s_cal_shape_function_2d_lag(jac_sf_grp%ntot_int, & + & jac_sf_grp%an_sf, spf_2d_27%dnxi_sf, spf_2d_27%dnei_sf, & + & spf_2d_27%xi, spf_2d_27%ei) +! +! jacobian for quadrature elaments + call cal_jacobian_sf_grp_9 & + & (node%numnod, ele%numele, ele%nnod_4_ele, ele%ie, node%xx, & + & surf_grp%num_grp, surf_grp%num_item, surf_grp%item_sf_grp, & + & np_smp, surf_grp%num_grp_smp, surf_grp%istack_grp_smp, & + & g_FEM%max_int_point, g_FEM%int_start2, & + & jac_sf_grp%ntot_int, jac_sf_grp%xj_sf, jac_sf_grp%axj_sf, & + & jac_sf_grp%xsf_sf, spf_2d_27%dnxi_sf, spf_2d_27%dnei_sf) +! +! + end subroutine const_jacobian_sf_grp_lag +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine const_jacobian_sf_grp_l_quad(node, ele, surf_grp, & + & g_FEM, spf_2d_20, jac_sf_grp) +! + use cal_1surf_grp_jacobians + use cal_shape_function_2d +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: surf_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d_20 + type(jacobians_2d), intent(inout) :: jac_sf_grp +! +! + call s_cal_shape_function_2d_quad(jac_sf_grp%ntot_int, & + & jac_sf_grp%an_sf, spf_2d_20%dnxi_sf, spf_2d_20%dnei_sf, & + & spf_2d_20%xi, spf_2d_20%ei) +! +! +! jacobian for quadrature elaments + call cal_jacobian_sf_grp_4_8 & + & (node%numnod, ele%numele, ele%nnod_4_ele, ele%ie, node%xx, & + & surf_grp%num_grp, surf_grp%num_item, surf_grp%item_sf_grp, & + & np_smp, surf_grp%num_grp_smp, surf_grp%istack_grp_smp, & + & g_FEM%max_int_point, g_FEM%int_start2, & + & jac_sf_grp%ntot_int, jac_sf_grp%xj_sf, jac_sf_grp%axj_sf, & + & jac_sf_grp%xsf_sf, spf_2d_20%dnxi_sf, spf_2d_20%dnei_sf) +! + end subroutine const_jacobian_sf_grp_l_quad +! +!----------------------------------------------------------------------- +! + end module const_jacobians_sf_grp diff --git a/src/Fortran_libraries/UTILS_src/jacobian/fem_element_volume.f90 b/src/Fortran_libraries/UTILS_src/jacobian/fem_element_volume.f90 new file mode 100644 index 00000000..adba2eee --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/fem_element_volume.f90 @@ -0,0 +1,104 @@ +! +! module fem_element_volume +! +! programmed by H.Matsui and H.Okuda +! on July 2000 (ver 1.1) +! Modified by H. Matsui on Aug., 2006 +! Modified by H. Matsui on June, 2007 +! +!! subroutine fem_element_volume_pg(ele, g_FEM, jac_3d, n_int) +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(jacobians_3d), intent(in) :: jac_3d +!! type(element_data), intent(inout) :: ele +! + module fem_element_volume +! + use m_precision + use m_machine_parameter +! + implicit none +! + private :: s_fem_element_volume +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine fem_element_volume_pg(ele, g_FEM, jac_3d, n_int) +! + use t_fem_gauss_int_coefs + use t_geometry_data + use t_jacobians +! + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(jacobians_3d), intent(in) :: jac_3d + integer (kind=kint), intent(in) :: n_int + type(element_data), intent(inout) :: ele +! +! + call s_fem_element_volume(ele%numele, ele%istack_ele_smp, & + & g_FEM%max_int_point, g_FEM%maxtot_int_3d, g_FEM%int_start3, & + & g_FEM%owe3d, n_int, jac_3d%ntot_int, jac_3d%xjac, & + & ele%volume_ele, ele%a_vol_ele) +! + end subroutine fem_element_volume_pg +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine s_fem_element_volume(numele, iele_smp_stack, & + & max_int_point, maxtot_int_3d, int_start3, owe3d, & + & n_int, ntot_int_3d, xjac, volume_ele, a_vol_ele) +! + integer(kind=kint), intent(in) :: numele + integer(kind=kint), intent(in) :: iele_smp_stack(0:np_smp) +! + integer(kind = kint), intent(in) :: max_int_point, maxtot_int_3d + integer(kind = kint), intent(in) :: int_start3(max_int_point) + real(kind = kreal), intent(in) :: owe3d(maxtot_int_3d) +! + integer(kind=kint), intent(in) :: ntot_int_3d, n_int + real(kind=kreal), intent(in) :: xjac(numele, ntot_int_3d) +! + real (kind=kreal), intent(inout) :: volume_ele(numele) + real (kind=kreal), intent(inout) :: a_vol_ele(numele) +! + integer (kind=kint) :: ip, iele, ii, ix + integer (kind=kint) :: istart, iend +! +! +!$omp workshare + volume_ele(1:numele) = 0.0d0 +!$omp end workshare +! +!$omp parallel do private(iele,ii,ix,istart,iend) + do ip = 1, np_smp + istart = iele_smp_stack(ip-1)+1 + iend = iele_smp_stack(ip) +! + do ii=1, n_int * n_int * n_int + ix = int_start3(n_int) + ii + do iele = istart, iend + volume_ele(iele) = volume_ele(iele) & + & + xjac(iele,ix)*owe3d(ix) + end do + end do +! +! + do iele = istart, iend + if (volume_ele(iele).eq.0.0d0) then + a_vol_ele(iele) = 1.0d60 + else + a_vol_ele(iele) = 1.0d0 / volume_ele(iele) + end if + end do + end do +!$omp end parallel do +! + end subroutine s_fem_element_volume +! +!----------------------------------------------------------------------- +! + end module fem_element_volume diff --git a/src/Fortran_libraries/UTILS_src/jacobian/int_area_normal_4_surface.f90 b/src/Fortran_libraries/UTILS_src/jacobian/int_area_normal_4_surface.f90 new file mode 100644 index 00000000..edeb4081 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/int_area_normal_4_surface.f90 @@ -0,0 +1,219 @@ +!>@file int_area_normal_4_surface.f90 +!!@brief module int_area_normal_4_surface +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2006 +!! +!>@brief Integration on surfaces +!! +!!@verbatim +!! subroutine int_normal_all_surf(surf, g_FEM, jac_2d, n_int, & +!! & area_surf, a_area_surf, vnorm_surf) +!! type(surface_data), intent(inout) :: surf +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(jacobians_2d), intent(in) :: jac_2d +!! subroutine int_normal_surf_groups(sf_grp, g_FEM, jac_sf_grp, & +!! & n_int, area_surf, a_area_surf, vnorm_surf) +!! type(surface_group_data), intent(in) :: sf_grp +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(jacobians_2d), intent(in) :: jac_sf_grp +!! subroutine int_surf_area_1_surf_grp(ele, surf, g_FEM, jac_2d, & +!! & num_int, num_sgrp, isurf_grp, area) +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(jacobians_2d), intent(in) :: jac_2d +!!@endverbatim +! + module int_area_normal_4_surface +! + use m_precision + use m_machine_parameter + use m_geometry_constants +! + use t_geometry_data + use t_surface_data + use t_group_data + use t_fem_gauss_int_coefs + use t_jacobian_2d +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine int_normal_all_surf(surf, g_FEM, jac_2d, n_int, & + & area_surf, a_area_surf, vnorm_surf) +! + type(surface_data), intent(inout) :: surf + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(jacobians_2d), intent(in) :: jac_2d + integer (kind = kint), intent(in) :: n_int +! + real(kind = kreal), intent(inout) :: area_surf(surf%numsurf) + real(kind = kreal), intent(inout) :: a_area_surf(surf%numsurf) + real(kind = kreal), intent(inout) :: vnorm_surf(surf%numsurf,3) +! + integer (kind = kint) :: ip, ist, ied + integer (kind = kint) :: isurf, ix, ii +! +! +!$omp parallel workshare + vnorm_surf(1:surf%numsurf,1) = 0.0d0 + vnorm_surf(1:surf%numsurf,2) = 0.0d0 + vnorm_surf(1:surf%numsurf,3) = 0.0d0 + area_surf(1:surf%numsurf) = 0.0d0 + a_area_surf(1:surf%numsurf) = 0.0d0 +!$omp end parallel workshare +! +!$omp parallel do private(ist,ied,ii,ix,isurf) + do ip = 1, np_smp + ist = surf%istack_surf_smp(ip-1) + 1 + ied = surf%istack_surf_smp(ip) +! + do ii = 1, n_int * n_int + ix = g_FEM%int_start2(n_int) + ii +! +!cdir noloopchg + do isurf = ist, ied + area_surf(isurf) = area_surf(isurf) & + & + jac_2d%xj_sf(isurf,ix) * g_FEM%owe2d(ix) +! + vnorm_surf(isurf,1) = vnorm_surf(isurf,1) & + & + jac_2d%xsf_sf(isurf,ix,1) * g_FEM%owe2d(ix) + vnorm_surf(isurf,2) = vnorm_surf(isurf,2) & + & + jac_2d%xsf_sf(isurf,ix,2) * g_FEM%owe2d(ix) + vnorm_surf(isurf,3) = vnorm_surf(isurf,3) & + & + jac_2d%xsf_sf(isurf,ix,3) * g_FEM%owe2d(ix) + end do + end do +! +!cdir noloopchg + do isurf = ist, ied + if (area_surf(isurf) .eq. 0.0d0) then + a_area_surf(isurf) = 1.0d60 + else + a_area_surf(isurf) = 1.0d0 / area_surf(isurf) + end if + end do +! +!cdir noloopchg + do isurf = ist, ied + vnorm_surf(isurf,1) = vnorm_surf(isurf,1)*a_area_surf(isurf) + vnorm_surf(isurf,2) = vnorm_surf(isurf,2)*a_area_surf(isurf) + vnorm_surf(isurf,3) = vnorm_surf(isurf,3)*a_area_surf(isurf) + end do +! + end do +!$omp end parallel do +! + end subroutine int_normal_all_surf +! +! ---------------------------------------------------------------------- +! + subroutine int_normal_surf_groups(sf_grp, g_FEM, jac_sf_grp, & + & n_int, area_surf, a_area_surf, vnorm_surf) +! + type(surface_group_data), intent(in) :: sf_grp + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(jacobians_2d), intent(in) :: jac_sf_grp + integer (kind = kint), intent(in) :: n_int +! + real(kind = kreal), intent(inout) :: area_surf(sf_grp%num_item) + real(kind = kreal), intent(inout) :: a_area_surf(sf_grp%num_item) + real(kind = kreal), intent(inout) :: vnorm_surf(sf_grp%num_item,3) +! + integer (kind = kint) :: ip, ist, ied + integer (kind = kint) :: i_grp, inum, ix, ii, i +! +! +!$omp parallel workshare + vnorm_surf(1:sf_grp%num_item,1) = 0.0d0 + vnorm_surf(1:sf_grp%num_item,2) = 0.0d0 + vnorm_surf(1:sf_grp%num_item,3) = 0.0d0 + area_surf(1:sf_grp%num_item) = 0.0d0 + a_area_surf(1:sf_grp%num_item) = 0.0d0 +!$omp end parallel workshare +! + do i_grp = 1, sf_grp%num_grp +!$omp parallel do private(i,ist,ied,inum) + do ip = 1, np_smp + i = (i_grp-1)*np_smp + ip + ist = sf_grp%istack_grp_smp(i-1) + 1 + ied = sf_grp%istack_grp_smp(i) +! + do ii = 1, n_int * n_int + ix = g_FEM%int_start2(n_int) + ii +! + do inum = ist, ied + area_surf(inum) = area_surf(inum) & + & + jac_sf_grp%xj_sf(inum,ix) * g_FEM%owe2d(ix) +! + vnorm_surf(inum,1) = vnorm_surf(inum,1) & + & + jac_sf_grp%xsf_sf(inum,ix,1) * g_FEM%owe2d(ix) + vnorm_surf(inum,2) = vnorm_surf(inum,2) & + & + jac_sf_grp%xsf_sf(inum,ix,2) * g_FEM%owe2d(ix) + vnorm_surf(inum,3) = vnorm_surf(inum,3) & + & + jac_sf_grp%xsf_sf(inum,ix,3) * g_FEM%owe2d(ix) + end do + end do +! + do inum = ist, ied + if(area_surf(inum) .eq. 0.0d0) then + a_area_surf(inum) = 1.0d60 + else + a_area_surf(inum) = 1.0d0 / area_surf(inum) + end if +! + vnorm_surf(inum,1) = vnorm_surf(inum,1)*a_area_surf(inum) + vnorm_surf(inum,2) = vnorm_surf(inum,2)*a_area_surf(inum) + vnorm_surf(inum,3) = vnorm_surf(inum,3)*a_area_surf(inum) + end do + end do +!$omp end parallel do + end do +! + end subroutine int_normal_surf_groups +! +! --------------------------------------------------------------------- +! + subroutine int_surf_area_1_surf_grp(ele, surf, g_FEM, jac_2d, & + & num_int, num_sgrp, isurf_grp, area) +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(jacobians_2d), intent(in) :: jac_2d + integer (kind = kint), intent(in) :: num_int + integer (kind = kint), intent(in) :: num_sgrp + integer (kind = kint), intent(in) :: isurf_grp(2,num_sgrp) +! + real(kind = kreal), intent(inout) :: area +! + integer (kind = kint) :: iele, isf, isurf, inum + integer (kind = kint) :: ii, ix +! +! + area = 0.0d0 + do ii= 1, num_int * num_int + ix = g_FEM%int_start2(num_int) + ii +! +!$cdir nodep + do inum = 1, num_sgrp + iele = isurf_grp(1,inum) + isf = isurf_grp(2,inum) + isurf = abs(surf%isf_4_ele(iele,isf)) +! + area = area + dble(ele%interior_ele(iele)) & + & * jac_2d%xj_sf(isurf,ix) * g_FEM%owe2d(ix) + end do + end do +! + end subroutine int_surf_area_1_surf_grp +! +! --------------------------------------------------------------------- +! + end module int_area_normal_4_surface diff --git a/src/Fortran_libraries/UTILS_src/jacobian/int_volume_of_domain.f90 b/src/Fortran_libraries/UTILS_src/jacobian/int_volume_of_domain.f90 new file mode 100755 index 00000000..7b416d70 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/int_volume_of_domain.f90 @@ -0,0 +1,198 @@ +!>@file int_volume_of_domain.f90 +!! module int_volume_of_domain +!! +!!@author H. Matsui +!!@date Programmed in May, 2015 +!!@date programmed by H.Matsui and H.Okuda +!!@n in July 2000 (ver 1.1) +!!@n Modified by H. Matsui in Aug., 2006 +!!@n Modified by H. Matsui in June, 2007 +!!@n Modified by H. Matsui in Sep., 2016 +!!@n +!> @brief Construct jacobians and volume integrations +!! +!!@verbatim +!! subroutine jacobian_and_element_volume & +!! & (id_rank, nprocs, mesh, group, spfs, jacs) +!! subroutine const_jacobian_and_volume & +!! & (id_rank, nprocs, mesh, group, spf_3d, jacs) +!! subroutine const_jacobian_and_vol_layer(id_rank, nprocs, & +!! & node, ele, surf_grp, infty_grp, spfs, jacs, layer_tbl) +!! type(mesh_geometry), intent(inout) :: mesh +!! type(mesh_groups), intent(inout) :: group +!! type(node_data), intent(in) :: node +!! type(element_data), intent(inout) :: ele +!! type(surface_group_data), intent(in) :: surf_grp +!! type(scalar_surf_BC_list), intent(inout) :: infty_grp +!! type(shape_finctions_at_points), intent(inout) :: spfs +!! type(volume_shape_function), intent(inout) :: spf_3d +!! type(jacobians_type), intent(inout) :: jacs +!! type(layering_tbl), intent(inout) :: layer_tbl +!! subroutine s_int_volume_of_domain(ele, g_FEM, jac_3d) +!!@endverbatim +! + module int_volume_of_domain +! + use m_precision + use m_constants +! + use t_mesh_data + use t_geometry_data + use t_group_data + use t_surface_boundary + use t_shape_functions + use t_fem_gauss_int_coefs + use t_jacobians +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine jacobian_and_element_volume & + & (id_rank, nprocs, mesh, group, spfs, jacs) +! + use t_surface_group_normals + use set_normal_vectors + use const_jacobians_3d +! + integer, intent(in) :: id_rank, nprocs + type(mesh_geometry), intent(inout) :: mesh + type(mesh_groups), intent(inout) :: group + type(shape_finctions_at_points), intent(inout) :: spfs + type(jacobians_type), intent(inout) :: jacs +! +! + call initialize_FEM_integration & + & (jacs%g_FEM, spfs%spf_3d, spfs%spf_2d, spfs%spf_1d) +! + if (iflag_debug.gt.0) write(*,*) 'const_jacobian_and_volume' + call const_jacobian_and_volume & + & (id_rank, nprocs, mesh, group, spfs%spf_3d, jacs) + call dealloc_vol_shape_func(spfs%spf_3d) +! +! call check_jacobians_trilinear & +! & (id_rank, mesh%ele, jacs%jac_3d_l) +! + end subroutine jacobian_and_element_volume +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine const_jacobian_and_volume & + & (id_rank, nprocs, mesh, group, spf_3d, jacs) +! + use t_shape_functions + use sum_volume_of_domain + use const_jacobians_3d + use const_bc_infty_surf_type +! + integer, intent(in) :: id_rank, nprocs +! + type(mesh_geometry), intent(inout) :: mesh + type(mesh_groups), intent(inout) :: group + type(volume_shape_function), intent(inout) :: spf_3d + type(jacobians_type), intent(inout) :: jacs +! +! + call empty_infty_surf_type(group%infty_grp) +! + call alloc_vol_shape_func(mesh%ele%nnod_4_ele, & + & jacs%g_FEM, spf_3d) + call const_jacobians_element(id_rank, nprocs, & + & mesh%node, mesh%ele, group%surf_grp, group%infty_grp, & + & spf_3d, jacs) +! + call allocate_volume_4_smp + call s_int_volume_of_domain(mesh%ele, jacs%g_FEM, jacs%jac_3d) + call deallocate_volume_4_smp +! + call dealloc_dxi_dx_element(mesh%ele, jacs) +! + end subroutine const_jacobian_and_volume +! +!----------------------------------------------------------------------- +! + subroutine const_jacobian_and_vol_layer(id_rank, nprocs, & + & node, ele, surf_grp, infty_grp, spfs, jacs, layer_tbl) +! + use t_shape_functions + use t_layering_ele_list + use const_jacobians_3d + use sum_volume_of_domain + use cal_layered_volumes + use const_bc_infty_surf_type +! + integer, intent(in) :: id_rank, nprocs +! + type(node_data), intent(in) :: node + type(element_data), intent(inout) :: ele + type(surface_group_data), intent(inout) :: surf_grp + type(scalar_surf_BC_list), intent(inout) :: infty_grp + type(shape_finctions_at_points), intent(inout) :: spfs + type(jacobians_type), intent(inout) :: jacs + type(layering_tbl), intent(inout) :: layer_tbl +! +! + call empty_infty_surf_type(infty_grp) +! + call sel_max_int_point_by_etype(ele%nnod_4_ele, jacs%g_FEM) + call initialize_FEM_integration & + & (jacs%g_FEM, spfs%spf_3d, spfs%spf_2d, spfs%spf_1d) +! + call alloc_vol_shape_func & + & (ele%nnod_4_ele, jacs%g_FEM, spfs%spf_3d) + call const_jacobians_element(id_rank, nprocs, & + & node, ele, surf_grp, infty_grp, spfs%spf_3d, jacs) +! + call allocate_volume_4_smp + call s_int_volume_of_domain(ele, jacs%g_FEM, jacs%jac_3d) + call s_cal_layered_volumes(ele, layer_tbl) + call deallocate_volume_4_smp +! + call dealloc_dxi_dx_element(ele, jacs) +! + end subroutine const_jacobian_and_vol_layer +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine s_int_volume_of_domain(ele, g_FEM, jac_3d) +! + use calypso_mpi_real + use fem_element_volume + use sum_volume_of_domain +! + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(jacobians_3d), intent(in) :: jac_3d + type(element_data), intent(inout) :: ele +! +! +! write(*,*) 'fem_element_volume_pg', g_FEM%max_int_point + call fem_element_volume_pg & + & (ele, g_FEM, jac_3d, g_FEM%max_int_point) +! +! --- lead total volume +! +! write(*,*) 'sum_4_volume' + call sum_4_volume(ele%numele, ele%interior_ele, & + & ele%istack_ele_smp, ele%volume_ele, ele%volume_local) +! +! write(*,*) 'MPI_allREDUCE' + call calypso_mpi_allreduce_one_real & + & (ele%volume_local, ele%volume, MPI_SUM) +! + if (ele%volume .eq. 0.0d0) then + ele%a_vol = 1.0d30 + else + ele%a_vol = 1.0d0 / ele%volume + end if +! + end subroutine s_int_volume_of_domain +! +!----------------------------------------------------------------------- +! + end module int_volume_of_domain diff --git a/src/Fortran_libraries/UTILS_src/jacobian/m_gauss_int_parameters.f90 b/src/Fortran_libraries/UTILS_src/jacobian/m_gauss_int_parameters.f90 new file mode 100644 index 00000000..5f962b77 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/m_gauss_int_parameters.f90 @@ -0,0 +1,195 @@ +! +! module m_gauss_int_parameters +! +! Written by H. Matsui on March. 2006 +! +! subroutine init_gauss_int_parameters +! + module m_gauss_int_parameters +! + use m_precision + use m_constants +! + implicit none +! + real(kind = kreal) :: sqrt165 +! +! Base of Gauss points and their coefficients +! + real(kind = kreal) :: gauss_2p +! + real(kind = kreal) :: gauss_3pc + real(kind = kreal) :: gauss_3ps + real(kind = kreal) :: gauss_3wc + real(kind = kreal) :: gauss_3ws +! + real(kind = kreal) :: gauss_4pi + real(kind = kreal) :: gauss_4po + real(kind = kreal) :: gauss_4wi + real(kind = kreal) :: gauss_4wo +! +! Gauss points and their coefficients +! + real(kind = kreal), parameter :: pt1d_1g(1) = (/zero/) + real(kind = kreal), parameter :: wt1d_1g(1) = (/two /) +! + real(kind = kreal) :: pt1d_2g(2) + real(kind = kreal) :: wt1d_2g(2) +! + real(kind = kreal) :: pt1d_3g(3) + real(kind = kreal) :: wt1d_3g(3) +! + real(kind = kreal) :: pt1d_4g(4) + real(kind = kreal) :: wt1d_4g(4) +! +! Specital integration points and their coefficients by Irons(71) +! + real(kind = kreal) :: pt3d_q27_c + real(kind = kreal) :: pt3d_q27_s + real(kind = kreal) :: pt3d_q27_n + real(kind = kreal) :: pt3d_q27_e + real(kind = kreal) :: wt3d_q27_c + real(kind = kreal) :: wt3d_q27_s + real(kind = kreal) :: wt3d_q27_n + real(kind = kreal) :: wt3d_q27_e +! +! Integration points ID for 3-dimension +! + integer(kind = kint), parameter :: int_position_1(3) & + & = (/ 1, 1, 1/) + + integer(kind = kint), parameter :: int_position_8(24) & + & = (/ 1, 1, 1, 2, 1, 1, & + & 1, 2, 1, 2, 2, 1, & + & 1, 1, 2, 2, 1, 2, & + & 1, 2, 2, 2, 2, 2 /) + + integer(kind = kint), parameter :: int_position_27(81) & + & = (/ 1, 1, 1, 2, 1, 1, 3, 1, 1, & + & 1, 2, 1, 2, 2, 1, 3, 2, 1, & + & 1, 3, 1, 2, 3, 1, 3, 3, 1, & + & 1, 1, 2, 2, 1, 2, 3, 1, 2, & + & 1, 2, 2, 2, 2, 2, 3, 2, 2, & + & 1, 3, 2, 2, 3, 2, 3, 3, 2, & + & 1, 1, 3, 2, 1, 3, 3, 1, 3, & + & 1, 2, 3, 2, 2, 3, 3, 2, 3, & + & 1, 3, 3, 2, 3, 3, 3, 3, 3 /) + + integer(kind = kint), parameter :: int_position_64(192) & + & = (/ 1, 1, 1, 2, 1, 1, 3, 1, 1, 4, 1, 1, & + & 1, 2, 1, 2, 2, 1, 3, 2, 1, 4, 2, 1, & + & 1, 3, 1, 2, 3, 1, 3, 3, 1, 4, 3, 1, & + & 1, 4, 1, 2, 4, 1, 3, 4, 1, 4, 4, 1, & + & 1, 1, 2, 2, 1, 2, 3, 1, 2, 4, 1, 2, & + & 1, 2, 2, 2, 2, 2, 3, 2, 2, 4, 2, 2, & + & 1, 3, 2, 2, 3, 2, 3, 3, 2, 4, 3, 2, & + & 1, 4, 2, 2, 4, 2, 3, 4, 2, 4, 4, 2, & + & 1, 1, 3, 2, 1, 3, 3, 1, 3, 4, 1, 3, & + & 1, 2, 3, 2, 2, 3, 3, 2, 3, 4, 2, 3, & + & 1, 3, 3, 2, 3, 3, 3, 3, 3, 4, 3, 3, & + & 1, 4, 3, 2, 4, 3, 3, 4, 3, 4, 4, 3, & + & 1, 1, 4, 2, 1, 4, 3, 1, 4, 4, 1, 4, & + & 1, 2, 4, 2, 2, 4, 3, 2, 4, 4, 2, 4, & + & 1, 3, 4, 2, 3, 4, 3, 3, 4, 4, 3, 4, & + & 1, 4, 4, 2, 4, 4, 3, 4, 4, 4, 4, 4/) +! +! Integration points ID for 2-dimension +! + integer(kind = kint), parameter :: int_posi_2d_1(2) & + & = (/ 1, 1/) + + integer(kind = kint), parameter :: int_posi_2d_4(8) & + & = (/ 1, 1, 2, 1, & + & 1, 2, 2, 2/) + + integer(kind = kint), parameter :: int_posi_2d_9(18) & + & = (/ 1, 1, 2, 1, 3, 1, & + & 1, 2, 2, 2, 3, 2, & + & 1, 3, 2, 3, 3, 3/) + + integer(kind = kint), parameter :: int_posi_2d_16(32) & + & = (/ 1, 1, 2, 1, 3, 1, 4, 1, & + & 1, 2, 2, 2, 3, 2, 4, 2, & + & 1, 3, 2, 3, 3, 3, 4, 3, & + & 1, 4, 2, 4, 3, 4, 4, 4/) +! +! +! Integration points ID for 1-dimension +! + integer(kind = kint), parameter :: int_posi_1d_1(1) & + & = (/1/) + + integer(kind = kint), parameter :: int_posi_1d_2(2) & + & = (/ 1, 2/) + + integer(kind = kint), parameter :: int_posi_1d_3(3) & + & = (/ 1, 2, 3/) + + integer(kind = kint), parameter :: int_posi_1d_4(4) & + & = (/ 1, 2, 3, 4/) +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine init_gauss_int_parameters +! +! + gauss_2p = one/sqrt(three) +! + gauss_3pc = zero + gauss_3ps = sqrt(3.0d00/5.0d00) + gauss_3wc = eight / dnine + gauss_3ws = five / dnine +! + gauss_4pi = sqrt( three/seven - two*sqrt(thirty)/(seven*five) ) + gauss_4po = sqrt( three/seven + two*sqrt(thirty)/(seven*five) ) +! + gauss_4wi = one/two + sqrt(thirty) / (dnine*four) + gauss_4wo = one/two - sqrt(thirty) / (dnine*four) +! + pt1d_2g(1) = -gauss_2p + pt1d_2g(2) = gauss_2p + wt1d_2g(1:2) = one +! + pt1d_3g(1) = -gauss_3ps + pt1d_3g(2) = gauss_3pc + pt1d_3g(3) = gauss_3ps + wt1d_3g(1) = gauss_3ws + wt1d_3g(2) = gauss_3wc + wt1d_3g(3) = gauss_3ws +! + pt1d_4g(1) = -gauss_4po + pt1d_4g(2) = -gauss_4pi + pt1d_4g(3) = gauss_4pi + pt1d_4g(4) = gauss_4po + wt1d_4g(1) = gauss_4wo + wt1d_4g(2) = gauss_4wi + wt1d_4g(3) = gauss_4wi + wt1d_4g(4) = gauss_4wo +! +! + sqrt165 = sqrt(165.0d0) +! + pt3d_q27_c = zero + pt3d_q27_s = sqrt( ( 33.0d0 - sqrt165) / 28.0d0 ) + pt3d_q27_n = sqrt( (195.0d0 - four*sqrt165) / 337.0d0 ) + pt3d_q27_e = sqrt( ( 30.0d0 + sqrt165) / 35.0d0 ) +! + wt3d_q27_c = (157.0d0 - (sqrt165 * 557.0d0 / 495.0d0) ) & + & * 256.0d0 / 46305.0d0 + wt3d_q27_s = ( two + (sqrt165 * 104.0d0 / 99.0d0) ) & + & * 128.0d0 / 945.0d0 + wt3d_q27_n = (13273.0d0 + (sqrt165 * 31124.0d0 / five) ) & + & * one / 46305.0d0 + wt3d_q27_e = ( 2790.0d0 - (sqrt165 * 191.0d0) ) & + & * eight / 83349.0d0 +! +! + end subroutine init_gauss_int_parameters +! +! ---------------------------------------------------------------------- +! + end module m_gauss_int_parameters diff --git a/src/Fortran_libraries/UTILS_src/jacobian/set_gauss_int_parameters.f90 b/src/Fortran_libraries/UTILS_src/jacobian/set_gauss_int_parameters.f90 new file mode 100644 index 00000000..92f883dc --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/set_gauss_int_parameters.f90 @@ -0,0 +1,182 @@ +! +! module set_gauss_int_parameters +! +! Written by H. Matsui on March. 2006 +! +!! subroutine set_gauss_coefs_4_3d & +!! & (max_int_point, maxtot_int_1d, int_start1, xi1, owe, & +!! & maxtot_int_3d, int_start3, l_int, xi3, ei3, zi3, owe3d) +!! subroutine set_gauss_coefs_4_2d & +!! & (max_int_point, maxtot_int_1d, int_start1, xi1, owe, & +!! & maxtot_int_2d, int_start2, l_int2d, xi2, ei2, owe2d) +!! subroutine set_gauss_coefs_4_1d & +!! & (max_int_point, maxtot_int_1d, int_start1, xi1, owe) +! + module set_gauss_int_parameters +! + use m_precision +! + implicit none +! + private :: set_gauss_coefs_1d_n +! +! ---------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_gauss_coefs_4_3d & + & (max_int_point, maxtot_int_1d, int_start1, xi1, owe, & + & maxtot_int_3d, int_start3, l_int, xi3, ei3, zi3, owe3d) +! + integer(kind = kint), intent(in) :: maxtot_int_1d + integer(kind = kint), intent(in) :: max_int_point, maxtot_int_3d + integer(kind = kint), intent(in) :: int_start1(max_int_point) + integer(kind = kint), intent(in) :: int_start3(max_int_point) +! + integer(kind = kint), intent(in) & + & :: l_int(3,maxtot_int_3d,max_int_point) + real(kind = kreal), intent(in) :: xi1(maxtot_int_1d) + real(kind = kreal), intent(in) :: owe(maxtot_int_1d) +! + real(kind = kreal), intent(inout) :: xi3(maxtot_int_3d) + real(kind = kreal), intent(inout) :: ei3(maxtot_int_3d) + real(kind = kreal), intent(inout) :: zi3(maxtot_int_3d) + real(kind = kreal), intent(inout) :: owe3d(maxtot_int_3d) +! + integer(kind = kint) :: n, ix, ii, i1, i2, i3 +! +! + do n = 1, max_int_point + do ii = 1, n*n*n + ix = ii + int_start3(n) + i1 = l_int(1,ii,n) + int_start1(n) + i2 = l_int(2,ii,n) + int_start1(n) + i3 = l_int(3,ii,n) + int_start1(n) + xi3(ix) = xi1(i1) + ei3(ix) = xi1(i2) + zi3(ix) = xi1(i3) + owe3d(ix) = owe(i1) * owe(i2) * owe(i3) + end do + end do +! + end subroutine set_gauss_coefs_4_3d +! +! --------------------------------------------------------------------- +! + subroutine set_gauss_coefs_4_2d & + & (max_int_point, maxtot_int_1d, int_start1, xi1, owe, & + & maxtot_int_2d, int_start2, l_int2d, xi2, ei2, owe2d) +! + integer(kind = kint), intent(in) :: maxtot_int_1d + integer(kind = kint), intent(in) :: max_int_point, maxtot_int_2d + integer(kind = kint), intent(in) :: int_start1(max_int_point) + integer(kind = kint), intent(in) :: int_start2(max_int_point) +! + integer(kind = kint), intent(in) & + & :: l_int2d(2,maxtot_int_2d,max_int_point) + real(kind= kreal), intent(in) :: xi1(maxtot_int_1d) + real(kind = kreal), intent(in) :: owe(maxtot_int_1d) +! + real(kind = kreal), intent(inout) :: xi2(maxtot_int_2d) + real(kind = kreal), intent(inout) :: ei2(maxtot_int_2d) + real(kind = kreal), intent(inout) :: owe2d(maxtot_int_2d) +! + integer(kind = kint) :: n, ii, ix, i1, i2 +! + do n = 1, max_int_point + do ii = 1, n*n + ix = ii + int_start2(n) + i1 = l_int2d(1,ii,n) + int_start1(n) + i2 = l_int2d(2,ii,n) + int_start1(n) + xi2(ix) = xi1(i1) + ei2(ix) = xi1(i2) + owe2d(ix) = owe(i1) * owe(i2) + end do + end do +! + end subroutine set_gauss_coefs_4_2d +! +! --------------------------------------------------------------------- +! + subroutine set_gauss_coefs_4_1d & + & (max_int_point, maxtot_int_1d, int_start1, xi1, owe) +! + use m_constants + use m_gauss_int_parameters + use t_gauss_points +! + integer(kind = kint), intent(in) :: max_int_point, maxtot_int_1d + integer(kind = kint), intent(in) :: int_start1(max_int_point) +! + real(kind = kreal), intent(inout) :: xi1(maxtot_int_1d) + real(kind = kreal), intent(inout) :: owe(maxtot_int_1d) +! + integer(kind = kint) :: n + type(gauss_points) :: gauss_1d +! +! + if (max_int_point .ge. ione) then + call set_gauss_coefs_1d_n(ione, pt1d_1g, wt1d_1g, & + & max_int_point, maxtot_int_1d, int_start1, xi1, owe) + end if +! + if (max_int_point .ge. itwo) then + call set_gauss_coefs_1d_n(itwo, pt1d_2g, wt1d_2g, & + & max_int_point, maxtot_int_1d, int_start1, xi1, owe) + end if +! + if (max_int_point .ge. ithree) then + call set_gauss_coefs_1d_n(ithree, pt1d_3g, wt1d_3g, & + & max_int_point, maxtot_int_1d, int_start1, xi1, owe) + end if +! + if (max_int_point .ge. ifour) then + call set_gauss_coefs_1d_n(ifour, pt1d_4g, wt1d_4g, & + & max_int_point, maxtot_int_1d, int_start1, xi1, owe) + end if +! +! +! + if (max_int_point .ge. 5) then + do n = 5, max_int_point + call construct_gauss_coefs(n, gauss_1d) +! + call set_gauss_coefs_1d_n(n, gauss_1d%point, gauss_1d%weight, & + & max_int_point, maxtot_int_1d, int_start1, xi1, owe) +! + call dealloc_gauss_points(gauss_1d) + end do + end if +! + end subroutine set_gauss_coefs_4_1d +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_gauss_coefs_1d_n(n, pt1d, wt1d, & + & max_int_point, maxtot_int_1d, int_start1, xi1, owe) +! + integer(kind = kint), intent(in) :: n + real(kind = kreal), intent(in) :: pt1d(n), wt1d(n) + integer(kind = kint), intent(in) :: max_int_point, maxtot_int_1d + integer(kind = kint), intent(in) :: int_start1(max_int_point) +! + real(kind = kreal), intent(inout) :: xi1(maxtot_int_1d) + real(kind = kreal), intent(inout) :: owe(maxtot_int_1d) +! + integer(kind = kint) :: ix, ii +! +! + do ii = 1, n + ix = ii + int_start1(n) + xi1(ix) = pt1d(ii) + owe(ix) = wt1d(ii) + end do +! + end subroutine set_gauss_coefs_1d_n +! +! --------------------------------------------------------------------- +! + end module set_gauss_int_parameters diff --git a/src/Fortran_libraries/UTILS_src/jacobian/set_integration_indices.f90 b/src/Fortran_libraries/UTILS_src/jacobian/set_integration_indices.f90 new file mode 100644 index 00000000..2eb6d621 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/set_integration_indices.f90 @@ -0,0 +1,217 @@ +! +! module set_integration_indices +! +! Written by H. Matsui on March. 2006 +! +!! subroutine set_integrate_indices_3d & +!! & (ntot_int_3d, max_int_point, l_int) +!! subroutine set_integrate_indices_2d & +!! & (ntot_int_2d, max_int_point, l_int2d) +!! subroutine set_integrate_indices_1d & +!! & (ntot_int_1d, max_int_point, l_int1d) +!! +!! subroutine set_integration_indices_3d_mesh & +!! & (ntot_int_3d, max_int_point, l_int) +!! subroutine set_integration_indices_2d_mesh & +!! & (ntot_int_2d, max_int_point, l_int2d) +!! subroutine set_integration_indices_1d_mesh & +!! & (ntot_int_1d, max_int_point, l_int1d) +! + module set_integration_indices +! + use m_precision + use m_gauss_int_parameters +! + implicit none +! +! ---------------------------------------------------------------------- +! + contains +! +! +! --------------------------------------------------------------------- +! + subroutine set_integrate_indices_3d & + & (ntot_int_3d, max_int_point, l_int) +! + integer(kind = kint), intent(in) :: ntot_int_3d + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(inout) & + & :: l_int(3,ntot_int_3d,max_int_point) +! + integer(kind = kint) :: n, i, kx, ky, kz +! +! + do n = 1, max_int_point + do kz = 1, n + do ky = 1, n + do kx = 1, n + i = kx + n*(ky-1) + n*n*(kz-1) + l_int(1,i,n) = kx + l_int(2,i,n) = ky + l_int(3,i,n) = kz + end do + end do + end do + end do +! + end subroutine set_integrate_indices_3d +! +! --------------------------------------------------------------------- +! + subroutine set_integrate_indices_2d & + & (ntot_int_2d, max_int_point, l_int2d) +! + integer(kind = kint), intent(in) :: ntot_int_2d + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(inout) & + & :: l_int2d(2,ntot_int_2d,max_int_point) +! + integer(kind = kint) :: n, i, kx, ky +! +! + do n = 1, max_int_point + do ky = 1, n + do kx = 1, n + i = kx + n*(ky-1) + l_int2d(1,i,n) = kx + l_int2d(2,i,n) = ky + end do + end do + end do +! + end subroutine set_integrate_indices_2d +! +! --------------------------------------------------------------------- +! + subroutine set_integrate_indices_1d & + & (ntot_int_1d, max_int_point, l_int1d) +! + integer(kind = kint), intent(in) :: ntot_int_1d + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(inout) & + & :: l_int1d(1,ntot_int_1d,max_int_point) +! + integer(kind = kint) :: n, kx +! + do n = 1, max_int_point + do kx = 1, n + l_int1d(1,kx,n) = kx + end do + end do +! + end subroutine set_integrate_indices_1d +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine set_integration_indices_3d_mesh & + & (ntot_int_3d, max_int_point, l_int) +! + integer(kind = kint), intent(in) :: ntot_int_3d + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(inout) & + & :: l_int(3,ntot_int_3d,max_int_point) +! + integer(kind = kint) :: nd, ii, j +! +! + do nd = 1, 3 + l_int(nd,1,1) = int_position_1(nd) + end do +! + do ii = 1, 8 + do nd = 1, 3 + j = nd + 3*(ii-1) + l_int(nd,ii,2) = int_position_8(j) + end do + end do +! + do ii = 1, 27 + do nd = 1, 3 + j = nd + 3*(ii-1) + l_int(nd,ii,3) = int_position_27(j) + end do + end do +! + do ii = 1, 64 + do nd = 1, 3 + j = nd + 3*(ii-1) + l_int(nd,ii,4) = int_position_64(j) + end do + end do +! + end subroutine set_integration_indices_3d_mesh +! +! --------------------------------------------------------------------- +! + subroutine set_integration_indices_2d_mesh & + & (ntot_int_2d, max_int_point, l_int2d) +! + integer(kind = kint), intent(in) :: ntot_int_2d + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(inout) & + & :: l_int2d(2,ntot_int_2d,max_int_point) +! + integer(kind = kint) :: nd, ii, j +! +! + do nd = 1, 2 + l_int2d(nd,1,1) = int_posi_2d_1(nd) + end do +! + do ii = 1, 4 + do nd = 1, 2 + j = nd + 2*(ii-1) + l_int2d(nd,ii,2) = int_posi_2d_4(j) + end do + end do +! + do ii = 1, 9 + do nd = 1, 2 + j = nd + 2*(ii-1) + l_int2d(nd,ii,3) = int_posi_2d_9(j) + end do + end do +! + do ii = 1, 16 + do nd = 1, 2 + j = nd + 2*(ii-1) + l_int2d(nd,ii,4) = int_posi_2d_16(j) + end do + end do +! + end subroutine set_integration_indices_2d_mesh +! +! --------------------------------------------------------------------- +! + subroutine set_integration_indices_1d_mesh & + & (ntot_int_1d, max_int_point, l_int1d) +! + integer(kind = kint), intent(in) :: ntot_int_1d + integer(kind = kint), intent(in) :: max_int_point + integer(kind = kint), intent(inout) & + & :: l_int1d(1,ntot_int_1d,max_int_point) +! + integer(kind = kint) :: ii +! +! + l_int1d(1,1,1) = int_posi_1d_1(1) +! + do ii = 1, 2 + l_int1d(1,ii,2) = int_posi_1d_2(ii) + end do +! + do ii = 1, 3 + l_int1d(1,ii,3) = int_posi_1d_3(ii) + end do +! + do ii = 1, 4 + l_int1d(1,ii,4) = int_posi_1d_4(ii) + end do +! + end subroutine set_integration_indices_1d_mesh +! +! --------------------------------------------------------------------- +! + end module set_integration_indices diff --git a/src/Fortran_libraries/UTILS_src/jacobian/set_normal_vectors.f90 b/src/Fortran_libraries/UTILS_src/jacobian/set_normal_vectors.f90 new file mode 100644 index 00000000..44921459 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/set_normal_vectors.f90 @@ -0,0 +1,179 @@ +!>@file set_normal_vectors.f90 +!!@brief module set_normal_vectors +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2006 +!! +!>@brief Construct normal vector on surface data +!! +!!@verbatim +!! subroutine surf_grp_jacobian_and_normal & +!! & (id_rank, nprocs, mesh, group, spfs, jacs) +!! type(mesh_geometry), intent(in) :: mesh +!! type(mesh_groups), intent(inout) :: group +!! type(shape_finctions_at_points), intent(inout) :: spfs +!! type(jacobians_type), intent(inout) :: jacs +!! subroutine surf_jacobian_sf_grp_normal(id_rank, nprocs, & +!! & mesh, group, spfs, jacs) +!! type(mesh_geometry), intent(inout) :: mesh +!! type(mesh_groups), intent(inout) :: group +!! type(shape_finctions_at_points), intent(inout) :: spfs +!! type(jacobians_type), intent(inout) :: jacs +!!@endverbatim +!! + module set_normal_vectors +! + use m_precision +! + use m_machine_parameter + use t_mesh_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_surface_group_normals + use t_shape_functions + use t_fem_gauss_int_coefs + use t_jacobians + use t_jacobian_2d +! + implicit none +! + private :: const_surf_group_normals, const_normal_vector +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine surf_grp_jacobian_and_normal & + & (id_rank, nprocs, mesh, group, spfs, jacs) +! + use int_area_normal_4_surface + use sum_normal_4_surf_group + use set_connects_4_surf_group +! + integer, intent(in) :: id_rank, nprocs + type(mesh_geometry), intent(in) :: mesh +! + type(mesh_groups), intent(inout) :: group + type(shape_finctions_at_points), intent(inout) :: spfs + type(jacobians_type), intent(inout) :: jacs +! +! + call const_surf_group_normals & + & (id_rank, nprocs, mesh%node, mesh%ele, mesh%surf, & + & group%surf_grp, group%surf_grp_norm, spfs%spf_2d, jacs) +! call dealloc_jacobians_surf_grp(mesh%surf, jacs) +! + if (iflag_debug.eq.1) write(*,*) 's_sum_normal_4_surf_group' + call s_sum_normal_4_surf_group(mesh%ele, & + & group%surf_grp, group%surf_grp_norm) +! + if (iflag_debug.eq.1) write(*,*) 'cal_surf_norm_node' + call cal_surf_normal_at_nod(mesh%node, mesh%ele, mesh%surf, & + & group%surf_grp, group%surf_grp_norm, group%surf_nod_grp) +! + end subroutine surf_grp_jacobian_and_normal +! +!----------------------------------------------------------------------- +! + subroutine surf_jacobian_sf_grp_normal(id_rank, nprocs, & + & mesh, group, spfs, jacs) +! + use sum_normal_4_surf_group + use set_connects_4_surf_group +! + integer, intent(in) :: id_rank, nprocs +! + type(mesh_geometry), intent(inout) :: mesh + type(mesh_groups), intent(inout) :: group + type(shape_finctions_at_points), intent(inout) :: spfs + type(jacobians_type), intent(inout) :: jacs +! +! --------------------- Surface jacobian for fieldline +! + if (iflag_debug.eq.1) write(*,*) 'const_normal_vector' + call const_normal_vector(id_rank, nprocs, & + & mesh%node, mesh%surf, spfs%spf_2d, jacs) + call dealloc_jacobians_surface(mesh%surf, jacs) +! + if (iflag_debug.eq.1) write(*,*) 'pick_normal_of_surf_group' + call pick_normal_of_surf_group(mesh%ele, mesh%surf, mesh%edge, & + & group%surf_grp, group%surf_grp_norm) +! + if (iflag_debug.eq.1) write(*,*) 's_sum_normal_4_surf_group' + call s_sum_normal_4_surf_group(mesh%ele, & + & group%surf_grp, group%surf_grp_norm) +! + if (iflag_debug.eq.1) write(*,*) 'cal_surf_norm_node' + call cal_surf_normal_at_nod(mesh%node, mesh%ele, mesh%surf, & + & group%surf_grp, group%surf_grp_norm, group%surf_nod_grp) +! + end subroutine surf_jacobian_sf_grp_normal +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine const_surf_group_normals & + & (id_rank, nprocs, node, ele, surf, sf_grp, & + & surf_grp_norm, spf_2d, jacs) +! + use int_area_normal_4_surface + use sum_normal_4_surf_group +! + integer, intent(in) :: id_rank, nprocs + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf +! + type(surface_group_data), intent(in) :: sf_grp + type(surface_group_normals), intent(inout) :: surf_grp_norm + type(surface_shape_function), intent(inout) :: spf_2d + type(jacobians_type), intent(inout) :: jacs +! +! + if (iflag_debug.eq.1) write(*,*) 'const_jacobian_sf_grp' + call alloc_surf_shape_func(surf%nnod_4_surf, jacs%g_FEM, spf_2d) + call const_jacobians_surf_group(id_rank, nprocs, & + & node, ele, surf, sf_grp, spf_2d, jacs) +! + call alloc_vectors_surf_group & + & (sf_grp%num_grp, sf_grp%num_item, surf_grp_norm) + call int_normal_surf_groups(sf_grp, jacs%g_FEM, jacs%jac_sf_grp, & + & jacs%g_FEM%max_int_point, surf_grp_norm%area_sf_grp, & + & surf_grp_norm%a_area_sf_grp, surf_grp_norm%vnorm_sf_grp) + call dealloc_surf_shape_func(spf_2d) +! + end subroutine const_surf_group_normals +! +!----------------------------------------------------------------------- +! + subroutine const_normal_vector & + & (id_rank, nprocs, node, surf, spf_2d, jacs) +! + use int_area_normal_4_surface +! + integer, intent(in) :: id_rank, nprocs + type(node_data), intent(in) :: node +! + type(surface_data), intent(inout) :: surf + type(surface_shape_function), intent(inout) :: spf_2d + type(jacobians_type), intent(inout) :: jacs +! +! + call alloc_surf_shape_func(surf%nnod_4_surf, jacs%g_FEM, spf_2d) + call const_jacobians_surface & + & (id_rank, nprocs, node, surf, spf_2d, jacs) +! + call alloc_normal_vector(surf) + call int_normal_all_surf & + & (surf, jacs%g_FEM, jacs%jac_2d, jacs%g_FEM%max_int_point, & + & surf%area_surf, surf%a_area_surf, surf%vnorm_surf) + call dealloc_surf_shape_func(spf_2d) +! + end subroutine const_normal_vector +! +!----------------------------------------------------------------------- +! + end module set_normal_vectors diff --git a/src/Fortran_libraries/UTILS_src/jacobian/set_shape_elements_infty_sf.f90 b/src/Fortran_libraries/UTILS_src/jacobian/set_shape_elements_infty_sf.f90 new file mode 100644 index 00000000..3857c118 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/set_shape_elements_infty_sf.f90 @@ -0,0 +1,205 @@ +! +! module set_shape_elements_infty_sf +! +! modified by H. Matsui on Aug., 2006 +! +! subroutine s_shape_elenents_inf_aw_3d(isf, xk, & +! & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & +! & xi_sqre, ei_sqre, zi_sqre, xi_inf, ei_inf, zi_inf, & +! & dxi_inf, dei_inf, dzi_inf, xi, ei, zi) +! +! subroutine s_shape_elenents_inf_aw_2d(isf, xk, & +! & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, & +! & xi_inf, ei_inf, dxi_inf, dei_inf, xi, ei) +! +! subroutine s_shape_elenents_inf_aw_1d(isf, xk, & +! & xi_nega, xi_posi, xi_sqre, xi_inf, dxi_inf, xi) +! + module set_shape_elements_infty_sf +! + use m_precision +! + use m_constants + use shape_func_elements + use shape_func_infty_elements +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_shape_elenents_inf_aw_3d(isf, xk, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, xi_inf, ei_inf, zi_inf, & + & dxi_inf, dei_inf, dzi_inf, xi, ei, zi) +! +! + integer(kind = kint) :: isf + real (kind=kreal), intent(in) :: xk + real (kind=kreal), intent(in) :: xi, ei, zi +! + real (kind=kreal), intent(inout) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(inout) :: xi_posi, ei_posi, zi_posi + real (kind=kreal), intent(inout) :: xi_sqre, ei_sqre, zi_sqre + real (kind=kreal), intent(inout) :: xi_inf, ei_inf, zi_inf + real (kind=kreal), intent(inout) :: dxi_inf, dei_inf, dzi_inf +! +! + if (isf .eq. 1) then +! + call s_shape_elenents_aw_inf_odd_1d(xi_inf, dxi_inf, & + & xi_nega, xi_posi, xi_sqre, xi, xk) + call s_shape_elenents_aw_1d(ei_nega, ei_posi, ei_sqre, ei) + call s_shape_elenents_aw_1d(zi_nega, zi_posi, zi_sqre, zi) + ei_inf = ei + zi_inf = zi + dei_inf = one + dzi_inf = one +! + else if(isf .eq. 2) then +! + call s_shape_elenents_aw_inf_even_1d(xi_inf, dxi_inf, & + & xi_nega, xi_posi, xi_sqre, xi, xk) + call s_shape_elenents_aw_1d(ei_nega, ei_posi, ei_sqre, ei) + call s_shape_elenents_aw_1d(zi_nega, zi_posi, zi_sqre, zi) + ei_inf = ei + zi_inf = zi + dei_inf = one + dzi_inf = one +! + else if(isf .eq. 3) then +! + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi) + call s_shape_elenents_aw_inf_odd_1d(ei_inf, dei_inf, & + & ei_nega, ei_posi, ei_sqre, ei, xk) + call s_shape_elenents_aw_1d(zi_nega, zi_posi, zi_sqre, zi) + xi_inf = xi + zi_inf = zi + dxi_inf = one + dzi_inf = one +! + else if(isf .eq. 4) then +! + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi) + call s_shape_elenents_aw_inf_even_1d(ei_inf, dei_inf, & + & ei_nega, ei_posi, ei_sqre, ei, xk) + call s_shape_elenents_aw_1d(zi_nega, zi_posi, zi_sqre, zi) + xi_inf = xi + zi_inf = zi + dxi_inf = one + dzi_inf = one +! + else if(isf .eq. 5) then +! + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi) + call s_shape_elenents_aw_1d(ei_nega, ei_posi, ei_sqre, ei) + call s_shape_elenents_aw_inf_odd_1d(zi_inf, dzi_inf, & + & zi_nega, zi_posi, zi_sqre, zi, xk) + xi_inf = xi + ei_inf = ei + dxi_inf = one + dei_inf = one +! + else if(isf .eq. 6) then +! + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi) + call s_shape_elenents_aw_1d(ei_nega, ei_posi, ei_sqre, ei) + call s_shape_elenents_aw_inf_even_1d(zi_inf, dzi_inf, & + & zi_nega, zi_posi, zi_sqre, zi, xk) + xi_inf = xi + ei_inf = ei + dxi_inf = one + dei_inf = one +! + end if +! + end subroutine s_shape_elenents_inf_aw_3d +! +!----------------------------------------------------------------------- +! + subroutine s_shape_elenents_inf_aw_2d(isf, xk, & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, & + & xi_inf, ei_inf, dxi_inf, dei_inf, xi, ei) +! +! + integer(kind = kint) :: isf + real (kind=kreal), intent(in) :: xk + real (kind=kreal), intent(in) :: xi, ei +! + real (kind=kreal), intent(inout) :: xi_nega, ei_nega + real (kind=kreal), intent(inout) :: xi_posi, ei_posi + real (kind=kreal), intent(inout) :: xi_sqre, ei_sqre + real (kind=kreal), intent(inout) :: xi_inf, ei_inf + real (kind=kreal), intent(inout) :: dxi_inf, dei_inf +! +! + if (isf .eq. 4) then +! + call s_shape_elenents_aw_inf_odd_1d(xi_inf, dxi_inf, & + & xi_nega, xi_posi, xi_sqre, xi, xk) + call s_shape_elenents_aw_1d(ei_nega, ei_posi, ei_sqre, ei) + ei_inf = ei + dei_inf = one +! + else if(isf .eq. 2) then +! + call s_shape_elenents_aw_inf_even_1d(xi_inf, dxi_inf, & + & xi_nega, xi_posi, xi_sqre, xi, xk) + call s_shape_elenents_aw_1d(ei_nega, ei_posi, ei_sqre, ei) + ei_inf = ei + dei_inf = one +! + else if(isf .eq. 1) then +! + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi) + call s_shape_elenents_aw_inf_odd_1d(ei_inf, dei_inf, & + & ei_nega, ei_posi, ei_sqre, ei, xk) + xi_inf = xi + dxi_inf = one +! + else if(isf .eq. 3) then +! + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi) + call s_shape_elenents_aw_inf_even_1d(ei_inf, dei_inf, & + & ei_nega, ei_posi, ei_sqre, ei, xk) + xi_inf = xi + dxi_inf = one +! + end if +! + end subroutine s_shape_elenents_inf_aw_2d +! +!----------------------------------------------------------------------- +! + subroutine s_shape_elenents_inf_aw_1d(isf, xk, & + & xi_nega, xi_posi, xi_sqre, xi_inf, dxi_inf, xi) +! +! + integer(kind = kint) :: isf + real (kind=kreal), intent(in) :: xk + real (kind=kreal), intent(in) :: xi +! + real (kind=kreal), intent(inout) :: xi_nega, xi_posi, xi_sqre + real (kind=kreal), intent(inout) :: xi_inf, dxi_inf +! +! + if (isf .eq. 1) then +! + call s_shape_elenents_aw_inf_odd_1d(xi_inf, dxi_inf, & + & xi_nega, xi_posi, xi_sqre, xi, xk) +! + else if(isf .eq. 2) then +! + call s_shape_elenents_aw_inf_even_1d(xi_inf, dxi_inf, & + & xi_nega, xi_posi, xi_sqre, xi, xk) +! + end if +! + end subroutine s_shape_elenents_inf_aw_1d +! +!----------------------------------------------------------------------- +! + end module set_shape_elements_infty_sf diff --git a/src/Fortran_libraries/UTILS_src/jacobian/shape_func_1d_linear.f90 b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_1d_linear.f90 new file mode 100644 index 00000000..221be105 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_1d_linear.f90 @@ -0,0 +1,54 @@ +! +! module shape_func_1d_linear +! +! Written by H. Matsui on Sep. 2005 +! +! subroutine shape_function_an_1d_1(an_1, xi_nega, xi_posi) +! subroutine shape_function_dnxi_1d_1(dnxi, dxi) +! +! xi: \xi +! xi_nega: 1 - \xi +! xi_posi: 1 + \xi +! + module shape_func_1d_linear +! + use m_precision + use m_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine shape_function_an_1d_1(an_1, xi_nega, xi_posi) +! + real (kind=kreal), intent(inout) :: an_1(2) +! + real (kind=kreal), intent(in) :: xi_nega, xi_posi +! +! + an_1(1) = half * xi_nega + an_1(2) = half * xi_posi +! +! + end subroutine shape_function_an_1d_1 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnxi_1d_1(dnxi, dxi) +! + real (kind=kreal), intent(inout) :: dnxi(2) + real (kind=kreal), intent(in) :: dxi +! +! + dnxi(1) = -half * dxi + dnxi(2) = half * dxi +! + end subroutine shape_function_dnxi_1d_1 +! +!----------------------------------------------------------------------- +! + end module shape_func_1d_linear diff --git a/src/Fortran_libraries/UTILS_src/jacobian/shape_func_1d_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_1d_quad.f90 new file mode 100644 index 00000000..cc1c1dc0 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_1d_quad.f90 @@ -0,0 +1,62 @@ +! +! module shape_func_1d_quad +! +! Written by H. Matsui on Sep. 2005 +! +! subroutine shape_function_an_1d_20(an_20, xi, & +! & xi_nega, xi_posi, xi_sqre) +! subroutine shape_function_dnxi_1d_20(dnxi, xi, dxi) +! +! xi: \xi +! xi_nega: 1 - \xi +! xi_posi: 1 + \xi +! xi_sqre: 1 - \xi +! + module shape_func_1d_quad +! + use m_precision +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine shape_function_an_1d_20(an_20, xi, & + & xi_nega, xi_posi, xi_sqre) +! + use m_constants +! + real (kind=kreal), intent(inout) :: an_20(3) +! + real (kind=kreal), intent(in) :: xi + real (kind=kreal), intent(in) :: xi_nega, xi_posi, xi_sqre +! +! + an_20(1) = -half * xi * xi_nega + an_20(2) = xi_sqre + an_20(3) = half * xi * xi_posi +! + end subroutine shape_function_an_1d_20 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnxi_1d_20(dnxi, xi, dxi) +! + use m_constants +! + real (kind=kreal), intent(inout) :: dnxi(3) + real (kind=kreal), intent(in) :: xi, dxi +! +! + dnxi(1) = -half * (one - two*xi) * dxi + dnxi(2) = -two * xi * dxi + dnxi(3) = half * (one + two*xi) * dxi +! + end subroutine shape_function_dnxi_1d_20 +! +!----------------------------------------------------------------------- +! + end module shape_func_1d_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/shape_func_2d_lag.f90 b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_2d_lag.f90 new file mode 100644 index 00000000..b5e47865 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_2d_lag.f90 @@ -0,0 +1,118 @@ +! +! module shape_func_2d_lag +! +! Written by H. Matsui on June. 2006 +! +! subroutine shape_function_an_sf27(an_27, xi, ei, & +! & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre) +! subroutine shape_function_dnxi_sf27(dnxi, xi, ei, & +! & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, & +! & dxi) +! subroutine shape_function_dnei_sf27(dnei, xi, ei, & +! & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, & +! & dei) +! +! xi, ei: \xi, \eta +! xi_nega: 1 - \xi +! xi_posi: 1 + \xi +! xi_sqre: 1 - \xi +! + module shape_func_2d_lag +! + use m_precision + use m_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine shape_function_an_sf27(an_27, xi, ei, & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre) +! + real (kind=kreal), intent(inout) :: an_27(9) +! + real (kind=kreal), intent(in) :: xi, ei + real (kind=kreal), intent(in) :: xi_nega, ei_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre +! +! + an_27(1) = quad * xi_nega * ei_nega * xi * ei + an_27(2) = quad * xi_posi * ei_nega * xi * ei + an_27(3) = quad * xi_posi * ei_posi * xi * ei + an_27(4) = quad * xi_nega * ei_posi * xi * ei +! + an_27(5) = half * xi_sqre * ei_nega * ei + an_27(6) = half * xi_posi * ei_sqre * xi + an_27(7) = half * xi_sqre * ei_posi * ei + an_27(8) = half * xi_nega * ei_sqre * xi +! + an_27(9) = xi_sqre * ei_sqre +! + end subroutine shape_function_an_sf27 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnxi_sf27(dnxi, xi, ei, & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, & + & dxi) +! + real (kind=kreal), intent(inout) :: dnxi(9) +! + real (kind=kreal), intent(in) :: xi, ei + real (kind=kreal), intent(in) :: xi_nega, ei_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre + real (kind=kreal), intent(in) :: dxi +! +! + dnxi(1) = quad * (xi_nega -xi) * ei_nega * ei * dxi + dnxi(2) = quad * (xi_posi +xi) * ei_nega * ei * dxi + dnxi(3) = quad * (xi_posi +xi) * ei_posi * ei * dxi + dnxi(4) = quad * (xi_nega -xi) * ei_posi * ei * dxi +! + dnxi(5) = - xi * ei_nega * ei * dxi + dnxi(6) = half * (xi_posi +xi) * ei_sqre * dxi + dnxi(7) = - xi * ei_posi * ei * dxi + dnxi(8) = half * (xi_nega -xi) * ei_sqre * dxi +! + dnxi(9) = - two * xi * ei_sqre * dxi +! + end subroutine shape_function_dnxi_sf27 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnei_sf27(dnei, xi, ei, & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, & + & dei) +! + real (kind=kreal), intent(inout) :: dnei(9) +! + real (kind=kreal), intent(in) :: xi, ei + real (kind=kreal), intent(in) :: xi_nega, ei_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre + real (kind=kreal), intent(in) :: dei +! +! + dnei(1) = quad * xi_nega * (ei_nega -ei) * xi * dei + dnei(2) = quad * xi_posi * (ei_nega -ei) * xi * dei + dnei(3) = quad * xi_posi * (ei_posi +ei) * xi * dei + dnei(4) = quad * xi_nega * (ei_posi +ei) * xi * dei +! + dnei(5) = half * xi_sqre * (ei_nega -ei) * dei + dnei(6) = - xi_posi * ei * xi * dei + dnei(7) = half * xi_sqre * (ei_posi +ei) * dei + dnei(8) = - xi_nega * ei * xi * dei +! + dnei(9) = -two *xi_sqre * ei * dei +! + end subroutine shape_function_dnei_sf27 +! +!----------------------------------------------------------------------- +! + end module shape_func_2d_lag diff --git a/src/Fortran_libraries/UTILS_src/jacobian/shape_func_2d_linear.f90 b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_2d_linear.f90 new file mode 100644 index 00000000..bc8c30a6 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_2d_linear.f90 @@ -0,0 +1,77 @@ +! +! module shape_func_2d_linear +! +! Written by H. Matsui on Sep. 2005 +! +! subroutine shape_function_an_sf_1(an_1, xi_nega, ei_nega, & +! & xi_posi, ei_posi) +! subroutine shape_function_dnxi_sf_1(dnxi, ei_nega, ei_posi, dxi) +! subroutine shape_function_dnei_sf_1(dnei, xi_nega, xi_posi, dei) +! + module shape_func_2d_linear +! + use m_precision + use m_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine shape_function_an_sf_1(an_1, xi_nega, ei_nega, & + & xi_posi, ei_posi) +! + real (kind=kreal), intent(inout) :: an_1(4) +! + real (kind=kreal), intent(in) :: xi_nega, xi_posi + real (kind=kreal), intent(in) :: ei_nega, ei_posi +! +! + an_1(1) = quad * xi_nega * ei_nega + an_1(2) = quad * xi_posi * ei_nega + an_1(3) = quad * xi_posi * ei_posi + an_1(4) = quad * xi_nega * ei_posi +! +! + end subroutine shape_function_an_sf_1 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnxi_sf_1(dnxi, ei_nega, ei_posi, dxi) +! + real (kind=kreal), intent(inout) :: dnxi(4) +! + real (kind=kreal), intent(in) :: ei_nega, ei_posi + real (kind=kreal), intent(in) :: dxi +! +! + dnxi(1) = -quad * ei_nega * dxi + dnxi(2) = quad * ei_nega * dxi + dnxi(3) = quad * ei_posi * dxi + dnxi(4) = -quad * ei_posi * dxi +! + end subroutine shape_function_dnxi_sf_1 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnei_sf_1(dnei, xi_nega, xi_posi, dei) +! + real (kind=kreal), intent(inout) :: dnei(4) +! + real (kind=kreal), intent(in) :: xi_nega, xi_posi + real (kind=kreal), intent(in) :: dei +! +! + dnei(1) = -quad * xi_nega * dei + dnei(2) = -quad * xi_posi * dei + dnei(3) = quad * xi_posi * dei + dnei(4) = quad * xi_nega * dei +! + end subroutine shape_function_dnei_sf_1 +! +!----------------------------------------------------------------------- +! + end module shape_func_2d_linear diff --git a/src/Fortran_libraries/UTILS_src/jacobian/shape_func_2d_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_2d_quad.f90 new file mode 100644 index 00000000..1e10db27 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_2d_quad.f90 @@ -0,0 +1,107 @@ +! +! module shape_func_2d_quad +! +! Written by H. Matsui on Sep. 2005 +! +! subroutine shape_function_an_sf20(an_20, xi, ei, & +! & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre) +! subroutine shape_function_dnxi_sf20(dnxi, xi, ei, & +! & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, & +! & dxi) +! subroutine shape_function_dnei_sf20(dnei, xi, ei, & +! & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, & +! & dei) +! + module shape_func_2d_quad +! + use m_precision + use m_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine shape_function_an_sf20(an_20, xi, ei, & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre) +! + real (kind=kreal), intent(inout) :: an_20(8) +! + real (kind=kreal), intent(in) :: xi, ei + real (kind=kreal), intent(in) :: xi_nega, ei_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre +! +! + an_20(1) = quad * xi_nega * ei_nega * (-xi-ei-one) + an_20(2) = quad * xi_posi * ei_nega * ( xi-ei-one) + an_20(3) = quad * xi_posi * ei_posi * ( xi+ei-one) + an_20(4) = quad * xi_nega * ei_posi * (-xi+ei-one) +! + an_20(5) = half * xi_sqre * ei_nega + an_20(6) = half * xi_posi * ei_sqre + an_20(7) = half * xi_sqre * ei_posi + an_20(8) = half * xi_nega * ei_sqre +! + end subroutine shape_function_an_sf20 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnxi_sf20(dnxi, xi, ei, & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, & + & dxi) +! + real (kind=kreal), intent(inout) :: dnxi(8) +! + real (kind=kreal), intent(in) :: xi, ei + real (kind=kreal), intent(in) :: xi_nega, ei_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre + real (kind=kreal), intent(in) :: dxi +! +! + dnxi(1) = -quad * (-two*xi-ei) * ei_nega * dxi + dnxi(2) = quad * ( two*xi-ei) * ei_nega * dxi + dnxi(3) = quad * ( two*xi+ei) * ei_posi * dxi + dnxi(4) = -quad * (-two*xi+ei) * ei_posi * dxi +! + dnxi(5) = - xi * ei_nega * dxi + dnxi(6) = half * ei_sqre * dxi + dnxi(7) = - xi * ei_posi * dxi + dnxi(8) = -half * ei_sqre * dxi +! + end subroutine shape_function_dnxi_sf20 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnei_sf20(dnei, xi, ei, & + & xi_nega, ei_nega, xi_posi, ei_posi, xi_sqre, ei_sqre, & + & dei) +! + real (kind=kreal), intent(inout) :: dnei(8) +! + real (kind=kreal), intent(in) :: xi, ei + real (kind=kreal), intent(in) :: xi_nega, ei_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre + real (kind=kreal), intent(in) :: dei +! +! + dnei(1) = -quad * xi_nega * (-xi-two*ei) * dei + dnei(2) = -quad * xi_posi * ( xi-two*ei) * dei + dnei(3) = quad * xi_posi * ( xi+two*ei) * dei + dnei(4) = quad * xi_nega * (-xi+two*ei) * dei +! + dnei(5) = - half * xi_sqre * dei + dnei(6) = - xi_posi * ei * dei + dnei(7) = half * xi_sqre * dei + dnei(8) = - xi_nega * ei * dei +! + end subroutine shape_function_dnei_sf20 +! +!----------------------------------------------------------------------- +! + end module shape_func_2d_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/shape_func_3d_lag.f90 b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_3d_lag.f90 new file mode 100644 index 00000000..4cb188ff --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_3d_lag.f90 @@ -0,0 +1,237 @@ +! +! module shape_func_3d_lag +! +! Written by H. Matsui on June. 2006 +! +! subroutine shape_function_an_27(an_27, xi, ei, zi, & +! & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & +! & xi_sqre, ei_sqre, zi_sqre) +! subroutine shape_function_dnxi_27(dnxi, xi, ei, zi, & +! & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & +! & xi_sqre, ei_sqre, zi_sqre, dxi) +! subroutine shape_function_dnei_27(dnei, xi, ei, zi, & +! & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & +! & xi_sqre, ei_sqre, zi_sqre, dei) +! subroutine shape_function_dnzi_27(dnzi, xi, ei, zi, & +! & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & +! & xi_sqre, ei_sqre, zi_sqre, dzi) +! +! xi, ei, zi: \xi, \eta, \zeta +! xi_nega: 1 - \xi +! xi_posi: 1 + \xi +! xi_sqre: 1 - \xi +! + module shape_func_3d_lag +! + use m_precision + use m_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine shape_function_an_27(an_27, xi, ei, zi, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre) +! + real (kind=kreal), intent(inout) :: an_27(27) +! + real (kind=kreal), intent(in) :: xi, ei, zi + real (kind=kreal), intent(in) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi, zi_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre, zi_sqre +! +! + an_27(1) = r125 * xi_nega * ei_nega * zi_nega * xi * ei * zi + an_27(2) = r125 * xi_posi * ei_nega * zi_nega * xi * ei * zi + an_27(3) = r125 * xi_posi * ei_posi * zi_nega * xi * ei * zi + an_27(4) = r125 * xi_nega * ei_posi * zi_nega * xi * ei * zi + an_27(5) = r125 * xi_nega * ei_nega * zi_posi * xi * ei * zi + an_27(6) = r125 * xi_posi * ei_nega * zi_posi * xi * ei * zi + an_27(7) = r125 * xi_posi * ei_posi * zi_posi * xi * ei * zi + an_27(8) = r125 * xi_nega * ei_posi * zi_posi * xi * ei * zi +! + an_27(9) = quad * xi_sqre * ei_nega * zi_nega * ei * zi + an_27(10) = quad * xi_posi * ei_sqre * zi_nega * xi * zi + an_27(11) = quad * xi_sqre * ei_posi * zi_nega * ei * zi + an_27(12) = quad * xi_nega * ei_sqre * zi_nega * xi * zi +! + an_27(13) = quad * xi_sqre * ei_nega * zi_posi * ei * zi + an_27(14) = quad * xi_posi * ei_sqre * zi_posi * xi * zi + an_27(15) = quad * xi_sqre * ei_posi * zi_posi * ei * zi + an_27(16) = quad * xi_nega * ei_sqre * zi_posi * xi * zi +! + an_27(17) = quad * xi_nega * ei_nega * zi_sqre * xi * ei + an_27(18) = quad * xi_posi * ei_nega * zi_sqre * xi * ei + an_27(19) = quad * xi_posi * ei_posi * zi_sqre * xi * ei + an_27(20) = quad * xi_nega * ei_posi * zi_sqre * xi * ei +! + an_27(21) = half * xi_nega * ei_sqre * zi_sqre * xi + an_27(22) = half * xi_posi * ei_sqre * zi_sqre * xi + an_27(23) = half * xi_sqre * ei_nega * zi_sqre * ei + an_27(24) = half * xi_sqre * ei_posi * zi_sqre * ei + an_27(25) = half * xi_sqre * ei_sqre * zi_nega * zi + an_27(26) = half * xi_sqre * ei_sqre * zi_posi * zi +! + an_27(27) = xi_sqre * ei_sqre * zi_sqre +! + end subroutine shape_function_an_27 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnxi_27(dnxi, xi, ei, zi, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, dxi) +! + real (kind=kreal), dimension(27) :: dnxi +! + real (kind=kreal), intent(in) :: xi, ei, zi + real (kind=kreal), intent(in) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi, zi_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre, zi_sqre + real (kind=kreal), intent(in) :: dxi +! +! + dnxi(1) = r125 * (xi_nega -xi) * ei_nega * zi_nega * ei*zi * dxi + dnxi(2) = r125 * (xi_posi +xi) * ei_nega * zi_nega * ei*zi * dxi + dnxi(3) = r125 * (xi_posi +xi) * ei_posi * zi_nega * ei*zi * dxi + dnxi(4) = r125 * (xi_nega -xi) * ei_posi * zi_nega * ei*zi * dxi + dnxi(5) = r125 * (xi_nega -xi) * ei_nega * zi_posi * ei*zi * dxi + dnxi(6) = r125 * (xi_posi +xi) * ei_nega * zi_posi * ei*zi * dxi + dnxi(7) = r125 * (xi_posi +xi) * ei_posi * zi_posi * ei*zi * dxi + dnxi(8) = r125 * (xi_nega -xi) * ei_posi * zi_posi * ei*zi * dxi +! + dnxi(9) =-half * xi * ei_nega * zi_nega * ei*zi * dxi + dnxi(10) = quad * (xi_posi +xi) * ei_sqre * zi_nega * zi * dxi + dnxi(11) =-half * xi * ei_posi * zi_nega * ei*zi * dxi + dnxi(12) = quad * (xi_nega -xi) * ei_sqre * zi_nega * zi * dxi +! + dnxi(13) =-half * xi * ei_nega * zi_posi * ei*zi * dxi + dnxi(14) = quad * (xi_posi +xi) * ei_sqre * zi_posi * zi * dxi + dnxi(15) =-half * xi * ei_posi * zi_posi * ei*zi * dxi + dnxi(16) = quad * (xi_nega -xi) * ei_sqre * zi_posi * zi * dxi +! + dnxi(17) = quad * (xi_nega -xi) * ei_nega * zi_sqre * ei * dxi + dnxi(18) = quad * (xi_posi +xi) * ei_nega * zi_sqre * ei * dxi + dnxi(19) = quad * (xi_posi +xi) * ei_posi * zi_sqre * ei * dxi + dnxi(20) = quad * (xi_nega -xi) * ei_posi * zi_sqre * ei * dxi +! + dnxi(21) = half * (xi_nega -xi) * ei_sqre * zi_sqre * dxi + dnxi(22) = half * (xi_posi +xi) * ei_sqre * zi_sqre * dxi + dnxi(23) = - xi * ei_nega * zi_sqre * ei * dxi + dnxi(24) = - xi * ei_posi * zi_sqre * ei * dxi + dnxi(25) = - xi * ei_sqre * zi_nega * zi * dxi + dnxi(26) = - xi * ei_sqre * zi_posi * zi * dxi +! + dnxi(27) = -two * xi * ei_sqre * zi_sqre * dxi +! + end subroutine shape_function_dnxi_27 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnei_27(dnei, xi, ei, zi, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, dei) +! + real (kind=kreal), intent(inout) :: dnei(27) +! + real (kind=kreal), intent(in) :: xi, ei, zi + real (kind=kreal), intent(in) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi, zi_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre, zi_sqre + real (kind=kreal), intent(in) :: dei +! +! + dnei(1) = r125 * xi_nega * (ei_nega -ei) * zi_nega * xi*zi * dei + dnei(2) = r125 * xi_posi * (ei_nega -ei) * zi_nega * xi*zi * dei + dnei(3) = r125 * xi_posi * (ei_posi +ei) * zi_nega * xi*zi * dei + dnei(4) = r125 * xi_nega * (ei_posi +ei) * zi_nega * xi*zi * dei + dnei(5) = r125 * xi_nega * (ei_nega -ei) * zi_posi * xi*zi * dei + dnei(6) = r125 * xi_posi * (ei_nega -ei) * zi_posi * xi*zi * dei + dnei(7) = r125 * xi_posi * (ei_posi +ei) * zi_posi * xi*zi * dei + dnei(8) = r125 * xi_nega * (ei_posi +ei) * zi_posi * xi*zi * dei +! + dnei(9) = quad * xi_sqre * (ei_nega -ei) * zi_nega * zi * dei + dnei(10) =-half * xi_posi * ei * zi_nega * xi*zi * dei + dnei(11) = quad * xi_sqre * (ei_posi +ei) * zi_nega * zi * dei + dnei(12) =-half * xi_nega * ei * zi_nega * xi*zi * dei +! + dnei(13) = quad * xi_sqre * (ei_nega -ei) * zi_posi * zi * dei + dnei(14) =-half * xi_posi * ei * zi_posi * xi*zi * dei + dnei(15) = quad * xi_sqre * (ei_posi +ei) * zi_posi * zi * dei + dnei(16) =-half * xi_nega * ei * zi_posi * xi*zi * dei +! + dnei(17) = quad * xi_nega * (ei_nega -ei) * zi_sqre * xi * dei + dnei(18) = quad * xi_posi * (ei_nega -ei) * zi_sqre * xi * dei + dnei(19) = quad * xi_posi * (ei_posi +ei) * zi_sqre * xi * dei + dnei(20) = quad * xi_nega * (ei_posi +ei) * zi_sqre * xi * dei +! + dnei(21) = - xi_nega * ei * zi_sqre * xi * dei + dnei(22) = - xi_posi * ei * zi_sqre * xi * dei + dnei(23) = half * xi_sqre * (ei_nega -ei) * zi_sqre * dei + dnei(24) = half * xi_sqre * (ei_posi +ei) * zi_sqre * dei + dnei(25) = - xi_sqre * ei * zi_nega * zi * dei + dnei(26) = - xi_sqre * ei * zi_posi * zi * dei +! + dnei(27) = -two * xi_sqre * ei * zi_sqre * dei +! + end subroutine shape_function_dnei_27 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnzi_27(dnzi, xi, ei, zi, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, dzi) +! + real (kind=kreal), intent(inout) :: dnzi(27) +! + real (kind=kreal), intent(in) :: xi, ei, zi + real (kind=kreal), intent(in) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi, zi_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre, zi_sqre + real (kind=kreal), intent(in) :: dzi +! +! + dnzi(1) = r125 * xi_nega * ei_nega * (zi_nega -zi) * xi*ei * dzi + dnzi(2) = r125 * xi_posi * ei_nega * (zi_nega -zi) * xi*ei * dzi + dnzi(3) = r125 * xi_posi * ei_posi * (zi_nega -zi) * xi*ei * dzi + dnzi(4) = r125 * xi_nega * ei_posi * (zi_nega -zi) * xi*ei * dzi + dnzi(5) = r125 * xi_nega * ei_nega * (zi_posi +zi) * xi*ei * dzi + dnzi(6) = r125 * xi_posi * ei_nega * (zi_posi +zi) * xi*ei * dzi + dnzi(7) = r125 * xi_posi * ei_posi * (zi_posi +zi) * xi*ei * dzi + dnzi(8) = r125 * xi_nega * ei_posi * (zi_posi +zi) * xi*ei * dzi +! + dnzi(9) = quad * xi_sqre * ei_nega * (zi_nega -zi) * ei * dzi + dnzi(10) = quad * xi_posi * ei_sqre * (zi_nega -zi) * xi * dzi + dnzi(11) = quad * xi_sqre * ei_posi * (zi_nega -zi) * ei * dzi + dnzi(12) = quad * xi_nega * ei_sqre * (zi_nega -zi) * xi * dzi +! + dnzi(13) = quad * xi_sqre * ei_nega * (zi_posi +zi) * ei * dzi + dnzi(14) = quad * xi_posi * ei_sqre * (zi_posi +zi) * xi * dzi + dnzi(15) = quad * xi_sqre * ei_posi * (zi_posi +zi) * ei * dzi + dnzi(16) = quad * xi_nega * ei_sqre * (zi_posi +zi) * xi * dzi +! + dnzi(17) =-half * xi_nega * ei_nega * zi * xi*ei * dzi + dnzi(18) =-half * xi_posi * ei_nega * zi * xi*ei * dzi + dnzi(19) =-half * xi_posi * ei_posi * zi * xi*ei * dzi + dnzi(20) =-half * xi_nega * ei_posi * zi * xi*ei * dzi +! + dnzi(21) = - xi_nega * ei_sqre * zi * xi * dzi + dnzi(22) = - xi_posi * ei_sqre * zi * xi * dzi + dnzi(23) = - xi_sqre * ei_nega * zi * ei * dzi + dnzi(24) = - xi_sqre * ei_posi * zi * ei * dzi + dnzi(25) = half * xi_sqre * ei_sqre * (zi_nega -zi) * dzi + dnzi(26) = half * xi_sqre * ei_sqre * (zi_posi +zi) * dzi +! + dnzi(27) = -two * xi_sqre * ei_sqre * zi * dzi +! +! + end subroutine shape_function_dnzi_27 +! +!----------------------------------------------------------------------- +! + end module shape_func_3d_lag diff --git a/src/Fortran_libraries/UTILS_src/jacobian/shape_func_3d_linear.f90 b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_3d_linear.f90 new file mode 100644 index 00000000..5e11087e --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_3d_linear.f90 @@ -0,0 +1,119 @@ +! +! module shape_func_3d_linear +! +! Written by H. Matsui on Sep. 2005 +! +! subroutine shape_function_an_1(an_1, & +! & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi) +! subroutine shape_function_dnxi_1(dnxi_1, & +! & ei_nega, zi_nega, ei_posi, zi_posi, dxi) +! subroutine shape_function_dnei_1(dnei_1, & +! & xi_nega, zi_nega, xi_posi, zi_posi, dei) +! subroutine shape_function_dnzi_1(dnzi_1, & +! & xi_nega, ei_nega, xi_posi, ei_posi, dzi) +! + module shape_func_3d_linear +! + use m_precision + use m_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine shape_function_an_1(an_1, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi) +! + real (kind=kreal), intent(inout) :: an_1(8) +! + real (kind=kreal), intent(in) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi, zi_posi +! +! + an_1(1) = r125 * xi_nega * ei_nega * zi_nega + an_1(2) = r125 * xi_posi * ei_nega * zi_nega + an_1(3) = r125 * xi_posi * ei_posi * zi_nega + an_1(4) = r125 * xi_nega * ei_posi * zi_nega + an_1(5) = r125 * xi_nega * ei_nega * zi_posi + an_1(6) = r125 * xi_posi * ei_nega * zi_posi + an_1(7) = r125 * xi_posi * ei_posi * zi_posi + an_1(8) = r125 * xi_nega * ei_posi * zi_posi +! + end subroutine shape_function_an_1 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnxi_1(dnxi_1, & + & ei_nega, zi_nega, ei_posi, zi_posi, dxi) +! + real (kind=kreal), intent(inout) :: dnxi_1(8) +! + real (kind=kreal), intent(in) :: ei_nega, zi_nega + real (kind=kreal), intent(in) :: ei_posi, zi_posi + real (kind=kreal), intent(in) :: dxi +! +! + dnxi_1(1) = -r125 * ei_nega * zi_nega * dxi + dnxi_1(2) = r125 * ei_nega * zi_nega * dxi + dnxi_1(3) = r125 * ei_posi * zi_nega * dxi + dnxi_1(4) = -r125 * ei_posi * zi_nega * dxi + dnxi_1(5) = -r125 * ei_nega * zi_posi * dxi + dnxi_1(6) = r125 * ei_nega * zi_posi * dxi + dnxi_1(7) = r125 * ei_posi * zi_posi * dxi + dnxi_1(8) = -r125 * ei_posi * zi_posi * dxi +! + end subroutine shape_function_dnxi_1 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnei_1(dnei_1, & + & xi_nega, zi_nega, xi_posi, zi_posi, dei) +! + real (kind=kreal), intent(inout):: dnei_1(8) +! + real (kind=kreal), intent(in) :: xi_nega, zi_nega + real (kind=kreal), intent(in) :: xi_posi, zi_posi + real (kind=kreal), intent(in) :: dei +! +! + dnei_1(1) = -r125 * xi_nega * zi_nega * dei + dnei_1(2) = -r125 * xi_posi * zi_nega * dei + dnei_1(3) = r125 * xi_posi * zi_nega * dei + dnei_1(4) = r125 * xi_nega * zi_nega * dei + dnei_1(5) = -r125 * xi_nega * zi_posi * dei + dnei_1(6) = -r125 * xi_posi * zi_posi * dei + dnei_1(7) = r125 * xi_posi * zi_posi * dei + dnei_1(8) = r125 * xi_nega * zi_posi * dei +! + end subroutine shape_function_dnei_1 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnzi_1(dnzi_1, & + & xi_nega, ei_nega, xi_posi, ei_posi, dzi) +! + real (kind=kreal), intent(inout) :: dnzi_1(8) +! + real (kind=kreal), intent(in) :: xi_nega, ei_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi + real (kind=kreal), intent(in) :: dzi +! +! + dnzi_1(1) = -r125 * xi_nega * ei_nega * dzi + dnzi_1(2) = -r125 * xi_posi * ei_nega * dzi + dnzi_1(3) = -r125 * xi_posi * ei_posi * dzi + dnzi_1(4) = -r125 * xi_nega * ei_posi * dzi + dnzi_1(5) = r125 * xi_nega * ei_nega * dzi + dnzi_1(6) = r125 * xi_posi * ei_nega * dzi + dnzi_1(7) = r125 * xi_posi * ei_posi * dzi + dnzi_1(8) = r125 * xi_nega * ei_posi * dzi +! + end subroutine shape_function_dnzi_1 +! +!----------------------------------------------------------------------- +! + end module shape_func_3d_linear diff --git a/src/Fortran_libraries/UTILS_src/jacobian/shape_func_3d_quad.f90 b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_3d_quad.f90 new file mode 100644 index 00000000..95845a87 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_3d_quad.f90 @@ -0,0 +1,200 @@ +! +! module shape_func_3d_quad +! +! Written by H. Matsui on Sep. 2005 +! +! subroutine shape_function_an_20(an_20, xi, ei, zi, & +! & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & +! & xi_sqre, ei_sqre, zi_sqre) +! subroutine shape_function_dnxi_20(dnxi, xi, ei, zi, & +! & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & +! & xi_sqre, ei_sqre, zi_sqre, dxi) +! subroutine shape_function_dnei_20(dnei, xi, ei, zi, & +! & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & +! & xi_sqre, ei_sqre, zi_sqre, dei) +! subroutine shape_function_dnzi_20(dnzi, xi, ei, zi, & +! & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & +! & xi_sqre, ei_sqre, zi_sqre, dzi) +! +! xi, ei, zi: \xi, \eta, \zeta +! xi_nega: 1 - \xi +! xi_posi: 1 + \xi +! xi_sqre: 1 - \xi +! + module shape_func_3d_quad +! + use m_precision + use m_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine shape_function_an_20(an_20, xi, ei, zi, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre) +! + real (kind=kreal), intent(inout) :: an_20(20) +! + real (kind=kreal), intent(in) :: xi, ei, zi + real (kind=kreal), intent(in) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi, zi_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre, zi_sqre +! +! + an_20(1) = -r125 * xi_nega * ei_nega * zi_nega * (two+xi+ei+zi) + an_20(2) = -r125 * xi_posi * ei_nega * zi_nega * (two-xi+ei+zi) + an_20(3) = -r125 * xi_posi * ei_posi * zi_nega * (two-xi-ei+zi) + an_20(4) = -r125 * xi_nega * ei_posi * zi_nega * (two+xi-ei+zi) + an_20(5) = -r125 * xi_nega * ei_nega * zi_posi * (two+xi+ei-zi) + an_20(6) = -r125 * xi_posi * ei_nega * zi_posi * (two-xi+ei-zi) + an_20(7) = -r125 * xi_posi * ei_posi * zi_posi * (two-xi-ei-zi) + an_20(8) = -r125 * xi_nega * ei_posi * zi_posi * (two+xi-ei-zi) +! + an_20(9) = quad * xi_sqre * ei_nega * zi_nega + an_20(10) = quad * xi_posi * ei_sqre * zi_nega + an_20(11) = quad * xi_sqre * ei_posi * zi_nega + an_20(12) = quad * xi_nega * ei_sqre * zi_nega +! + an_20(13) = quad * xi_sqre * ei_nega * zi_posi + an_20(14) = quad * xi_posi * ei_sqre * zi_posi + an_20(15) = quad * xi_sqre * ei_posi * zi_posi + an_20(16) = quad * xi_nega * ei_sqre * zi_posi +! + an_20(17) = quad * xi_nega * ei_nega * zi_sqre + an_20(18) = quad * xi_posi * ei_nega * zi_sqre + an_20(19) = quad * xi_posi * ei_posi * zi_sqre + an_20(20) = quad * xi_nega * ei_posi * zi_sqre +! + end subroutine shape_function_an_20 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnxi_20(dnxi, xi, ei, zi, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, dxi) +! + real (kind=kreal), dimension(20) :: dnxi +! + real (kind=kreal), intent(in) :: xi, ei, zi + real (kind=kreal), intent(in) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi, zi_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre, zi_sqre + real (kind=kreal), intent(in) :: dxi +! +! + dnxi(1) = r125 * (one+two*xi+ei+zi) * ei_nega * zi_nega * dxi + dnxi(2) = -r125 * (one-two*xi+ei+zi) * ei_nega * zi_nega * dxi + dnxi(3) = -r125 * (one-two*xi-ei+zi) * ei_posi * zi_nega * dxi + dnxi(4) = r125 * (one+two*xi-ei+zi) * ei_posi * zi_nega * dxi + dnxi(5) = r125 * (one+two*xi+ei-zi) * ei_nega * zi_posi * dxi + dnxi(6) = -r125 * (one-two*xi+ei-zi) * ei_nega * zi_posi * dxi + dnxi(7) = -r125 * (one-two*xi-ei-zi) * ei_posi * zi_posi * dxi + dnxi(8) = r125 * (one+two*xi-ei-zi) * ei_posi * zi_posi * dxi +! + dnxi(9) = -half * xi * ei_nega * zi_nega * dxi + dnxi(10) = quad * ei_sqre * zi_nega * dxi + dnxi(11) = -half * xi * ei_posi * zi_nega * dxi + dnxi(12) = -quad * ei_sqre * zi_nega * dxi +! + dnxi(13) = -half * xi * ei_nega * zi_posi * dxi + dnxi(14) = quad * ei_sqre * zi_posi * dxi + dnxi(15) = -half * xi * ei_posi * zi_posi * dxi + dnxi(16) = -quad * ei_sqre * zi_posi * dxi +! + dnxi(17) = -quad * ei_nega * zi_sqre * dxi + dnxi(18) = quad * ei_nega * zi_sqre * dxi + dnxi(19) = quad * ei_posi * zi_sqre * dxi + dnxi(20) = -quad * ei_posi * zi_sqre * dxi +! + end subroutine shape_function_dnxi_20 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnei_20(dnei, xi, ei, zi, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, dei) +! + real (kind=kreal), intent(inout) :: dnei(20) +! + real (kind=kreal), intent(in) :: xi, ei, zi + real (kind=kreal), intent(in) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi, zi_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre, zi_sqre + real (kind=kreal), intent(in) :: dei +! +! + dnei(1) = r125 * xi_nega * (one+xi+two*ei+zi) * zi_nega * dei + dnei(2) = r125 * xi_posi * (one-xi+two*ei+zi) * zi_nega * dei + dnei(3) = -r125 * xi_posi * (one-xi-two*ei+zi) * zi_nega * dei + dnei(4) = -r125 * xi_nega * (one+xi-two*ei+zi) * zi_nega * dei + dnei(5) = r125 * xi_nega * (one+xi+two*ei-zi) * zi_posi * dei + dnei(6) = r125 * xi_posi * (one-xi+two*ei-zi) * zi_posi * dei + dnei(7) = -r125 * xi_posi * (one-xi-two*ei-zi) * zi_posi * dei + dnei(8) = -r125 * xi_nega * (one+xi-two*ei-zi) * zi_posi * dei +! + dnei(9) = -quad * xi_sqre * zi_nega * dei + dnei(10) = -half * xi_posi * ei * zi_nega * dei + dnei(11) = quad * xi_sqre * zi_nega * dei + dnei(12) = -half * xi_nega * ei * zi_nega * dei +! + dnei(13) = -quad * xi_sqre * zi_posi * dei + dnei(14) = -half * xi_posi * ei * zi_posi * dei + dnei(15) = quad * xi_sqre * zi_posi * dei + dnei(16) = -half * xi_nega * ei * zi_posi * dei +! + dnei(17) = -quad * xi_nega * zi_sqre * dei + dnei(18) = -quad * xi_posi * zi_sqre * dei + dnei(19) = quad * xi_posi * zi_sqre * dei + dnei(20) = quad * xi_nega * zi_sqre * dei +! + end subroutine shape_function_dnei_20 +! +!----------------------------------------------------------------------- +! + subroutine shape_function_dnzi_20(dnzi, xi, ei, zi, & + & xi_nega, ei_nega, zi_nega, xi_posi, ei_posi, zi_posi, & + & xi_sqre, ei_sqre, zi_sqre, dzi) +! + real (kind=kreal), intent(inout) :: dnzi(20) +! + real (kind=kreal), intent(in) :: xi, ei, zi + real (kind=kreal), intent(in) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(in) :: xi_posi, ei_posi, zi_posi + real (kind=kreal), intent(in) :: xi_sqre, ei_sqre, zi_sqre + real (kind=kreal), intent(in) :: dzi +! +! + dnzi(1) = r125 * xi_nega * ei_nega * (one+xi+ei+two*zi) * dzi + dnzi(2) = r125 * xi_posi * ei_nega * (one-xi+ei+two*zi) * dzi + dnzi(3) = r125 * xi_posi * ei_posi * (one-xi-ei+two*zi) * dzi + dnzi(4) = r125 * xi_nega * ei_posi * (one+xi-ei+two*zi) * dzi + dnzi(5) = -r125 * xi_nega * ei_nega * (one+xi+ei-two*zi) * dzi + dnzi(6) = -r125 * xi_posi * ei_nega * (one-xi+ei-two*zi) * dzi + dnzi(7) = -r125 * xi_posi * ei_posi * (one-xi-ei-two*zi) * dzi + dnzi(8) = -r125 * xi_nega * ei_posi * (one+xi-ei-two*zi) * dzi +! + dnzi(9) = -quad * xi_sqre * ei_nega * dzi + dnzi(10) = -quad * xi_posi * ei_sqre * dzi + dnzi(11) = -quad * xi_sqre * ei_posi * dzi + dnzi(12) = -quad * xi_nega * ei_sqre * dzi +! + dnzi(13) = quad * xi_sqre * ei_nega * dzi + dnzi(14) = quad * xi_posi * ei_sqre * dzi + dnzi(15) = quad * xi_sqre * ei_posi * dzi + dnzi(16) = quad * xi_nega * ei_sqre * dzi +! + dnzi(17) = -half * xi_nega * ei_nega * zi * dzi + dnzi(18) = -half * xi_posi * ei_nega * zi * dzi + dnzi(19) = -half * xi_posi * ei_posi * zi * dzi + dnzi(20) = -half * xi_nega * ei_posi * zi * dzi +! + end subroutine shape_function_dnzi_20 +! +!----------------------------------------------------------------------- +! + end module shape_func_3d_quad diff --git a/src/Fortran_libraries/UTILS_src/jacobian/shape_func_elements.f90 b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_elements.f90 new file mode 100644 index 00000000..8927f5bc --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_elements.f90 @@ -0,0 +1,76 @@ +! +! module shape_func_elements +! +! modified by H. Matsui on Aug., 2006 +! +! subroutine s_shape_elenents_aw_3d(xi_nega, ei_nega, zi_nega, & +! & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & +! & xi, ei, zi) +! +! subroutine s_shape_elenents_aw_2d(xi_nega, ei_nega, & +! & xi_posi, ei_posi, xi_sqre, ei_sqre, xi, ei) +! +! subroutine s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi) +! + module shape_func_elements +! + use m_precision + use m_constants +! + implicit none +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_shape_elenents_aw_3d(xi_nega, ei_nega, zi_nega, & + & xi_posi, ei_posi, zi_posi, xi_sqre, ei_sqre, zi_sqre, & + & xi, ei, zi) +! + real (kind=kreal), intent(in) :: xi, ei, zi + real (kind=kreal), intent(inout) :: xi_nega, ei_nega, zi_nega + real (kind=kreal), intent(inout) :: xi_posi, ei_posi, zi_posi + real (kind=kreal), intent(inout) :: xi_sqre, ei_sqre, zi_sqre +! + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi) + call s_shape_elenents_aw_1d(ei_nega, ei_posi, ei_sqre, ei) + call s_shape_elenents_aw_1d(zi_nega, zi_posi, zi_sqre, zi) +! + end subroutine s_shape_elenents_aw_3d +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine s_shape_elenents_aw_2d(xi_nega, ei_nega, & + & xi_posi, ei_posi, xi_sqre, ei_sqre, xi, ei) +! + real (kind=kreal), intent(in) :: xi, ei + real (kind=kreal), intent(inout) :: xi_nega, ei_nega + real (kind=kreal), intent(inout) :: xi_posi, ei_posi + real (kind=kreal), intent(inout) :: xi_sqre, ei_sqre +! + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi) + call s_shape_elenents_aw_1d(ei_nega, ei_posi, ei_sqre, ei) +! + end subroutine s_shape_elenents_aw_2d +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi) +! + real(kind = kreal), intent(in) :: xi + real(kind = kreal), intent(inout) :: xi_nega, xi_posi, xi_sqre +! +! + xi_nega = one - xi + xi_posi = one + xi + xi_sqre = one - xi * xi +! + end subroutine s_shape_elenents_aw_1d +! +!----------------------------------------------------------------------- +! + end module shape_func_elements diff --git a/src/Fortran_libraries/UTILS_src/jacobian/shape_func_infty_elements.f90 b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_infty_elements.f90 new file mode 100644 index 00000000..3ce37722 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/shape_func_infty_elements.f90 @@ -0,0 +1,93 @@ +! +! module shape_func_infty_elements +! +! modified by H. Matsui on Aug., 2006 +! +! subroutine s_shape_elenents_aw_inf_odd_1d(xi_inf, dxi_inf, & +! & xi_nega, xi_posi, xi_sqre, xi, xk) +! subroutine s_shape_elenents_aw_inf_even_1d(xi_inf, dxi_inf, & +! & xi_nega, xi_posi, xi_sqre, xi, xk) +! + module shape_func_infty_elements +! + use m_precision + use m_constants +! + implicit none +! + private :: s_trans_xi_4_inf_odd, s_trans_xi_4_inf_even +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_shape_elenents_aw_inf_odd_1d(xi_inf, dxi_inf, & + & xi_nega, xi_posi, xi_sqre, xi, xk) +! + use shape_func_elements +! + real(kind = kreal), intent(in) :: xi, xk + real(kind = kreal), intent(inout) :: xi_inf, dxi_inf + real(kind = kreal), intent(inout) :: xi_nega, xi_posi, xi_sqre +! +! + call s_trans_xi_4_inf_odd(xi_inf, dxi_inf, xi, xk) +! + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi_inf) +! + end subroutine s_shape_elenents_aw_inf_odd_1d +! +!----------------------------------------------------------------------- +! + subroutine s_shape_elenents_aw_inf_even_1d(xi_inf, dxi_inf, & + & xi_nega, xi_posi, xi_sqre, xi, xk) +! + use shape_func_elements +! + real(kind = kreal), intent(in) :: xi, xk + real(kind = kreal), intent(inout) :: xi_inf, dxi_inf + real(kind = kreal), intent(inout) :: xi_nega, xi_posi, xi_sqre +! +! + call s_trans_xi_4_inf_even(xi_inf, dxi_inf, xi, xk) +! + call s_shape_elenents_aw_1d(xi_nega, xi_posi, xi_sqre, xi_inf) +! + end subroutine s_shape_elenents_aw_inf_even_1d +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine s_trans_xi_4_inf_odd(xi_inf, dxi_inf, xi, xk) +! + real(kind = kreal), intent(in) :: xi, xk + real(kind = kreal), intent(inout) :: xi_inf, dxi_inf +! +! + xi_inf = one - (two**(xk+one) / (two**xk - 1)) & + & * (one - one / (one + xi)**xk ) + dxi_inf = (two**(xk+one) / (xk*(two**xk - 1)) ) & + & * (one / (one + xi)**xk ) +! + end subroutine s_trans_xi_4_inf_odd +! +!----------------------------------------------------------------------- +! + subroutine s_trans_xi_4_inf_even(xi_inf, dxi_inf, xi, xk) +! + real(kind = kreal), intent(in) :: xi, xk + real(kind = kreal), intent(inout) :: xi_inf, dxi_inf +! +! + xi_inf = one - (two**(xk+one) / (two**xk - 1)) & + & * (one - one / (one - xi)**xk ) + dxi_inf =-(two**(xk+one) / (xk*(two**xk - 1)) ) & + & * (one / (one - xi)**xk ) +! + end subroutine s_trans_xi_4_inf_even +! +!----------------------------------------------------------------------- +! + end module shape_func_infty_elements diff --git a/src/Fortran_libraries/UTILS_src/jacobian/sum_normal_4_surf_group.f90 b/src/Fortran_libraries/UTILS_src/jacobian/sum_normal_4_surf_group.f90 new file mode 100644 index 00000000..ff39433d --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/sum_normal_4_surf_group.f90 @@ -0,0 +1,128 @@ +!>@file sum_normal_4_surf_group.f90 +!! module sum_normal_4_surf_group +!! +!!@author H. Matsui +!!@date Programmed in Aug, 2006 +!! modified in June, 2007 +!! modified in Jan., 2009 +!>@brief Get size of area for each surface group +!! +!!@verbatim +!! subroutine s_sum_normal_4_surf_group(ele, sf_grp, sf_grp_v) +!! type(element_data), intent(in) :: ele +!! type(surface_group_data), intent(in) :: sf_grp +!! type(surface_group_normals), intent(inout) :: sf_grp_v +!!@endverbatim +! + module sum_normal_4_surf_group +! + use m_precision +! + implicit none +! + private :: sum_norm_of_surf_group +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine s_sum_normal_4_surf_group(ele, sf_grp, sf_grp_v) +! + use calypso_mpi + use calypso_mpi_real +! + use m_machine_parameter + use t_geometry_data + use t_group_data + use t_surface_group_normals + use transfer_to_long_integers +! + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: sf_grp + type(surface_group_normals), intent(inout) :: sf_grp_v +! + integer(kind = kint) :: i + real(kind= kreal), allocatable :: sum_sf_grp_l(:) +! +! + allocate(sum_sf_grp_l(sf_grp%num_grp)) + sum_sf_grp_l(1:sf_grp%num_grp) = 0.0d0 +! + call sum_norm_of_surf_group & + & (np_smp, ele%numele, ele%interior_ele, & + & sf_grp%num_grp, sf_grp%num_item, sf_grp%item_sf_grp, & + & sf_grp%num_grp_smp, sf_grp%istack_grp_smp, & + & sf_grp_v%area_sf_grp, sum_sf_grp_l) +! + call calypso_mpi_allreduce_real & + & (sum_sf_grp_l, sf_grp_v%tot_area_sf_grp, & + & cast_long(sf_grp%num_grp), MPI_SUM) + deallocate(sum_sf_grp_l) +! + if (my_rank.eq.0) then + do i = 1, sf_grp%num_grp + write(*,*) i, trim(sf_grp%grp_name(i)), & + & sf_grp_v%tot_area_sf_grp(i) + end do + end if +! + end subroutine s_sum_normal_4_surf_group +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine sum_norm_of_surf_group(np_smp, numele, interior_ele, & + & num_surf, num_surf_bc, surf_item, num_surf_smp, & + & isurf_grp_smp_stack, area_sf_grp, sum_sf_grp) +! + use calypso_mpi +! + integer(kind = kint) , intent(in) :: numele + integer (kind = kint), intent(in) :: interior_ele(numele) + integer(kind = kint), intent(in) :: np_smp, num_surf_smp + integer(kind = kint), intent(in) & + & :: isurf_grp_smp_stack(0:num_surf_smp) + integer(kind = kint), intent(in) :: num_surf, num_surf_bc + integer(kind = kint), intent(in) :: surf_item(2,num_surf_bc) + real(kind = kreal), intent(in) :: area_sf_grp(num_surf_bc) +! + real(kind= kreal), intent(inout) :: sum_sf_grp(num_surf) +! + integer(kind = kint) :: i_grp, ip, i, ist, ied, isurf, iele + real(kind= kreal), allocatable :: area_grp_smp(:) +! +! +! +!$omp parallel workshare + sum_sf_grp(1:num_surf) = 0.0d0 +!$omp end parallel workshare +! + allocate(area_grp_smp(np_smp)) +! + do i_grp = 1, num_surf +!$omp parallel do private(ist,ied,isurf,iele) + do ip = 1, np_smp + i = (i_grp-1)*np_smp + ip + ist = isurf_grp_smp_stack(i-1) + 1 + ied = isurf_grp_smp_stack(i) +! + area_grp_smp(ip) = 0.0d0 + do isurf = ist, ied + iele = surf_item(1,isurf) + area_grp_smp(ip) = area_grp_smp(ip) + area_sf_grp(isurf) & + & * dble(interior_ele(iele)) + end do + end do +!$omp end parallel do +! + sum_sf_grp(i_grp) = sum(area_grp_smp) + end do + deallocate(area_grp_smp) +! + end subroutine sum_norm_of_surf_group +! +! ---------------------------------------------------------------------- +! + end module sum_normal_4_surf_group diff --git a/src/Fortran_libraries/UTILS_src/jacobian/sum_volume_of_domain.f90 b/src/Fortran_libraries/UTILS_src/jacobian/sum_volume_of_domain.f90 new file mode 100644 index 00000000..0737cda4 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/sum_volume_of_domain.f90 @@ -0,0 +1,141 @@ +!>@file sum_volume_of_domain.f90 +!! module sum_volume_of_domain +!! +!!@author H. Matsui and H.Okuda +!!@date programmed by H.Matsui and H.Okuda +!!@n in July 2000 (ver 1.1) +!!@n Modified by H. Matsui in Aug., 2006 +!! +!> @brief get local volume size for internal subdomain +!! +!!@verbatim +!! subroutine allocate_volume_4_smp +!! subroutine deallocate_volume_4_smp +!! +!! subroutine sum_4_volume(numele, interior_ele, iele_fsmp_stack, & +!! & volume_ele, vol_local) +!! subroutine sum_of_volume_by_ele_table(numele, interior_ele, & +!! & volume_ele, numele_field, iele_fsmp_stack, & +!! & iele_field, vol_local) +!!@endverbatim +! + module sum_volume_of_domain +! + use m_precision +! + use m_machine_parameter +! + implicit none +! + real(kind=kreal), allocatable :: xvol_smp(:) + private :: xvol_smp +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine allocate_volume_4_smp +! + allocate ( xvol_smp(np_smp) ) + xvol_smp = 0.0d0 +! + end subroutine allocate_volume_4_smp +! +!----------------------------------------------------------------------- +! + subroutine deallocate_volume_4_smp +! + deallocate ( xvol_smp ) +! + end subroutine deallocate_volume_4_smp +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine sum_4_volume(numele, interior_ele, iele_fsmp_stack, & + & volume_ele, vol_local) +! + integer (kind = kint), intent(in) :: numele + integer (kind = kint), intent(in) :: interior_ele(numele) + integer (kind=kint), intent(in) :: iele_fsmp_stack(0:np_smp) + real (kind=kreal), intent(in) :: volume_ele(numele) +! + real (kind=kreal), intent(inout) :: vol_local +! + integer (kind=kint) :: iproc, iele + integer (kind=kint) :: istart, iend +! +! + vol_local = 0.0d0 + xvol_smp = 0.0d0 +! +!$omp parallel do private(iele,istart,iend) + do iproc = 1, np_smp + istart = iele_fsmp_stack(iproc-1)+1 + iend = iele_fsmp_stack(iproc) + do iele = istart, iend +! + xvol_smp(iproc) = xvol_smp(iproc) & + & + volume_ele(iele)*dble(interior_ele(iele)) +! + end do + end do +!$omp end parallel do +! +!cdir noconcur + do iproc = 1, np_smp + vol_local = vol_local + xvol_smp(iproc) + end do +! + end subroutine sum_4_volume +! +!----------------------------------------------------------------------- +! + subroutine sum_of_volume_by_ele_table(numele, interior_ele, & + & volume_ele, numele_field, iele_fsmp_stack, & + & iele_field, vol_local) +! + integer (kind = kint), intent(in) :: numele + integer (kind = kint), intent(in) :: interior_ele(numele) + real (kind=kreal), intent(in) :: volume_ele(numele) +! + integer (kind=kint), intent(in) :: numele_field + integer (kind=kint), intent(in) :: iele_fsmp_stack(0:np_smp) + integer (kind=kint), intent(in) :: iele_field(numele_field) +! + real (kind=kreal), intent(inout) :: vol_local +! + integer (kind=kint) :: iproc, inum, iele + integer (kind=kint) :: istart, iend +! +! + vol_local = 0.0d0 + xvol_smp = 0.0d0 +! +!$omp parallel do private(inum,iele,istart,iend) + do iproc = 1, np_smp + istart = iele_fsmp_stack(iproc-1)+1 + iend = iele_fsmp_stack(iproc) + do inum = istart, iend +! + iele = iele_field(inum) + xvol_smp(iproc) = xvol_smp(iproc) & + & + volume_ele(iele)*dble(interior_ele(iele)) +! + end do + end do +!$omp end parallel do +! +!poption noparallel +!cdir noconcur + do iproc = 1, np_smp + vol_local = vol_local + xvol_smp(iproc) + end do +! + end subroutine sum_of_volume_by_ele_table +! +!----------------------------------------------------------------------- +! + end module sum_volume_of_domain diff --git a/src/Fortran_libraries/UTILS_src/jacobian/t_fem_gauss_int_coefs.f90 b/src/Fortran_libraries/UTILS_src/jacobian/t_fem_gauss_int_coefs.f90 new file mode 100644 index 00000000..e7b5e21d --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/t_fem_gauss_int_coefs.f90 @@ -0,0 +1,182 @@ +!>@file t_fem_gauss_int_coefs.f90 +!! module t_fem_gauss_int_coefs +!! +!!@author H. Matsui +!!@date Programmed on Dec. 2003 +!!@n Modified by H. Matsui on Oct., 2006 +! +!> @brief Structure of gauss points for FEM +!! +!!@verbatim +!! subroutine sel_max_int_point_by_etype(nnod_4_ele, g_FEM) +!! subroutine set_max_integration_points(num_int, g_FEM) +!! subroutine alloc_gauss_coef_4_fem(g_FEM) +!! subroutine alloc_gauss_coef_to_4th(g_FEM) +!! +!! subroutine dealloc_gauss_coef_4_fem(g_FEM) +!! +!! subroutine num_of_int_points(g_FEM) +!! subroutine copy_fem_gauss_int_coefs(org_g_FEM, new_g_FEM) +!!@endverbatim +! + module t_fem_gauss_int_coefs +! + use m_precision + use m_constants +! + implicit none +! + type FEM_gauss_int_coefs + integer(kind=kint) :: max_int_point = 4 + integer(kind=kint) :: maxtot_int_3d= 100 + integer(kind=kint) :: maxtot_int_2d= 30 + integer(kind=kint) :: maxtot_int_1d= 10 +! + integer(kind=kint), allocatable :: int_start1(:) + integer(kind=kint), allocatable :: int_start2(:) + integer(kind=kint), allocatable :: int_start3(:) +! + real(kind = kreal), allocatable :: owe(:) + real(kind = kreal), allocatable :: owe2d(:) + real(kind = kreal), allocatable :: owe3d(:) + end type FEM_gauss_int_coefs +! +!----------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +!> Set maximum number for integration points of FEM +! + subroutine sel_max_int_point_by_etype(nnod_4_ele, g_FEM) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: nnod_4_ele + type(FEM_gauss_int_coefs), intent(inout) :: g_FEM +! +! + if(nnod_4_ele.eq.num_t_quad .or. nnod_4_ele.eq.num_t_lag) then + call set_max_integration_points(ithree, g_FEM) + else if(nnod_4_ele .eq. ione) then + call set_max_integration_points(ione, g_FEM) + else + call set_max_integration_points(itwo, g_FEM) + end if +! + end subroutine sel_max_int_point_by_etype +! +! ---------------------------------------------------------------------- +! + subroutine set_max_integration_points(num_int, g_FEM) +! + type(FEM_gauss_int_coefs), intent(inout) :: g_FEM + integer(kind = kint), intent(in) :: num_int +! + g_FEM%max_int_point = num_int +! + end subroutine set_max_integration_points +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine alloc_gauss_coef_4_fem(g_FEM) +! + type(FEM_gauss_int_coefs), intent(inout) :: g_FEM +! + allocate(g_FEM%owe(g_FEM%maxtot_int_1d) ) + allocate(g_FEM%owe2d(g_FEM%maxtot_int_2d)) + allocate(g_FEM%owe3d(g_FEM%maxtot_int_3d)) +! + allocate(g_FEM%int_start1(g_FEM%max_int_point)) + allocate(g_FEM%int_start2(g_FEM%max_int_point)) + allocate(g_FEM%int_start3(g_FEM%max_int_point)) +! + g_FEM%owe = 0.0d0 + g_FEM%owe2d = 0.0d0 + g_FEM%owe3d = 0.0d0 +! + end subroutine alloc_gauss_coef_4_fem +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine dealloc_gauss_coef_4_fem(g_FEM) +! + type(FEM_gauss_int_coefs), intent(inout) :: g_FEM +! +! + if(allocated(g_FEM%owe) .eqv. .FALSE.) return + deallocate(g_FEM%owe, g_FEM%owe2d, g_FEM%owe3d) + deallocate(g_FEM%int_start1, g_FEM%int_start2, g_FEM%int_start3) +! + end subroutine dealloc_gauss_coef_4_fem +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine num_of_int_points(g_FEM) +! + type(FEM_gauss_int_coefs), intent(inout) :: g_FEM +! + integer(kind = kint) :: n +! +! + g_FEM%maxtot_int_3d = 0 + g_FEM%maxtot_int_2d = 0 + g_FEM%maxtot_int_1d = 0 + do n = 1, g_FEM%max_int_point + g_FEM%maxtot_int_3d = g_FEM%maxtot_int_3d + n*n*n + g_FEM%maxtot_int_2d = g_FEM%maxtot_int_2d + n*n + g_FEM%maxtot_int_1d = g_FEM%maxtot_int_1d + n + end do +! + end subroutine num_of_int_points +! +! ---------------------------------------------------------------------- +! + subroutine set_start_addres_4_FEM_int(g_FEM) +! + type(FEM_gauss_int_coefs), intent(inout) :: g_FEM + integer(kind = kint) :: n +! +! + g_FEM%int_start3(1) = 0 + g_FEM%int_start2(1) = 0 + g_FEM%int_start1(1) = 0 + do n = 2, g_FEM%max_int_point + g_FEM%int_start3(n) = g_FEM%int_start3(n-1) + (n-1)*(n-1)*(n-1) + g_FEM%int_start2(n) = g_FEM%int_start2(n-1) + (n-1)*(n-1) + g_FEM%int_start1(n) = g_FEM%int_start1(n-1) + (n-1) + end do +! + end subroutine set_start_addres_4_FEM_int +! +!----------------------------------------------------------------------- +! + subroutine copy_fem_gauss_int_coefs(org_g_FEM, new_g_FEM) +! + type(FEM_gauss_int_coefs), intent(in) :: org_g_FEM + type(FEM_gauss_int_coefs), intent(inout) :: new_g_FEM +! +! + new_g_FEM%max_int_point = org_g_FEM%max_int_point +! + new_g_FEM%maxtot_int_3d = org_g_FEM%maxtot_int_3d + new_g_FEM%maxtot_int_2d = org_g_FEM%maxtot_int_2d + new_g_FEM%maxtot_int_1d = org_g_FEM%maxtot_int_1d +! + call alloc_gauss_coef_4_fem(new_g_FEM) +! + new_g_FEM%owe(1:new_g_FEM%maxtot_int_1d) = & + & org_g_FEM%owe(1:new_g_FEM%maxtot_int_1d) + new_g_FEM%owe2d(1:new_g_FEM%maxtot_int_2d) = & + & org_g_FEM%owe2d(1:new_g_FEM%maxtot_int_2d) + new_g_FEM%owe3d(1:new_g_FEM%maxtot_int_3d) = & + & org_g_FEM%owe3d(1:new_g_FEM%maxtot_int_3d) +! + end subroutine copy_fem_gauss_int_coefs +! +!----------------------------------------------------------------------- +! + end module t_fem_gauss_int_coefs diff --git a/src/Fortran_libraries/UTILS_src/jacobian/t_jacobian_1d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/t_jacobian_1d.f90 new file mode 100644 index 00000000..4840339b --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/t_jacobian_1d.f90 @@ -0,0 +1,129 @@ +!>@file t_jacobian_1d.f90 +!! module t_jacobian_1d +!! +!!@author H. Matsui +!!@date Programmed on Nov., 2008 +!!@n Modified by H. Matsui on Feb., 2012 +! +!> @brief Structure of 1D Jacobian and difference of shape functions +!! +!!@verbatim +!! subroutine alloc_1d_jac_type(nedge, nnod_4_edge, n_int, jac_1d) +!! integer(kind = kint), intent(in) :: nedge, nnod_4_edge +!! integer(kind = kint), intent(in) :: n_int +!! type(jacobians_1d), intent(inout) :: jac_1d +!! +!! subroutine dealloc_1d_jac_type(jac_1d) +!! +!! subroutine copy_1d_jacobians & +!! & (nedge, nnod_4_edge, jac_org, jac_new) +!!@endverbatim +! + module t_jacobian_1d +! + use m_precision +! + implicit none +! +!> Stracture of Jacobians for edge + type jacobians_1d +!> Number of Gauss points + integer(kind = kint) :: ntot_int +! +!> Shape function + real (kind=kreal), allocatable :: an_edge(:,:) +! +!> Difference of shape function + real (kind=kreal), allocatable :: xeg_edge(:,:,:) +! +!> Jacobian + real (kind=kreal), allocatable :: xj_edge(:,:) +!> 1 / Jacobian + real (kind=kreal), allocatable :: axj_edge(:,:) + end type jacobians_1d +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_1d_jac_type(nedge, nnod_4_edge, n_int, jac_1d) +! + integer(kind = kint), intent(in) :: nedge, nnod_4_edge + integer(kind = kint), intent(in) :: n_int +! + type(jacobians_1d), intent(inout) :: jac_1d +! +! + jac_1d%ntot_int = n_int + allocate(jac_1d%an_edge(nnod_4_edge,jac_1d%ntot_int)) +! + allocate(jac_1d%xeg_edge(nedge,jac_1d%ntot_int,3)) +! + allocate(jac_1d%xj_edge(nedge,jac_1d%ntot_int)) + allocate(jac_1d%axj_edge(nedge,jac_1d%ntot_int)) +! + jac_1d%an_edge = 0.0d0 +! + if (nedge .gt. 0) then + jac_1d%xeg_edge = 0.0d0 +! + jac_1d%xj_edge = 0.0d0 + jac_1d%axj_edge = 0.0d0 + end if +! + end subroutine alloc_1d_jac_type +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dealloc_1d_jac_type(jac_1d) +! + type(jacobians_1d), intent(inout) :: jac_1d +! +! + if(allocated(jac_1d%an_edge) .eqv. .FALSE.) return + deallocate(jac_1d%an_edge) + deallocate(jac_1d%xeg_edge) +! + deallocate(jac_1d%xj_edge, jac_1d%axj_edge) +! + end subroutine dealloc_1d_jac_type +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine copy_1d_jacobians & + & (nedge, nnod_4_edge, jac_org, jac_new) +! + integer(kind = kint), intent(in) :: nedge, nnod_4_edge +! + type(jacobians_1d), intent(in) :: jac_org + type(jacobians_1d), intent(inout) :: jac_new +! +! + call alloc_1d_jac_type & + & (nedge, nnod_4_edge, jac_org%ntot_int, jac_new) +! + jac_new%an_edge(1:nnod_4_edge,1:jac_org%ntot_int) & + & = jac_org%an_edge(1:nnod_4_edge,1:jac_org%ntot_int) +! +!$omp parallel workshare + jac_new%xeg_edge(1:nedge,1:jac_org%ntot_int,1) & + & = jac_org%xeg_edge(1:nedge,1:jac_org%ntot_int,1) + jac_new%xeg_edge(1:nedge,1:jac_org%ntot_int,2) & + & = jac_org%xeg_edge(1:nedge,1:jac_org%ntot_int,2) + jac_new%xeg_edge(1:nedge,1:jac_org%ntot_int,3) & + & = jac_org%xeg_edge(1:nedge,1:jac_org%ntot_int,3) + jac_new%xj_edge(1:nedge,1:jac_org%ntot_int) & + & = jac_org%xj_edge(1:nedge,1:jac_org%ntot_int) + jac_new%axj_edge(1:nedge,1:jac_org%ntot_int) & + & = jac_org%axj_edge(1:nedge,1:jac_org%ntot_int) +!$omp end parallel workshare +! + end subroutine copy_1d_jacobians +! +! --------------------------------------------------------------------- +! + end module t_jacobian_1d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/t_jacobian_2d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/t_jacobian_2d.f90 new file mode 100644 index 00000000..85940885 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/t_jacobian_2d.f90 @@ -0,0 +1,117 @@ +!>@file t_jacobian_2d.f90 +!! module t_jacobian_2d +!! +!!@author H. Matsui +!!@date Programmed on Nov., 2008 +!!@n Modified by H. Matsui on Feb., 2012 +! +!> @brief Structure of 2D Jacobian and difference of shape functions +!! +!!@verbatim +!! subroutine alloc_2d_jac_type(nsurf, nnod_4_surf, n_int, jac_2d) +!! integer(kind = kint), intent(in) :: nsurf, nnod_4_surf +!! integer(kind = kint), intent(in) :: n_int +!! type(jacobians_2d), intent(inout) :: jac_2d +!! +!! subroutine dealloc_2d_jac_type(jac_2d) +!! +!! subroutine copy_jacobians_2d & +!! & (nsurf, nnod_4_surf, jac_2d_org, jac_2d_new) +!! type(jacobians_2d), intent(in) :: jac_2d_org +!! type(jacobians_2d), intent(inout) :: jac_2d_new +!!@endverbatim +! + module t_jacobian_2d +! + use m_precision +! + implicit none +! +!> Stracture of Jacobians for surface + type jacobians_2d +!> Number of Gauss points + integer(kind=kint) :: ntot_int +!> Shape function + real (kind=kreal), allocatable :: an_sf(:,:) +! +!> Difference of shape function + real (kind=kreal), allocatable :: xsf_sf(:,:,:) +! +!> Jacobian + real (kind=kreal), allocatable :: xj_sf(:,:) +!> 1 / Jacobian + real (kind=kreal), allocatable :: axj_sf(:,:) + end type jacobians_2d +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine alloc_2d_jac_type(nsurf, nnod_4_surf, n_int, jac_2d) +! + integer(kind = kint), intent(in) :: nsurf, nnod_4_surf + integer(kind = kint), intent(in) :: n_int +! + type(jacobians_2d), intent(inout) :: jac_2d +! +! + jac_2d%ntot_int = n_int + allocate(jac_2d%an_sf(nnod_4_surf,jac_2d%ntot_int)) +! + allocate(jac_2d%xsf_sf(nsurf,jac_2d%ntot_int,3)) +! + allocate(jac_2d%xj_sf(nsurf,jac_2d%ntot_int)) + allocate(jac_2d%axj_sf(nsurf,jac_2d%ntot_int)) +! + jac_2d%an_sf = 0.0d0 +! + if (nsurf .gt. 0) then + jac_2d%xsf_sf = 0.0d0 +! + jac_2d%xj_sf = 0.0d0 + jac_2d%axj_sf = 0.0d0 + end if +! + end subroutine alloc_2d_jac_type +! +! --------------------------------------------------------------------- +! + subroutine dealloc_2d_jac_type(jac_2d) +! + type(jacobians_2d), intent(inout) :: jac_2d +! +! + if(allocated(jac_2d%an_sf) .eqv. .FALSE.) return + deallocate(jac_2d%an_sf) + deallocate(jac_2d%xsf_sf) +! + deallocate(jac_2d%xj_sf, jac_2d%axj_sf) +! + end subroutine dealloc_2d_jac_type +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine copy_jacobians_2d & + & (nsurf, nnod_4_surf, jac_2d_org, jac_2d_new) +! + integer(kind = kint), intent(in) :: nsurf, nnod_4_surf + type(jacobians_2d), intent(in) :: jac_2d_org + type(jacobians_2d), intent(inout) :: jac_2d_new +! +! + call alloc_2d_jac_type(nsurf, nnod_4_surf, & + & jac_2d_org%ntot_int, jac_2d_new) +! + jac_2d_new%an_sf = jac_2d_org%an_sf + jac_2d_new%xsf_sf = jac_2d_org%xsf_sf + jac_2d_new%xj_sf = jac_2d_org%xj_sf + jac_2d_new%axj_sf = jac_2d_org%axj_sf +! + end subroutine copy_jacobians_2d +! +! ---------------------------------------------------------------------- +! + end module t_jacobian_2d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/t_jacobian_3d.f90 b/src/Fortran_libraries/UTILS_src/jacobian/t_jacobian_3d.f90 new file mode 100644 index 00000000..2af2eb09 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/t_jacobian_3d.f90 @@ -0,0 +1,280 @@ +!>@file t_jacobian_3d.f90 +!! module t_jacobian_3d +!! +!!@author H. Matsui +!!@date Programmed on Dec., 2008 +!!@n Modified by H. Matsui on Feb., 2012 +! +!> @brief Structure of 3D Jacobian and difference of shape functions +!! +!!@verbatim +!! subroutine alloc_jacobians & +!! & (numele, nnod_4_ele, ntot_int_3d, jac_3d) +!! subroutine alloc_inv_jacobian(numele, jac_3d) +!! subroutine alloc_dxi_dx(numele, jac_3d) +!! integer(kind = kint), intent(in) :: numele, nnod_4_ele +!! integer(kind = kint), intent(in) :: ntot_int_3d +!! type(jacobians_3d), intent(inout) :: jac_3d +!! +!! subroutine dealloc_jacobians(jac_3d) +!! subroutine dealloc_inv_jacobian(jac_3d) +!! subroutine dealloc_dxi_dx(jac_3d) +!! +!! subroutine copy_jacobians_3d(jac_org, jac_new) +!! subroutine copy_shape_func_infty(jac_org, jac_new) +!! subroutine copy_dxidx_3d(jac_org, jac_new) +!! +!! definision of matrix +!! dxidx_3d(iele,ix,1,1) :: dxi / dx +!! dxidx_3d(iele,ix,2,1) :: dei / dx +!! dxidx_3d(iele,ix,3,1) :: dzi / dx +!! +!! dxidx_3d(iele,ix,1,2) :: dxi / dy +!! dxidx_3d(iele,ix,2,2) :: dei / dy +!! dxidx_3d(iele,ix,3,2) :: dzi / dy +!! +!! dxidx_3d(iele,ix,1,3) :: dxi / dz +!! dxidx_3d(iele,ix,2,3) :: dei / dz +!! dxidx_3d(iele,ix,3,3) :: dzi / dz +!! +!! iele: element ID +!! ix: integration point ID +!!@endverbatim +!>@n @param ntot_int_3d +!> Total number of integration point for 3D element +! +!>@n @param an(Shape_function_ID,integration_point) +!> Shape function at integration point for linear element +!>@n \f[ N_\alpha(\xi,\chi,\eta) \f] +! +!>@n @param dnx(element_ID,Shape_function_ID,integration_point,direction) +!> Spatial differnce of linear shape function at integration +!> point for element +!>@n \f[ \frac{ dN_\alpha(\xi,\chi,\eta) }{ dx}, +!> \frac{ dN_\alpha(\xi,\chi,\eta) }{ dy}, +!> \frac{ dN_\alpha(\xi,\chi,\eta) }{ dz} \f] +! +!>@n @param an_infty(Shape_function_ID,surface_ID,integration_point) +!> Shape function at integration point for linear infinity element +!>@n \f[ N_{\infty\alpha}(\xi,\chi,\eta) \f] +! +!>@n @param xjac(element_ID,integration_point) +!> Jacobian at integration point for linear element +!>@n \f[ Ja = \det \left(\frac{ d{\bf x} }{ d {\bf \xi}} \right)\f] +!>@n @param axjac(element_ID,integration_point) +!> \f[ Ja^{-1}\f] +! +!> +!>@n @param aw(Shape_function_ID,integration_point) +!> Shape function at integration point for element +!>@n \f[ N_\alpha(\xi,\chi,\eta) \f] +! +!>@n @param dwx(element_ID,Shape_function_ID,integration_point,direction) +!> Spatial differnce of shape function at integration +!> point for element +!>@n \f[ \frac{ dN_\alpha(\xi,\chi,\eta) }{ dx}, +!> \frac{ dN_\alpha(\xi,\chi,\eta) }{ dy}, +!> \frac{ dN_\alpha(\xi,\chi,\eta) }{ dz} \f] +! +!>@n @param aw_infty(Shape_function_ID,surface_ID,integration_point) +!> Shape function at integration point for infinity element +!>@n \f[ N_{\infty\alpha}(\xi,\chi,\eta) \f] +! +!>@n @param xjac_q(element_ID,integration_point) +!> Jacobian at integration point for element +!>@n \f[ Ja = \det \left(\frac{ d{\bf x} }{ d {\bf \xi}} \right)\f] +!>@n @param axjac_q(element_ID,integration_point) +!> \f[ Ja^{-1}\f] +! +!> +!>@n @param am(Shape_function_ID,integration_point) +!> Shape function at integration point for element +!>@n \f[ N_\alpha(\xi,\chi,\eta) \f] +! +!>@n @param dmx(element_ID,Shape_function_ID,integration_point,direction) +!> Spatial differnce of shape function at integration +!> point for element +!>@n \f[ \frac{ dN_\alpha(\xi,\chi,\eta) }{ dx}, +!> \frac{ dN_\alpha(\xi,\chi,\eta) }{ dy}, +!> \frac{ dN_\alpha(\xi,\chi,\eta) }{ dz} \f] +! +!>@n @param am_infty(Shape_function_ID,surface_ID,integration_point) +!> Shape function at integration point for infinity element +!>@n \f[ N_{\infty\alpha}(\xi,\chi,\eta) \f] +! +!>@n @param xjac_lq(element_ID,integration_point) +!> Jacobian at integration point for element +!>@n \f[ Ja = \det \left(\frac{ d{\bf x} }{ d {\bf \xi}} \right)\f] +!>@n @param axjac_lq(element_ID,integration_point) +!> \f[ Ja^{-1}\f] +! + module t_jacobian_3d +! + use m_precision +! + implicit none +! +!> Stracture for Jacobians for element + type jacobians_3d +!> Total number of integration points + integer(kind = kint) :: ntot_int +!> Shape function at integration points + real (kind=kreal), allocatable :: an(:,:) +!> Spatial differnce of Shape function at integration points + real (kind=kreal), allocatable :: dnx(:,:,:,:) +! +!> Shape function for infinite element at integration points + real (kind=kreal), allocatable :: an_infty(:,:,:) +! +!> Jacobian at integration points + real (kind=kreal), allocatable :: xjac(:,:) +!> 1 / Jacbian + real (kind=kreal), allocatable :: axjac(:,:) +! +!> dxi / dx + real(kind=kreal), allocatable :: dxidx_3d(:,:,:,:) + end type jacobians_3d +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_jacobians & + & (numele, nnod_4_ele, ntot_int_3d, jac_3d) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numele, nnod_4_ele + integer(kind = kint), intent(in) :: ntot_int_3d +! + type(jacobians_3d), intent(inout) :: jac_3d +! +! + jac_3d%ntot_int = ntot_int_3d + allocate(jac_3d%an(nnod_4_ele,jac_3d%ntot_int)) + allocate(jac_3d%an_infty(nnod_4_ele,nsurf_4_ele,jac_3d%ntot_int)) +! + allocate(jac_3d%dnx(numele,nnod_4_ele,jac_3d%ntot_int,3)) +! + allocate(jac_3d%xjac(numele,jac_3d%ntot_int)) +! + jac_3d%an = 0.0d0 + jac_3d%an_infty = 0.0d0 +! + if (numele .gt. 0) then + jac_3d%dnx = 0.0d0 +! + jac_3d%xjac = 0.0d0 + end if +! + end subroutine alloc_jacobians +! +! --------------------------------------------------------------------- +! + subroutine alloc_inv_jacobian(numele, jac_3d) +! + integer(kind = kint), intent(in) :: numele + type(jacobians_3d), intent(inout) :: jac_3d +! +! + allocate(jac_3d%axjac(numele,jac_3d%ntot_int)) + if(numele .gt. 0) jac_3d%axjac = 0.0d0 +! + end subroutine alloc_inv_jacobian +! +! --------------------------------------------------------------------- +! + subroutine alloc_dxi_dx(numele, jac_3d) +! + integer(kind = kint), intent(in) :: numele + type(jacobians_3d), intent(inout) :: jac_3d +! +! + allocate( jac_3d%dxidx_3d(numele,jac_3d%ntot_int,3,3) ) + if (numele .gt. 0) jac_3d%dxidx_3d = 0.0d0 +! + end subroutine alloc_dxi_dx +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine dealloc_jacobians(jac_3d) +! + type(jacobians_3d), intent(inout) :: jac_3d +! + if(allocated(jac_3d%an) .eqv. .FALSE.) return + deallocate(jac_3d%an, jac_3d%an_infty) + deallocate(jac_3d%dnx) +! + deallocate(jac_3d%xjac) +! + end subroutine dealloc_jacobians +! +! ------------------------------------------------------------------ +! + subroutine dealloc_inv_jacobian(jac_3d) +! + type(jacobians_3d), intent(inout) :: jac_3d +! + if(allocated(jac_3d%axjac) .eqv. .FALSE.) return + deallocate(jac_3d%axjac) +! + end subroutine dealloc_inv_jacobian +! +! ------------------------------------------------------------------ +! + subroutine dealloc_dxi_dx(jac_3d) +! + type(jacobians_3d), intent(inout) :: jac_3d +! + if(allocated(jac_3d%dxidx_3d) .eqv. .FALSE.) return + deallocate(jac_3d%dxidx_3d) +! + end subroutine dealloc_dxi_dx +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine copy_jacobians_3d(jac_org, jac_new) +! + type(jacobians_3d), intent(in) :: jac_org + type(jacobians_3d), intent(inout) :: jac_new +! +! + jac_new%an = jac_org%an + jac_new%dnx = jac_org%dnx +! + jac_new%xjac = jac_org%xjac + jac_new%axjac = jac_org%axjac +! + end subroutine copy_jacobians_3d +! +! ------------------------------------------------------------------ +! + subroutine copy_shape_func_infty(jac_org, jac_new) +! + type(jacobians_3d), intent(in) :: jac_org + type(jacobians_3d), intent(inout) :: jac_new +! +! + jac_new%an_infty = jac_org%an_infty +! + end subroutine copy_shape_func_infty +! +! ------------------------------------------------------------------ +! + subroutine copy_dxidx_3d(jac_org, jac_new) +! + type(jacobians_3d), intent(in) :: jac_org + type(jacobians_3d), intent(inout) :: jac_new +! +! + jac_new%dxidx_3d = jac_org%dxidx_3d +! + end subroutine copy_dxidx_3d +! +! ------------------------------------------------------------------ +! + end module t_jacobian_3d diff --git a/src/Fortran_libraries/UTILS_src/jacobian/t_jacobians.f90 b/src/Fortran_libraries/UTILS_src/jacobian/t_jacobians.f90 new file mode 100644 index 00000000..98a5d1cd --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/t_jacobians.f90 @@ -0,0 +1,401 @@ +!>@file set_interpolate_file_name.f90 +!!@brief module set_interpolate_file_name +!! +!!@author H. Matsui +!!@date Programmed in Sep. 2006 (ver 1.2) +!! +!>@brief Structure of Jacobian and difference of shape functions +!! +!!@verbatim +!! subroutine const_jacobians_element(id_rank, nprocs, & +!! & node, ele, surf_grp, infinity_list, jacs) +!! subroutine const_jacobians_surf_group (id_rank, nprocs, & +!! & node, ele, surf, surf_grp, spf_2d, jacs) +!! subroutine const_jacobians_surface & +!! & (id_rank, nprocs, node, surf, spf_2d, jacs) +!! subroutine const_jacobians_edge & +!! & (id_rank, nprocs, node, edge, spf_1d, jacs) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(edge_data), intent(in) :: edge +!! type(surface_group_data), intent(in) :: surf_grp +!! type(scalar_surf_BC_list), intent(in) :: infinity_list +!! type(surface_shape_function), intent(inout) :: spf_2d +!! type(jacobians_type), intent(inout) :: jacs +!! +!! subroutine dealloc_dxi_dx_element(ele, jacs) +!! subroutine dealloc_jacobians_element(ele, jacs) +!! subroutine dealloc_jacobians_surf_grp(surf, jacs) +!! subroutine dealloc_jacobians_surface(surf, jacs) +!! subroutine dealloc_jacobians_edge(edge, jacs) +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(edge_data), intent(in) :: edge +!! type(jacobians_type), intent(inout) :: jacs +!!@endverbatim +! + module t_jacobians +! + use m_precision + use m_geometry_constants +! + use t_fem_gauss_int_coefs + use t_geometry_data + use t_surface_data + use t_edge_data + use t_group_data + use t_shape_functions + use t_jacobian_3d + use t_jacobian_2d + use t_jacobian_1d +! + implicit none +! +! +!> Stracture for Jacobians for FEM grid + type jacobians_type +!> Gauss points and weights + type(FEM_gauss_int_coefs) :: g_FEM +! +!> Stracture for Jacobians for element + type(jacobians_3d) :: jac_3d +!> Stracture for Jacobians for surface + type(jacobians_2d) :: jac_2d +!> Stracture for Jacobians for edge + type(jacobians_1d) :: jac_1d +!> Stracture for Jacobians for surafce group + type(jacobians_2d) :: jac_sf_grp +! +!> Stracture for Jacobians for linear element + type(jacobians_3d), pointer :: jac_3d_l +!> Stracture for Jacobians for linear surface + type(jacobians_2d), pointer :: jac_2d_l +!> Stracture for Jacobians for linear edge + type(jacobians_1d), pointer :: jac_1d_l +!> Stracture for Jacobians for linear surafce group + type(jacobians_2d), pointer :: jac_sf_grp_l + end type jacobians_type +! + private :: link_linear_jacobians_element + private :: link_linear_jacobians_sf_grp + private :: link_linear_jacobians_surface + private :: link_linear_jacobians_edge +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine const_jacobians_element(id_rank, nprocs, & + & node, ele, surf_grp, infinity_list, spf_3d, jacs) +! + use const_jacobians_3d + use const_jacobians_infinity +! + integer, intent(in) :: id_rank, nprocs + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: surf_grp + type(scalar_surf_BC_list), intent(in) :: infinity_list + type(volume_shape_function), intent(inout) :: spf_3d + type(jacobians_type), intent(inout) :: jacs +! +! + call alloc_jacobians(ele%numele, ele%nnod_4_ele, & + & jacs%g_FEM%maxtot_int_3d, jacs%jac_3d) + call alloc_inv_jacobian(ele%numele, jacs%jac_3d) + call alloc_dxi_dx(ele%numele, jacs%jac_3d) +! + if(id_rank .lt. nprocs) then + call sel_jacobian_type & + & (node, ele, jacs%g_FEM, spf_3d, jacs%jac_3d) + call sel_jacobian_infinity(node, ele, surf_grp, & + & infinity_list, jacs%g_FEM, spf_3d, jacs%jac_3d) + end if + call dealloc_inv_jacobian(jacs%jac_3d) +! + if(ele%nnod_4_ele .eq. num_t_linear) then + call link_linear_jacobians_element(jacs%jac_3d, jacs) + else + allocate(jacs%jac_3d_l) + call alloc_jacobians(ele%numele, num_t_linear, & + & jacs%g_FEM%maxtot_int_3d, jacs%jac_3d_l) + call alloc_inv_jacobian(ele%numele, jacs%jac_3d) + call alloc_dxi_dx(ele%numele, jacs%jac_3d_l) +! + if(id_rank .lt. nprocs) then + call cal_jacobian_trilinear & + & (node, ele, jacs%g_FEM, spf_3d, jacs%jac_3d_l) + call const_linear_jacobian_infinity(node, ele, surf_grp, & + & infinity_list, jacs%g_FEM, spf_3d, jacs%jac_3d_l) + end if +! + call dealloc_inv_jacobian(jacs%jac_3d_l) + end if +! + end subroutine const_jacobians_element +! +!----------------------------------------------------------------------- +!> Construct shape function, difference of shape function, and Jacobian +!> for surface group +! + subroutine const_jacobians_surf_group (id_rank, nprocs, & + & node, ele, surf, surf_grp, spf_2d, jacs) +! + use const_jacobians_sf_grp +! + integer, intent(in) :: id_rank, nprocs + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(surface_group_data), intent(in) :: surf_grp + type(surface_shape_function), intent(inout) :: spf_2d + type(jacobians_type), intent(inout) :: jacs +! +! + call alloc_2d_jac_type(surf_grp%num_item, & + & surf%nnod_4_surf, jacs%g_FEM%maxtot_int_2d, jacs%jac_sf_grp) +! + if(id_rank .lt. nprocs) then + call sel_jacobian_surface_grp (node, ele, surf, surf_grp, & + & jacs%g_FEM, spf_2d, jacs%jac_sf_grp) + end if +! + if(surf%nnod_4_surf .eq. num_linear_sf) then + call link_linear_jacobians_sf_grp(jacs%jac_sf_grp, jacs) + else + allocate(jacs%jac_sf_grp_l) + call alloc_2d_jac_type(surf_grp%num_item, num_linear_sf, & + & jacs%g_FEM%maxtot_int_2d, jacs%jac_sf_grp_l) +! + if(id_rank .lt. nprocs) then + call const_jacobian_sf_grp_linear(node, ele, surf_grp, & + & jacs%g_FEM, spf_2d, jacs%jac_sf_grp_l) + end if + end if +! + end subroutine const_jacobians_surf_group +! +!----------------------------------------------------------------------- +!> Construct shape function, difference of shape function, and Jacobian +!> for surface element +! + subroutine const_jacobians_surface & + & (id_rank, nprocs, node, surf, spf_2d, jacs) +! + use const_jacobians_2d +! + integer, intent(in) :: id_rank, nprocs + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf + type(surface_shape_function), intent(inout) :: spf_2d + type(jacobians_type), intent(inout) :: jacs +! +! + call alloc_2d_jac_type(surf%numsurf, & + & surf%nnod_4_surf, jacs%g_FEM%maxtot_int_2d, jacs%jac_2d) +! + if(id_rank .lt. nprocs) then + call sel_jacobian_surface & + & (node, surf, jacs%g_FEM, spf_2d, jacs%jac_2d) + end if +! + if(surf%nnod_4_surf .eq. num_linear_sf) then + call link_linear_jacobians_surface(jacs%jac_2d, jacs) + else + allocate(jacs%jac_2d_l) + call alloc_2d_jac_type(surf%numsurf, num_linear_sf, & + & jacs%g_FEM%maxtot_int_2d, jacs%jac_2d_l) + if(id_rank .lt. nprocs) then + call cal_jacobian_surface_linear & + & (node, surf, jacs%g_FEM, spf_2d, jacs%jac_2d_l) + end if + end if +! + end subroutine const_jacobians_surface +! +!----------------------------------------------------------------------- +!> Construct shape function, difference of shape function, and Jacobian +!> for edge element +! + subroutine const_jacobians_edge & + & (id_rank, nprocs, node, edge, spf_1d, jacs) +! + use const_jacobians_1d +! + integer, intent(in) :: id_rank, nprocs + type(node_data), intent(in) :: node + type(edge_data), intent(in) :: edge + type(edge_shape_function), intent(inout) :: spf_1d + type(jacobians_type), intent(inout) :: jacs +! +! + call alloc_1d_jac_type(edge%numedge, edge%nnod_4_edge, & + & jacs%g_FEM%maxtot_int_1d, jacs%jac_1d) +! + if(id_rank .lt. nprocs) then + call sel_jacobian_edge & + & (node, edge, jacs%g_FEM, spf_1d, jacs%jac_1d) + end if +! + if(edge%nnod_4_edge .eq. num_linear_edge) then + call link_linear_jacobians_edge(jacs%jac_1d, jacs) + else + allocate(jacs%jac_1d_l) + call alloc_1d_jac_type(edge%numedge, num_linear_edge, & + & jacs%g_FEM%maxtot_int_1d, jacs%jac_1d_l) + if(id_rank .lt. nprocs) then + call cal_jacobian_edge_linear & + & (node, edge, jacs%g_FEM, spf_1d, jacs%jac_1d_l) + end if + end if +! + end subroutine const_jacobians_edge +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine dealloc_dxi_dx_element(ele, jacs) +! + type(element_data), intent(in) :: ele + type(jacobians_type), intent(inout) :: jacs +! +! + call dealloc_dxi_dx(jacs%jac_3d) +! + if(ele%nnod_4_ele .ne. num_t_linear) then + call dealloc_dxi_dx(jacs%jac_3d_l) + end if +! + end subroutine dealloc_dxi_dx_element +! +!----------------------------------------------------------------------- +! + subroutine dealloc_jacobians_element(ele, jacs) +! + type(element_data), intent(in) :: ele + type(jacobians_type), intent(inout) :: jacs +! +! + if(ele%nnod_4_ele .eq. num_t_linear) then + nullify(jacs%jac_3d_l) + else + call dealloc_jacobians(jacs%jac_3d_l) + deallocate(jacs%jac_3d_l) + end if +! + call dealloc_jacobians(jacs%jac_3d) +! + end subroutine dealloc_jacobians_element +! +!----------------------------------------------------------------------- +! + subroutine dealloc_jacobians_surf_grp(surf, jacs) +! + use const_jacobians_2d +! + type(surface_data), intent(in) :: surf + type(jacobians_type), intent(inout) :: jacs +! +! + if(surf%nnod_4_surf .eq. num_linear_sf) then + nullify(jacs%jac_sf_grp_l) + else + call dealloc_2d_jac_type(jacs%jac_sf_grp_l) + deallocate(jacs%jac_sf_grp_l) + end if +! + call dealloc_2d_jac_type(jacs%jac_sf_grp) +! + end subroutine dealloc_jacobians_surf_grp +! +!----------------------------------------------------------------------- +! + subroutine dealloc_jacobians_surface(surf, jacs) +! + use const_jacobians_2d +! + type(surface_data), intent(in) :: surf + type(jacobians_type), intent(inout) :: jacs +! +! + if(surf%nnod_4_surf .eq. num_linear_sf) then + nullify(jacs%jac_2d_l) + else + call dealloc_2d_jac_type(jacs%jac_2d_l) + deallocate(jacs%jac_2d_l) + end if +! + call dealloc_2d_jac_type(jacs%jac_2d) +! + end subroutine dealloc_jacobians_surface +! +!----------------------------------------------------------------------- +! + subroutine dealloc_jacobians_edge(edge, jacs) +! + type(edge_data), intent(in) :: edge + type(jacobians_type), intent(inout) :: jacs +! +! + if(edge%nnod_4_edge .eq. num_linear_edge) then + nullify(jacs%jac_1d_l) + else + call dealloc_1d_jac_type(jacs%jac_1d_l) + deallocate(jacs%jac_1d_l) + end if +! + call dealloc_1d_jac_type(jacs%jac_1d) +! + end subroutine dealloc_jacobians_edge +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine link_linear_jacobians_element(jac_3d, jacs) +! + type(jacobians_3d), intent(in), target :: jac_3d + type(jacobians_type), intent(inout) :: jacs +! + jacs%jac_3d_l => jac_3d +! + end subroutine link_linear_jacobians_element +! +! ---------------------------------------------------------------------- +! + subroutine link_linear_jacobians_sf_grp(jac_sf_grp, jacs) +! + type(jacobians_2d), intent(in), target :: jac_sf_grp + type(jacobians_type), intent(inout) :: jacs +! + jacs%jac_sf_grp_l => jac_sf_grp +! + end subroutine link_linear_jacobians_sf_grp +! +! ---------------------------------------------------------------------- +! + subroutine link_linear_jacobians_surface(jac_2d, jacs) +! + type(jacobians_2d), intent(in), target :: jac_2d + type(jacobians_type), intent(inout) :: jacs +! + jacs%jac_2d_l => jac_2d +! + end subroutine link_linear_jacobians_surface +! +! ---------------------------------------------------------------------- +! + subroutine link_linear_jacobians_edge(jac_1d, jacs) +! + type(jacobians_1d), intent(in), target :: jac_1d + type(jacobians_type), intent(inout) :: jacs +! + jacs%jac_1d_l => jac_1d +! + end subroutine link_linear_jacobians_edge +! +! ---------------------------------------------------------------------- +! + end module t_jacobians diff --git a/src/Fortran_libraries/UTILS_src/jacobian/t_shape_functions.f90 b/src/Fortran_libraries/UTILS_src/jacobian/t_shape_functions.f90 new file mode 100644 index 00000000..d0e2ebb1 --- /dev/null +++ b/src/Fortran_libraries/UTILS_src/jacobian/t_shape_functions.f90 @@ -0,0 +1,325 @@ +!>@file t_shape_functions.f90 +!!@brief module t_shape_functions +!! +!!@author H. Matsui +!!@date Programmed on 2001 +!! +!>@brief arrays for shape functions in element coordinate +!! +!!@verbatim +!! subroutine alloc_3d_gauss_point_id(g_FEM, spf_3d) +!! subroutine alloc_2d_gauss_point_id(g_FEM, spf_2d) +!! subroutine alloc_1d_gauss_point_id(g_FEM, spf_1d) +!! subroutine alloc_integrate_parameters +!! +!! subroutine dealloc_gauss_point_id +!! subroutine dealloc_3d_gauss_point_id(spf_3d) +!! subroutine dealloc_2d_gauss_point_id(spf_2d) +!! subroutine dealloc_1d_gauss_point_id(spf_1d) +!! +!! subroutine alloc_vol_shape_func(nnod_4_ele, g_FEM, spf_3d) +!! subroutine alloc_shape_func_infty & +!! & (nnod_4_ele, nsurf_4_ele, g_FEM, spf_inf) +!! subroutine alloc_surf_shape_func(nnod_4_sf, g_FEM, spf_2d) +!! subroutine alloc_edge_shape_func(nnod_4_ed, g_FEM, spf_1d) +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(volume_shape_function), intent(inout) :: spf_3d +!! type(infty_shape_function), intent(inout) :: spf_inf +!! type(surface_shape_function), intent(inout) :: spf_2d +!! type(edge_shape_function), intent(inout) :: spf_1d +!!@endverbatim +! + module t_shape_functions +! + use m_precision + use t_fem_gauss_int_coefs +! + implicit none +! +! + type volume_shape_function + integer(kind = kint), allocatable :: l_int(:,:,:) +! + real(kind=kreal), allocatable :: xi(:) + real(kind=kreal), allocatable :: ei(:) + real(kind=kreal), allocatable :: zi(:) +! + real(kind=kreal), allocatable :: dnxi(:,:) + real(kind=kreal), allocatable :: dnei(:,:) + real(kind=kreal), allocatable :: dnzi(:,:) + end type volume_shape_function +! + type infty_shape_function + real(kind=kreal), allocatable :: dnxi_inf(:,:,:) + real(kind=kreal), allocatable :: dnei_inf(:,:,:) + real(kind=kreal), allocatable :: dnzi_inf(:,:,:) + end type infty_shape_function +! + type surface_shape_function + integer (kind=kint), allocatable :: l_int(:,:,:) +! + real(kind=kreal), allocatable :: xi(:) + real(kind=kreal), allocatable :: ei(:) +! + real(kind=kreal), allocatable :: dnxi_sf(:,:) + real(kind=kreal), allocatable :: dnei_sf(:,:) + end type surface_shape_function +! + type edge_shape_function + integer (kind=kint), allocatable :: l_int(:,:,:) + real (kind=kreal), allocatable :: xi(:) +! + real (kind=kreal), allocatable :: dnxi_ed(:,:) + end type edge_shape_function +! +! + type shape_finctions_at_points + type(volume_shape_function) :: spf_3d + type(surface_shape_function) :: spf_2d + type(edge_shape_function) :: spf_1d + end type shape_finctions_at_points +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine alloc_3d_gauss_point_id(g_FEM, spf_3d) +! + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(inout) :: spf_3d +! +! + allocate(spf_3d%l_int(3,g_FEM%maxtot_int_3d,g_FEM%max_int_point)) + allocate(spf_3d%xi(g_FEM%maxtot_int_3d) ) + allocate(spf_3d%ei(g_FEM%maxtot_int_3d) ) + allocate(spf_3d%zi(g_FEM%maxtot_int_3d) ) +! + spf_3d%l_int = 0 + spf_3d%xi = 0.0d0 + spf_3d%ei = 0.0d0 + spf_3d%zi = 0.0d0 +! + end subroutine alloc_3d_gauss_point_id +! +! ---------------------------------------------------------------------- +! + subroutine alloc_2d_gauss_point_id(g_FEM, spf_2d) +! + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d +! +! + allocate(spf_2d%l_int(2,g_FEM%maxtot_int_2d,g_FEM%max_int_point)) + allocate(spf_2d%xi(g_FEM%maxtot_int_2d) ) + allocate(spf_2d%ei(g_FEM%maxtot_int_2d) ) + spf_2d%l_int = 0 + spf_2d%xi = 0.0d0 + spf_2d%ei = 0.0d0 +! + end subroutine alloc_2d_gauss_point_id +! +! ---------------------------------------------------------------------- +! + subroutine alloc_1d_gauss_point_id(g_FEM, spf_1d) +! + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(edge_shape_function), intent(inout) :: spf_1d +! +! + allocate(spf_1d%l_int(1,g_FEM%maxtot_int_1d,g_FEM%max_int_point)) + allocate(spf_1d%xi(g_FEM%maxtot_int_1d)) + spf_1d%l_int = 0 + spf_1d%xi = 0.0d0 +! + end subroutine alloc_1d_gauss_point_id +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine dealloc_gauss_point_id(spf_3d, spf_2d, spf_1d) +! + type(volume_shape_function), intent(inout) :: spf_3d + type(surface_shape_function), intent(inout) :: spf_2d + type(edge_shape_function), intent(inout) :: spf_1d +! +! + call dealloc_3d_gauss_point_id(spf_3d) + call dealloc_2d_gauss_point_id(spf_2d) + call dealloc_1d_gauss_point_id(spf_1d) +! + end subroutine dealloc_gauss_point_id +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine dealloc_3d_gauss_point_id(spf_3d) +! + type(volume_shape_function), intent(inout) :: spf_3d +! +! + if(allocated(spf_3d%l_int) .eqv. .FALSE.) return + deallocate(spf_3d%l_int) + deallocate(spf_3d%xi, spf_3d%ei, spf_3d%zi) +! + end subroutine dealloc_3d_gauss_point_id +! +! ---------------------------------------------------------------------- +! + subroutine dealloc_2d_gauss_point_id(spf_2d) +! + type(surface_shape_function), intent(inout) :: spf_2d +! +! + if(allocated(spf_2d%l_int) .eqv. .FALSE.) return + deallocate(spf_2d%l_int) + deallocate(spf_2d%xi, spf_2d%ei) +! + end subroutine dealloc_2d_gauss_point_id +! +! ---------------------------------------------------------------------- +! + subroutine dealloc_1d_gauss_point_id(spf_1d) +! + type(edge_shape_function), intent(inout) :: spf_1d +! +! + if(allocated(spf_1d%l_int) .eqv. .FALSE.) return + deallocate(spf_1d%l_int) + deallocate(spf_1d%xi) +! + end subroutine dealloc_1d_gauss_point_id +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine alloc_vol_shape_func(nnod_4_ele, g_FEM, spf_3d) +! + integer(kind = kint), intent(in) :: nnod_4_ele + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(volume_shape_function), intent(inout) :: spf_3d +! +! + allocate(spf_3d%dnxi(nnod_4_ele,g_FEM%maxtot_int_3d) ) + allocate(spf_3d%dnei(nnod_4_ele,g_FEM%maxtot_int_3d) ) + allocate(spf_3d%dnzi(nnod_4_ele,g_FEM%maxtot_int_3d) ) +! + spf_3d%dnxi = 0.0d0 + spf_3d%dnei = 0.0d0 + spf_3d%dnzi = 0.0d0 +! + end subroutine alloc_vol_shape_func +! +! ---------------------------------------------------------------------- +! + subroutine alloc_shape_func_infty & + & (nnod_4_ele, nsurf_4_ele, g_FEM, spf_inf) +! + integer(kind = kint), intent(in) :: nnod_4_ele, nsurf_4_ele + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(infty_shape_function), intent(inout) :: spf_inf +! + integer(kind = kint) :: ntot_int +! +! + ntot_int = g_FEM%maxtot_int_3d + allocate(spf_inf%dnxi_inf(nnod_4_ele,nsurf_4_ele,ntot_int) ) + allocate(spf_inf%dnei_inf(nnod_4_ele,nsurf_4_ele,ntot_int) ) + allocate(spf_inf%dnzi_inf(nnod_4_ele,nsurf_4_ele,ntot_int) ) +! + spf_inf%dnxi_inf = 0.0d0 + spf_inf%dnei_inf = 0.0d0 + spf_inf%dnzi_inf = 0.0d0 +! + end subroutine alloc_shape_func_infty +! +! ---------------------------------------------------------------------- +! + subroutine alloc_surf_shape_func(nnod_4_sf, g_FEM, spf_2d) +! + integer(kind = kint), intent(in) :: nnod_4_sf + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(surface_shape_function), intent(inout) :: spf_2d +! +! + allocate(spf_2d%dnxi_sf(nnod_4_sf,g_FEM%maxtot_int_2d) ) + allocate(spf_2d%dnei_sf(nnod_4_sf,g_FEM%maxtot_int_2d) ) +! + spf_2d%dnxi_sf = 0.0d0 + spf_2d%dnei_sf = 0.0d0 +! + end subroutine alloc_surf_shape_func +! +! ---------------------------------------------------------------------- +! + subroutine alloc_edge_shape_func(nnod_4_ed, g_FEM, spf_1d) +! + integer(kind = kint), intent(in) :: nnod_4_ed + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(edge_shape_function), intent(inout) :: spf_1d +! +! + allocate(spf_1d%dnxi_ed(nnod_4_ed,g_FEM%maxtot_int_1d) ) +! + spf_1d%dnxi_ed = 0.0d0 +! + end subroutine alloc_edge_shape_func +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine dealloc_vol_shape_func(spf_3d) +! + type(volume_shape_function), intent(inout) :: spf_3d +! +! + if(allocated(spf_3d%dnxi) .eqv. .FALSE.) return + deallocate(spf_3d%dnxi) + deallocate(spf_3d%dnei) + deallocate(spf_3d%dnzi) +! + end subroutine dealloc_vol_shape_func +! +! ---------------------------------------------------------------------- +! + subroutine dealloc_shape_func_infty(spf_inf) +! + type(infty_shape_function), intent(inout) :: spf_inf +! +! + if(allocated(spf_inf%dnxi_inf) .eqv. .FALSE.) return + deallocate(spf_inf%dnxi_inf) + deallocate(spf_inf%dnei_inf) + deallocate(spf_inf%dnzi_inf) +! + end subroutine dealloc_shape_func_infty +! +! ---------------------------------------------------------------------- +! + subroutine dealloc_surf_shape_func(spf_2d) +! + type(surface_shape_function), intent(inout) :: spf_2d +! +! + if(allocated(spf_2d%dnxi_sf) .eqv. .FALSE.) return + deallocate(spf_2d%dnxi_sf) + deallocate(spf_2d%dnei_sf) +! + end subroutine dealloc_surf_shape_func +! +! ---------------------------------------------------------------------- +! + subroutine dealloc_edge_shape_func(spf_1d) +! + type(edge_shape_function), intent(inout) :: spf_1d +! +! + if(allocated(spf_1d%dnxi_ed) .eqv. .FALSE.) return + deallocate(spf_1d%dnxi_ed) +! + end subroutine dealloc_edge_shape_func +! +! ---------------------------------------------------------------------- +! + end module t_shape_functions diff --git a/src/Fortran_libraries/VIZ_src/Makefile b/src/Fortran_libraries/VIZ_src/Makefile index c8f209e1..2d53f4d9 100644 --- a/src/Fortran_libraries/VIZ_src/Makefile +++ b/src/Fortran_libraries/VIZ_src/Makefile @@ -6,7 +6,11 @@ LIB_VIZ = -lkemo_viz LIB_VIZ_FILE = libkemo_viz.a SUBDIRS = \ -surfacing +surfacing \ +fieldline \ +map_rendering \ +volume_rendering + # # ------------------------------------------------------------------------- @@ -53,6 +57,8 @@ lib_archve: mod_list: @echo MOD_VIZ= \\ >> $(MAKENAME) @echo '$$(MOD_SURFACING)' \\ >> $(MAKENAME) + @echo '$$(MOD_FIELDLINE)' \\ >> $(MAKENAME) + @echo '$$(MOD_PVR)' \\ >> $(MAKENAME) @echo >> $(MAKENAME) @for dir in $(SUBDIRS); do \ diff --git a/src/Fortran_libraries/VIZ_src/fieldline/MPI_particle_file_IO.f90 b/src/Fortran_libraries/VIZ_src/fieldline/MPI_particle_file_IO.f90 new file mode 100644 index 00000000..d0b13448 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/MPI_particle_file_IO.f90 @@ -0,0 +1,148 @@ +!>@file MPI_particle_file_IO.f90 +!! module MPI_particle_file_IO +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2006 +! +!>@brief File IO for element communication table +!! +!!@verbatim +!! subroutine mpi_read_perticle_file & +!! & (num_pe, id_rank, file_name, t_IO, particle_IO) +!! integer, intent(in) :: num_pe, id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(inout) :: t_IO +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!! subroutine mpi_write_perticle_file(file_name, t_IO, particle_IO) +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(in) :: t_IO +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!!@endverbatim +!! +!!@param id_rank MPI rank +! + module MPI_particle_file_IO +! + use m_precision + use m_machine_parameter +! + use m_file_format_switch + use t_calypso_mpi_IO_param + use t_read_mesh_data + use t_time_data +! + implicit none +! + type(calypso_MPI_IO_params), save, private :: IO_param +! +!------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------ +! + subroutine mpi_read_perticle_file & + & (num_pe, id_rank, file_name, t_IO, particle_IO) +! + use m_fem_mesh_labels + use mesh_data_IO + use groups_IO + use local_fline_restart_IO + use MPI_domain_data_IO + use MPI_ascii_data_IO + use MPI_node_geometry_IO + use MPI_element_connect_IO + use field_data_MPI_IO + +! + integer, intent(in) :: num_pe, id_rank + character(len=kchara), intent(in) :: file_name +! + type(time_data), intent(inout) :: t_IO + type(surf_edge_IO_file), intent(inout) :: particle_IO +! +! + if(id_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Read ascii particle file: ', trim(file_name) +! + call open_read_mpi_file & + & (file_name, num_pe, id_rank, IO_param) +! + call mpi_skip_read(IO_param, len(hd_fem_para())) + call mpi_read_domain_info(IO_param, particle_IO%comm) +! + call mpi_skip_read(IO_param, len(hd_fem_node())) + call mpi_read_geometry_info(IO_param, particle_IO%node) + call mpi_skip_read(IO_param, len(hd_particle_connect())) + call mpi_read_element_info(IO_param, particle_IO%ele) +! + call mpi_skip_read(IO_param, len(hd_particle_velocity())) + call mpi_read_vect_in_ele(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call mpi_skip_read(IO_param, len(hd_particle_marker())) + call mpi_read_scl_in_ele(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call read_field_time_mpi(IO_param%id_file, nprocs, & + & IO_param%ioff_gl, t_IO) + call close_mpi_file(IO_param) +! + end subroutine mpi_read_perticle_file +! +!------------------------------------------------------------------ +! + subroutine mpi_write_perticle_file(file_name, t_IO, particle_IO) +! + use m_fem_mesh_labels + use mesh_data_IO + use time_data_IO + use local_fline_restart_IO + use MPI_domain_data_IO + use MPI_ascii_data_IO + use MPI_node_geometry_IO + use MPI_element_connect_IO + use field_data_MPI_IO +! + character(len=kchara), intent(in) :: file_name + type(time_data), intent(in) :: t_IO + type(surf_edge_IO_file), intent(in) :: particle_IO +! +! + if(my_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Write ascii particle file: ', trim(file_name) +! + call open_write_mpi_file(file_name, IO_param) +! + call mpi_write_charahead & + & (IO_param, len(hd_fem_para()), hd_fem_para()) + call mpi_write_domain_info(IO_param, particle_IO%comm) +! + call mpi_write_charahead & + & (IO_param, len(hd_fem_node()), hd_fem_node()) + call mpi_write_geometry_info(IO_param, particle_IO%node) +! + call mpi_write_charahead & + & (IO_param, len(hd_particle_connect()), hd_particle_connect()) + call mpi_write_element_info(IO_param, particle_IO%ele) +! + call mpi_write_charahead & + & (IO_param, len(hd_particle_velocity()), hd_particle_velocity()) + call mpi_write_vect_in_ele(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call mpi_write_charahead & + & (IO_param, len(hd_particle_marker()), hd_particle_marker()) + call mpi_write_scl_in_ele(IO_param, particle_IO%node, & + & particle_IO%sfed) + + call mpi_write_charahead(IO_param, & + & len(step_data_buffer(my_rank, t_IO)), & + & step_data_buffer(my_rank, t_IO)) + call close_mpi_file(IO_param) +! + end subroutine mpi_write_perticle_file +! +!------------------------------------------------------------------ +! + end module MPI_particle_file_IO diff --git a/src/Fortran_libraries/VIZ_src/fieldline/MPI_particle_file_IO_b.f90 b/src/Fortran_libraries/VIZ_src/fieldline/MPI_particle_file_IO_b.f90 new file mode 100644 index 00000000..01d5b398 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/MPI_particle_file_IO_b.f90 @@ -0,0 +1,122 @@ +!>@file MPI_particle_file_IO_b.f90 +!!@brief module MPI_particle_file_IO_b +!! +!!@author H.Matsui +!!@date Programmed in June, 2024 +! +!>@brief particle file IO for gxipped format +!! +!!@verbatim +!! subroutine mpi_read_particle_file_b(num_pe, id_rank, file_name, & +!! & t_IO, particle_IO) +!! integer, intent(in) :: num_pe, id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(surf_edge_IO_file), intent(inout) :: particle_IO +!! type(time_data), intent(inout) :: t_IO +!! subroutine mpi_write_particle_file_b & +!! & (file_name, t_IO, particle_IO) +!! character(len=kchara), intent(in) :: file_name +!! type(surf_edge_IO_file), intent(inout) :: particle_IO +!! type(time_data), intent(in) :: t_IO +!!@endverbatim +! + module MPI_particle_file_IO_b +! + use m_precision + use m_machine_parameter +! + use m_calypso_mpi_IO + use t_read_mesh_data + use t_calypso_mpi_IO_param + use MPI_ascii_data_IO + use t_time_data +! + implicit none +! + type(calypso_MPI_IO_params), private, save :: IO_param +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine mpi_read_particle_file_b(num_pe, id_rank, file_name, & + & t_IO, particle_IO) +! + use MPI_mesh_data_IO_b + use MPI_groups_IO_b + use MPI_domain_data_IO_b + use MPI_node_geometry_IO_b + use MPI_element_connect_IO_b + use MPI_ascii_data_IO + use field_block_MPI_IO_b +! + integer, intent(in) :: num_pe, id_rank + character(len=kchara), intent(in) :: file_name +! + type(surf_edge_IO_file), intent(inout) :: particle_IO + type(time_data), intent(inout) :: t_IO +! +! + if(my_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Read gzipped binary merged perticle file: ', trim(file_name) +! + call open_read_mpi_file_b & + & (file_name, num_pe, id_rank, IO_param) +! + call mpi_read_domain_info_b(IO_param, particle_IO%comm) + call mpi_read_geometry_info_b(IO_param, particle_IO%node) + call mpi_read_element_info_b(IO_param, particle_IO%ele) + + call mpi_read_vect_in_ele_b(IO_param, particle_IO%node, & + & particle_IO%sfed) + call mpi_read_scl_in_ele_b(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call read_field_time_mpi_b(num_pe, IO_param, t_IO) + call close_mpi_file(IO_param) +! + end subroutine mpi_read_particle_file_b +! +! --------------------------------------------------------------------- +! + subroutine mpi_write_particle_file_b & + & (file_name, t_IO, particle_IO) +! + use m_machine_parameter + use MPI_mesh_data_IO_b + use MPI_ascii_data_IO + use MPI_domain_data_IO_b + use MPI_node_geometry_IO_b + use MPI_element_connect_IO_b + use field_block_MPI_IO_b +! + character(len=kchara), intent(in) :: file_name + type(surf_edge_IO_file), intent(in) :: particle_IO + type(time_data), intent(in) :: t_IO +! +! + if(my_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Write gzipped binary merged perticle file: ', trim(file_name) +! + call open_write_mpi_file_b(file_name, IO_param) + call mpi_write_domain_info_b(IO_param, particle_IO%comm) +! + call mpi_write_geometry_info_b(IO_param, particle_IO%node) + call mpi_write_element_info_b(IO_param, particle_IO%ele) +! + call mpi_write_vect_in_ele_b(IO_param, particle_IO%node, & + & particle_IO%sfed) + call mpi_write_scl_in_ele_b(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call write_field_time_mpi_b(IO_param, & + & t_IO%i_time_step, t_IO%time, t_IO%dt) + call close_mpi_file(IO_param) +! + end subroutine mpi_write_particle_file_b +! +! --------------------------------------------------------------------- +! + end module MPI_particle_file_IO_b diff --git a/src/Fortran_libraries/VIZ_src/fieldline/Makefile b/src/Fortran_libraries/VIZ_src/fieldline/Makefile new file mode 100644 index 00000000..d6d2aeb3 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/Makefile @@ -0,0 +1,41 @@ +# +# +# + +FIELDLINE_DIR = $$(VIZ_SRCDIR)/fieldline +SOURCES = $(shell ls *.f90 *.F90) +MOD_FIELDLINE = $(addsuffix .o,$(basename $(SOURCES)) ) + +# +# -------------------------------------------------------------------- +# + +dir_list: + @echo 'FIELDLINE_DIR = $(FIELDLINE_DIR)' >> $(MAKENAME) + +lib_name: + +lib_tasks: lib_archve + @echo ' ''$$(RANLIB) $$@' >> $(MAKENAME) + +libtarget: + +lib_archve: libtarget + @echo ' ''$$(AR)' '$$(ARFLUGS)' rcsv '$$@' '$$(MOD_FIELDLINE)' \ + >> $(MAKENAME) + + + +mod_list: + @echo MOD_FIELDLINE= \\ >> $(MAKENAME) + @echo $(MOD_FIELDLINE) >> $(MAKENAME) + @echo >> $(MAKENAME) + +module: + @cat Makefile.depends >> $(MAKENAME) + +depends: + @$(MAKE_MOD_DEP) Makefile.depends '$$(FIELDLINE_DIR)' $(SOURCES) + +clean: + rm -f *.o *.mod *~ *.par *.diag *.a diff --git a/src/Fortran_libraries/VIZ_src/fieldline/Makefile.depends b/src/Fortran_libraries/VIZ_src/fieldline/Makefile.depends new file mode 100644 index 00000000..ab07a534 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/Makefile.depends @@ -0,0 +1,115 @@ +MPI_particle_file_IO.o: $(FIELDLINE_DIR)/MPI_particle_file_IO.f90 m_precision.o m_machine_parameter.o m_file_format_switch.o t_calypso_mpi_IO_param.o t_read_mesh_data.o t_time_data.o m_fem_mesh_labels.o mesh_data_IO.o groups_IO.o local_fline_restart_IO.o MPI_domain_data_IO.o MPI_ascii_data_IO.o MPI_node_geometry_IO.o MPI_element_connect_IO.o field_data_MPI_IO.o time_data_IO.o + $(F90) -c $(F90OPTFLAGS) $< +MPI_particle_file_IO_b.o: $(FIELDLINE_DIR)/MPI_particle_file_IO_b.f90 m_precision.o m_machine_parameter.o m_calypso_mpi_IO.o t_read_mesh_data.o t_calypso_mpi_IO_param.o MPI_ascii_data_IO.o t_time_data.o MPI_mesh_data_IO_b.o MPI_groups_IO_b.o MPI_domain_data_IO_b.o MPI_node_geometry_IO_b.o MPI_element_connect_IO_b.o field_block_MPI_IO_b.o + $(F90) -c $(F90OPTFLAGS) $< +bcast_control_data_tracers.o: $(FIELDLINE_DIR)/bcast_control_data_tracers.f90 m_precision.o m_machine_parameter.o t_control_data_tracers.o calypso_mpi.o transfer_to_long_integers.o calypso_mpi_char.o calypso_mpi_int.o bcast_control_arrays.o bcast_ctl_data_field_line.o + $(F90) -c $(F90OPTFLAGS) $< +bcast_ctl_data_field_line.o: $(FIELDLINE_DIR)/bcast_ctl_data_field_line.f90 m_precision.o m_machine_parameter.o calypso_mpi.o t_control_data_flines.o calypso_mpi_int.o calypso_mpi_char.o transfer_to_long_integers.o t_ctl_data_field_line.o bcast_control_arrays.o + $(F90) -c $(F90OPTFLAGS) $< +cal_field_on_surf_viz.o: $(FIELDLINE_DIR)/cal_field_on_surf_viz.f90 m_precision.o m_constants.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +cal_fline_in_cube.o: $(FIELDLINE_DIR)/cal_fline_in_cube.f90 m_precision.o m_constants.o m_geometry_constants.o t_geometry_data.o t_surface_data.o solver_33_array.o + $(F90) -c $(F90OPTFLAGS) $< +collect_fline_data.o: $(FIELDLINE_DIR)/collect_fline_data.f90 m_precision.o calypso_mpi.o m_constants.o m_geometry_constants.o t_control_params_4_fline.o t_local_fline.o t_ucd_data.o const_global_element_ids.o t_source_of_filed_line.o + $(F90) -c $(F90OPTFLAGS) $< +const_field_lines.o: $(FIELDLINE_DIR)/const_field_lines.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o m_work_time.o t_mesh_SR.o t_mesh_data.o t_control_params_4_fline.o t_comm_table.o t_phys_data.o t_parallel_surface_indices.o t_local_fline.o t_next_node_ele_4_node.o t_trace_data_send_recv.o t_broadcast_trace_data.o t_tracing_data.o calypso_SR.o transfer_to_long_integers.o extend_field_line.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_data_field_line_IO.o: $(FIELDLINE_DIR)/ctl_data_field_line_IO.f90 m_precision.o m_machine_parameter.o t_ctl_data_field_line.o t_read_control_elements.o t_control_array_integer.o t_control_array_character.o t_control_array_integer2.o t_control_array_real.o t_control_array_real3.o t_fline_seeds_list_ctl.o calypso_mpi.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_file_fieldlines_IO.o: $(FIELDLINE_DIR)/ctl_file_fieldlines_IO.f90 m_precision.o m_constants.o m_machine_parameter.o t_ctl_data_field_line.o t_control_data_flines.o t_read_control_elements.o skip_comment_f.o ctl_data_field_line_IO.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +elapsed_labels_4_FLINE.o: $(FIELDLINE_DIR)/elapsed_labels_4_FLINE.f90 m_precision.o m_work_time.o + $(F90) -c $(F90OPTFLAGS) $< +extend_field_line.o: $(FIELDLINE_DIR)/extend_field_line.f90 m_precision.o m_constants.o m_geometry_constants.o calypso_mpi.o t_geometry_data.o t_surface_data.o t_parallel_surface_indices.o t_phys_data.o t_ctl_params_viz_fields.o t_local_fline.o trace_in_element.o set_fields_after_tracing.o coordinate_converter.o convert_components_4_viz.o cal_field_on_surf_viz.o cal_fline_in_cube.o tracer_field_interpolate.o + $(F90) -c $(F90OPTFLAGS) $< +gz_MPI_particle_file_IO.o: $(FIELDLINE_DIR)/gz_MPI_particle_file_IO.f90 m_precision.o m_machine_parameter.o m_file_format_switch.o t_calypso_mpi_IO_param.o t_read_mesh_data.o t_time_data.o m_fem_mesh_labels.o local_fline_restart_IO.o MPI_ascii_data_IO.o gz_MPI_ascii_data_IO.o gz_MPI_domain_data_IO.o gz_MPI_element_connect_IO.o gz_MPI_node_geometry_IO.o gz_field_block_MPI_IO.o time_data_IO.o + $(F90) -c $(F90OPTFLAGS) $< +gz_MPI_particle_file_IO_b.o: $(FIELDLINE_DIR)/gz_MPI_particle_file_IO_b.f90 m_precision.o m_machine_parameter.o m_calypso_mpi_IO.o t_time_data.o t_read_mesh_data.o t_calypso_mpi_IO_param.o gz_MPI_mesh_data_IO_b.o MPI_ascii_data_IO.o gz_MPI_binary_datum_IO.o MPI_binary_head_IO.o gz_field_block_MPI_IO_b.o + $(F90) -c $(F90OPTFLAGS) $< +gz_particle_file_IO.o: $(FIELDLINE_DIR)/gz_particle_file_IO.f90 m_precision.o m_machine_parameter.o m_file_format_switch.o t_read_mesh_data.o t_buffer_4_gzip.o t_time_data.o skip_gz_comment.o local_fline_restart_IO.o gzip_file_access.o gz_domain_data_IO.o gz_node_geometry_IO.o gz_element_connect_IO.o gz_field_data_IO.o m_fem_mesh_labels.o + $(F90) -c $(F90OPTFLAGS) $< +gz_particle_file_IO_b.o: $(FIELDLINE_DIR)/gz_particle_file_IO_b.f90 m_precision.o m_machine_parameter.o m_file_format_switch.o t_read_mesh_data.o t_buffer_4_gzip.o t_time_data.o set_mesh_file_names.o binary_IO.o gzip_file_access.o gz_domain_data_IO_b.o gz_node_geometry_IO_b.o gz_element_connect_IO_b.o gz_field_data_IO_b.o + $(F90) -c $(F90OPTFLAGS) $< +local_fline_restart_IO.o: $(FIELDLINE_DIR)/local_fline_restart_IO.f90 m_precision.o m_constants.o t_local_fline.o t_read_mesh_data.o calypso_mpi.o set_nnod_4_ele_by_type.o t_ctl_params_viz_fields.o t_field_data_IO.o + $(F90) -c $(F90OPTFLAGS) $< +m_control_fline_flags.o: $(FIELDLINE_DIR)/m_control_fline_flags.f90 m_precision.o t_control_array_character.o + $(F90) -c $(F90OPTFLAGS) $< +multi_trace_particle.o: $(FIELDLINE_DIR)/multi_trace_particle.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o t_time_data.o t_mesh_data.o t_phys_data.o t_parallel_surface_indices.o t_control_params_4_fline.o t_source_of_filed_line.o t_trace_data_send_recv.o t_broadcast_trace_data.o t_tracing_data.o t_local_fline.o t_ucd_data.o t_control_data_flines.o set_fline_control.o m_work_time.o trace_particle.o + $(F90) -c $(F90OPTFLAGS) $< +multi_tracer_fieldline.o: $(FIELDLINE_DIR)/multi_tracer_fieldline.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o t_time_data.o t_mesh_data.o t_phys_data.o t_parallel_surface_indices.o t_control_params_4_fline.o t_source_of_filed_line.o t_trace_data_send_recv.o t_broadcast_trace_data.o t_tracing_data.o t_local_fline.o t_IO_step_parameter.o t_ucd_data.o m_connect_hexa_2_tetra.o t_find_interpolate_in_ele.o set_fline_control.o set_fline_seeds_from_list.o set_fields_for_fieldline.o const_field_lines.o collect_fline_data.o parallel_ucd_IO_select.o + $(F90) -c $(F90OPTFLAGS) $< +multi_tracer_file_IO.o: $(FIELDLINE_DIR)/multi_tracer_file_IO.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o t_time_data.o t_mesh_data.o t_phys_data.o t_parallel_surface_indices.o t_control_params_4_fline.o t_source_of_filed_line.o t_trace_data_send_recv.o t_broadcast_trace_data.o t_tracing_data.o t_local_fline.o t_IO_step_parameter.o t_ucd_data.o tracer_restart_file_IO.o trace_particle.o t_mesh_SR.o collect_fline_data.o parallel_ucd_IO_select.o set_fields_for_fieldline.o set_fline_seeds_from_list.o + $(F90) -c $(F90OPTFLAGS) $< +particle_MPI_IO_select.o: $(FIELDLINE_DIR)/particle_MPI_IO_select.F90 m_precision.o calypso_mpi.o m_file_format_switch.o t_file_IO_parameter.o t_mesh_data.o t_time_data.o particle_file_IO_select.o MPI_particle_file_IO.o MPI_particle_file_IO_b.o mesh_file_name_by_param.o element_mesh_IO_select.o gz_MPI_particle_file_IO.o gz_MPI_particle_file_IO_b.o set_element_mesh_file_names.o + $(F90) -c $(F90OPTFLAGS) $(F90CPPFLAGS) $< +particle_file_IO.o: $(FIELDLINE_DIR)/particle_file_IO.f90 m_precision.o m_machine_parameter.o m_file_format_switch.o t_read_mesh_data.o set_mesh_file_names.o t_time_data.o m_fem_mesh_labels.o mesh_data_IO.o time_data_IO.o local_fline_restart_IO.o + $(F90) -c $(F90OPTFLAGS) $< +particle_file_IO_b.o: $(FIELDLINE_DIR)/particle_file_IO_b.f90 m_precision.o m_machine_parameter.o m_file_format_switch.o t_read_mesh_data.o t_binary_IO_buffer.o t_time_data.o set_mesh_file_names.o binary_IO.o domain_data_IO_b.o node_geometry_IO_b.o element_connect_IO_b.o field_data_IO_b.o + $(F90) -c $(F90OPTFLAGS) $< +particle_file_IO_select.o: $(FIELDLINE_DIR)/particle_file_IO_select.F90 m_precision.o t_file_IO_parameter.o t_mesh_data.o m_file_format_switch.o mesh_file_name_by_param.o particle_file_IO.o particle_file_IO_b.o gz_particle_file_IO.o gz_particle_file_IO_b.o set_parallel_file_name.o set_sph_extensions.o set_element_mesh_file_names.o + $(F90) -c $(F90OPTFLAGS) $(F90CPPFLAGS) $< +set_control_each_fline.o: $(FIELDLINE_DIR)/set_control_each_fline.f90 m_precision.o calypso_mpi.o m_constants.o m_error_IDs.o m_machine_parameter.o t_control_params_4_fline.o t_ctl_data_field_line.o t_geometry_data.o t_group_data.o set_area_4_viz.o set_field_comp_for_viz.o set_fields_for_fieldline.o m_field_file_format.o m_control_fline_flags.o t_source_of_filed_line.o set_control_platform_data.o set_isosurface_file_ctl.o skip_comment_f.o delete_data_files.o set_components_flags.o coordinate_converter.o + $(F90) -c $(F90OPTFLAGS) $< +set_control_fline_seeds.o: $(FIELDLINE_DIR)/set_control_fline_seeds.f90 m_precision.o calypso_mpi.o m_constants.o m_error_IDs.o m_machine_parameter.o t_control_params_4_fline.o t_fline_seeds_list_ctl.o coordinate_converter.o + $(F90) -c $(F90OPTFLAGS) $< +set_fields_after_tracing.o: $(FIELDLINE_DIR)/set_fields_after_tracing.f90 m_precision.o m_constants.o m_geometry_constants.o calypso_mpi.o t_geometry_data.o t_surface_data.o t_phys_data.o t_ctl_params_viz_fields.o tracer_field_interpolate.o coordinate_converter.o convert_components_4_viz.o cal_field_on_surf_viz.o + $(F90) -c $(F90OPTFLAGS) $< +set_fields_for_fieldline.o: $(FIELDLINE_DIR)/set_fields_for_fieldline.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o t_phys_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_parallel_surface_indices.o t_control_params_4_fline.o t_source_of_filed_line.o t_tracing_data.o t_mesh_data.o start_surface_by_gl_table.o start_surface_by_flux.o start_surface_by_volume.o start_surface_4_fline.o + $(F90) -c $(F90OPTFLAGS) $< +set_fline_control.o: $(FIELDLINE_DIR)/set_fline_control.f90 m_precision.o m_machine_parameter.o t_mesh_data.o t_geometry_data.o t_group_data.o t_phys_data.o t_control_params_4_fline.o t_control_data_flines.o set_control_each_fline.o set_iflag_for_used_ele.o set_control_fline_seeds.o + $(F90) -c $(F90OPTFLAGS) $< +set_fline_seed_from_tracer.o: $(FIELDLINE_DIR)/set_fline_seed_from_tracer.f90 m_precision.o m_geometry_constants.o t_geometry_data.o t_phys_data.o t_file_IO_parameter.o t_control_params_4_fline.o t_tracing_data.o t_ctl_params_viz_fields.o set_fline_seeds_from_list.o + $(F90) -c $(F90OPTFLAGS) $< +set_fline_seeds_from_list.o: $(FIELDLINE_DIR)/set_fline_seeds_from_list.f90 m_precision.o calypso_mpi.o m_machine_parameter.o m_geometry_constants.o t_geometry_data.o t_phys_data.o t_control_params_4_fline.o t_source_of_filed_line.o t_tracing_data.o calypso_mpi_int.o t_control_data_flines.o t_find_interpolate_in_ele.o set_fline_control.o quicksort.o sel_interpolate_scalar.o extend_field_line.o trace_in_element.o tracer_field_interpolate.o + $(F90) -c $(F90OPTFLAGS) $< +set_fline_start_surface.o: $(FIELDLINE_DIR)/set_fline_start_surface.f90 m_precision.o m_geometry_constants.o t_geometry_data.o t_surface_data.o t_tracing_data.o calypso_mpi.o m_constants.o t_phys_data.o t_control_params_4_fline.o t_source_of_filed_line.o cal_field_on_surf_viz.o trace_in_element.o tracer_field_interpolate.o + $(F90) -c $(F90OPTFLAGS) $< +set_iflag_for_used_ele.o: $(FIELDLINE_DIR)/set_iflag_for_used_ele.f90 m_precision.o t_geometry_data.o t_group_data.o + $(F90) -c $(F90OPTFLAGS) $< +start_surface_4_fline.o: $(FIELDLINE_DIR)/start_surface_4_fline.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o t_phys_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_control_params_4_fline.o t_source_of_filed_line.o t_tracing_data.o calypso_mpi_int.o extend_field_line.o cal_field_on_surf_viz.o set_fline_start_surface.o + $(F90) -c $(F90OPTFLAGS) $< +start_surface_by_flux.o: $(FIELDLINE_DIR)/start_surface_by_flux.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o t_phys_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_control_params_4_fline.o t_source_of_filed_line.o t_tracing_data.o t_fline_seeds_surf_group.o calypso_mpi_real.o extend_field_line.o cal_field_on_surf_viz.o set_fline_start_surface.o + $(F90) -c $(F90OPTFLAGS) $< +start_surface_by_gl_table.o: $(FIELDLINE_DIR)/start_surface_by_gl_table.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o t_geometry_data.o t_group_data.o t_control_params_4_fline.o t_source_of_filed_line.o extend_field_line.o cal_field_on_surf_viz.o set_fline_start_surface.o + $(F90) -c $(F90OPTFLAGS) $< +start_surface_by_volume.o: $(FIELDLINE_DIR)/start_surface_by_volume.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o t_phys_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_control_params_4_fline.o t_fline_seeds_ele_group.o t_source_of_filed_line.o t_tracing_data.o calypso_mpi_real.o extend_field_line.o cal_field_on_surf_viz.o set_fline_start_surface.o + $(F90) -c $(F90OPTFLAGS) $< +t_broadcast_trace_data.o: $(FIELDLINE_DIR)/t_broadcast_trace_data.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o t_comm_table.o t_para_double_numbering.o t_control_params_4_fline.o t_ctl_params_viz_fields.o t_tracing_data.o calypso_mpi_real.o calypso_mpi_int.o calypso_mpi_int8.o transfer_to_long_integers.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_data_flines.o: $(FIELDLINE_DIR)/t_control_data_flines.f90 m_precision.o m_constants.o m_machine_parameter.o t_ctl_data_field_line.o ctl_data_field_line_IO.o t_control_array_character3.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_data_tracers.o: $(FIELDLINE_DIR)/t_control_data_tracers.f90 m_precision.o m_machine_parameter.o t_control_data_flines.o t_control_array_character.o t_control_array_real.o t_control_array_integer.o t_control_array_character3.o t_read_control_elements.o ctl_file_fieldlines_IO.o skip_comment_f.o write_control_elements.o t_ctl_data_4_time_steps.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_params_4_fline.o: $(FIELDLINE_DIR)/t_control_params_4_fline.f90 m_precision.o t_file_IO_parameter.o t_ctl_params_viz_fields.o t_geometry_data.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_field_line.o: $(FIELDLINE_DIR)/t_ctl_data_field_line.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_integer.o t_control_array_character.o t_control_array_real.o t_control_array_character2.o t_fline_seeds_list_ctl.o skip_comment_f.o t_control_array_character3.o add_nodal_fields_ctl.o + $(F90) -c $(F90OPTFLAGS) $< +t_fieldline.o: $(FIELDLINE_DIR)/t_fieldline.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o m_work_time.o t_time_data.o t_mesh_data.o t_phys_data.o t_parallel_surface_indices.o t_control_params_4_fline.o t_source_of_filed_line.o t_trace_data_send_recv.o t_broadcast_trace_data.o t_tracing_data.o t_local_fline.o t_ucd_data.o t_particle_trace.o calypso_mpi.o calypso_mpi_int.o m_connect_hexa_2_tetra.o t_control_data_flines.o multi_tracer_fieldline.o const_field_lines.o multi_tracer_file_IO.o t_mesh_SR.o set_fline_control.o set_fline_seed_from_tracer.o set_fline_seeds_from_list.o set_fields_for_fieldline.o + $(F90) -c $(F90OPTFLAGS) $< +t_fline_seeds_ele_group.o: $(FIELDLINE_DIR)/t_fline_seeds_ele_group.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o t_phys_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_control_params_4_fline.o t_source_of_filed_line.o t_tracing_data.o convert_components_4_viz.o + $(F90) -c $(F90OPTFLAGS) $< +t_fline_seeds_list_ctl.o: $(FIELDLINE_DIR)/t_fline_seeds_list_ctl.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_integer2.o t_control_array_real3.o calypso_mpi.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_fline_seeds_surf_group.o: $(FIELDLINE_DIR)/t_fline_seeds_surf_group.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o t_phys_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_control_params_4_fline.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +t_local_fline.o: $(FIELDLINE_DIR)/t_local_fline.f90 m_precision.o m_constants.o t_ctl_params_viz_fields.o + $(F90) -c $(F90OPTFLAGS) $< +t_particle_trace.o: $(FIELDLINE_DIR)/t_particle_trace.f90 m_precision.o m_machine_parameter.o m_geometry_constants.o m_work_time.o t_time_data.o t_mesh_data.o t_phys_data.o t_parallel_surface_indices.o t_control_params_4_fline.o t_source_of_filed_line.o t_trace_data_send_recv.o t_broadcast_trace_data.o t_tracing_data.o t_local_fline.o t_ucd_data.o t_control_data_flines.o m_connect_hexa_2_tetra.o multi_tracer_fieldline.o multi_tracer_file_IO.o multi_trace_particle.o t_mesh_SR.o set_fields_for_fieldline.o trace_particle.o collect_fline_data.o parallel_ucd_IO_select.o set_fline_seeds_from_list.o + $(F90) -c $(F90OPTFLAGS) $< +t_source_of_filed_line.o: $(FIELDLINE_DIR)/t_source_of_filed_line.f90 m_precision.o m_constants.o t_control_params_4_fline.o + $(F90) -c $(F90OPTFLAGS) $< +t_trace_data_send_recv.o: $(FIELDLINE_DIR)/t_trace_data_send_recv.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o t_geometry_data.o t_surface_data.o t_comm_table.o t_para_double_numbering.o t_control_params_4_fline.o t_ctl_params_viz_fields.o calypso_SR.o calypso_SR_core.o set_to_send_buffer.o solver_SR_int.o solver_SR_int8.o select_copy_from_recv.o t_solver_SR.o t_tracing_data.o calypso_mpi_int.o + $(F90) -c $(F90OPTFLAGS) $< +t_tracing_data.o: $(FIELDLINE_DIR)/t_tracing_data.f90 m_precision.o m_constants.o t_control_params_4_fline.o t_ctl_params_viz_fields.o + $(F90) -c $(F90OPTFLAGS) $< +trace_in_element.o: $(FIELDLINE_DIR)/trace_in_element.f90 m_precision.o m_constants.o m_geometry_constants.o calypso_mpi.o t_geometry_data.o t_surface_data.o t_phys_data.o t_ctl_params_viz_fields.o t_parallel_surface_indices.o cal_fline_in_cube.o set_fields_after_tracing.o + $(F90) -c $(F90OPTFLAGS) $< +trace_particle.o: $(FIELDLINE_DIR)/trace_particle.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o m_work_time.o t_time_data.o t_mesh_data.o t_phys_data.o t_parallel_surface_indices.o t_tracing_data.o t_control_params_4_fline.o t_source_of_filed_line.o t_trace_data_send_recv.o t_broadcast_trace_data.o t_mesh_SR.o t_local_fline.o transfer_to_long_integers.o trace_particle_in_element.o set_fline_seeds_from_list.o copy_field_smp.o calypso_mpi_int.o + $(F90) -c $(F90OPTFLAGS) $< +trace_particle_in_element.o: $(FIELDLINE_DIR)/trace_particle_in_element.f90 m_precision.o m_constants.o m_geometry_constants.o calypso_mpi.o t_geometry_data.o t_surface_data.o t_parallel_surface_indices.o t_phys_data.o t_ctl_params_viz_fields.o t_local_fline.o t_control_params_4_fline.o trace_in_element.o set_fields_after_tracing.o coordinate_converter.o convert_components_4_viz.o cal_field_on_surf_viz.o cal_fline_in_cube.o tracer_field_interpolate.o + $(F90) -c $(F90OPTFLAGS) $< +tracer_field_interpolate.o: $(FIELDLINE_DIR)/tracer_field_interpolate.f90 m_precision.o m_constants.o m_geometry_constants.o calypso_mpi.o t_geometry_data.o t_surface_data.o t_phys_data.o t_ctl_params_viz_fields.o coordinate_converter.o convert_components_4_viz.o cal_field_on_surf_viz.o sel_interpolate_scalar.o + $(F90) -c $(F90OPTFLAGS) $< +tracer_restart_file_IO.o: $(FIELDLINE_DIR)/tracer_restart_file_IO.f90 m_precision.o t_time_data.o t_file_IO_parameter.o t_IO_step_parameter.o t_ctl_params_viz_fields.o t_local_fline.o t_read_mesh_data.o t_field_data_IO.o set_sph_restart_IO.o field_IO_select.o local_fline_restart_IO.o particle_MPI_IO_select.o const_global_element_ids.o + $(F90) -c $(F90OPTFLAGS) $< + diff --git a/src/Fortran_libraries/VIZ_src/fieldline/bcast_control_data_tracers.f90 b/src/Fortran_libraries/VIZ_src/fieldline/bcast_control_data_tracers.f90 new file mode 100644 index 00000000..afa3e06e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/bcast_control_data_tracers.f90 @@ -0,0 +1,53 @@ +!>@file bcast_control_data_tracers.f90 +!!@brief module bcast_control_data_tracers +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Control data structure for visualization controls +!! +!!@verbatim +!! subroutine bcast_tracer_controls(viz_ctls) +!! type(tracers_control), intent(inout) :: tracer_ctls +!!@endverbatim + module bcast_control_data_tracers +! + use m_precision +! + use m_machine_parameter + use t_control_data_tracers + use calypso_mpi +! + implicit none +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine bcast_tracer_controls(tracer_ctls) +! + use transfer_to_long_integers + use calypso_mpi_char + use calypso_mpi_int + use bcast_control_arrays + use bcast_ctl_data_field_line +! + type(tracers_control), intent(inout) :: tracer_ctls +! +! + call bcast_files_4_fline_ctl(tracer_ctls%tracer_controls) +! + call bcast_ctl_type_r1(tracer_ctls%delta_t_tracer_out_ctl) + call bcast_ctl_type_i1(tracer_ctls%i_step_tracer_out_ctl) +! + call calypso_mpi_bcast_character & + & (tracer_ctls%block_name, cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(tracer_ctls%i_tracers_control, 0) +! + end subroutine bcast_tracer_controls +! +! --------------------------------------------------------------------- +! + end module bcast_control_data_tracers diff --git a/src/Fortran_libraries/VIZ_src/fieldline/bcast_ctl_data_field_line.f90 b/src/Fortran_libraries/VIZ_src/fieldline/bcast_ctl_data_field_line.f90 new file mode 100644 index 00000000..48c42ed3 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/bcast_ctl_data_field_line.f90 @@ -0,0 +1,137 @@ +!>@file bcast_ctl_data_field_line.f90 +!!@brief module bcast_ctl_data_field_line +!! +!!@date Programmed by H.Matsui in May, 2006 +! +!>@brief control data for each field line +!! +!!@verbatim +!! subroutine bcast_files_4_fline_ctl(fline_ctls) +!! type(fieldline_controls), intent(inout) :: fline_ctls +!! subroutine bcast_field_line_ctl(fln) +!! type(fline_ctl), intent(inout) :: fln +!!@endverbatim +! + module bcast_ctl_data_field_line +! + use m_precision +! + use m_machine_parameter + use calypso_mpi +! + implicit none +! + private :: bcast_field_line_ctl + private :: bcast_fline_seeds_list_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine bcast_files_4_fline_ctl(fline_ctls) +! + use t_control_data_flines + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(fieldline_controls), intent(inout) :: fline_ctls + integer (kind=kint) :: i_fline +! +! + call calypso_mpi_bcast_character(fline_ctls%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(fline_ctls%num_fline_ctl, 0) + if(fline_ctls%num_fline_ctl .le. 0) return +! + if(my_rank .gt. 0) call alloc_fline_ctl_struct(fline_ctls) +! + call calypso_mpi_bcast_character(fline_ctls%fname_fline_ctl, & + & cast_long(kchara*fline_ctls%num_fline_ctl), 0) + do i_fline = 1, fline_ctls%num_fline_ctl + call bcast_field_line_ctl(fline_ctls%fline_ctl_struct(i_fline)) + end do +! + end subroutine bcast_files_4_fline_ctl +! +! -------------------------------------------------------------------- +! + subroutine bcast_field_line_ctl(fln) +! + use t_ctl_data_field_line + use transfer_to_long_integers + use calypso_mpi_char + use calypso_mpi_int + use bcast_control_arrays +! + type(fline_ctl), intent(inout) :: fln +! +! + call calypso_mpi_bcast_character(fln%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(fln%i_vr_fline_ctl, 0) +! + call bcast_ctl_array_c1(fln%fline_area_grp_ctl) +! + call bcast_fline_seeds_list_ctl(fln%seeds_ctl) +! + call bcast_ctl_type_c1(fln%fline_file_head_ctl) + call bcast_ctl_type_c1(fln%fline_output_type_ctl) +! + call bcast_ctl_type_c1(fln%fline_rst_prefix_ctl) + call bcast_ctl_type_c1(fln%fline_rst_format_ctl) +! + call bcast_ctl_type_c1(fln%fline_field_ctl) + call bcast_ctl_type_c1(fln%fline_color_field_ctl) + call bcast_ctl_type_c1(fln%fline_color_comp_ctl) + call bcast_ctl_type_c1(fln%starting_type_ctl) + call bcast_ctl_type_c1(fln%fline_comm_mode_ctl) +! + call bcast_ctl_type_c1(fln%seed_surf_grp_ctl) + call bcast_ctl_type_c1(fln%seed_ele_grp_ctl) +! + call bcast_ctl_type_c1(fln%seed_ref_field_ctl) + call bcast_ctl_type_c1(fln%seed_ref_comp_ctl) +! + call bcast_ctl_type_c1(fln%seed_file_prefix_ctl) +! + call bcast_ctl_type_c1(fln%selection_type_ctl) + call bcast_ctl_type_c1(fln%line_direction_ctl) + call bcast_ctl_array_c2(fln%fline_field_output_ctl) +! + call bcast_ctl_type_i1(fln%num_fieldline_ctl) + call bcast_ctl_type_i1(fln%max_line_stepping_ctl) + call bcast_ctl_type_r1(fln%max_trace_length_ctl) +! + end subroutine bcast_field_line_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_fline_seeds_list_ctl(seeds_ctl) +! + use t_ctl_data_field_line + use transfer_to_long_integers + use calypso_mpi_char + use calypso_mpi_int + use bcast_control_arrays +! + type(fline_seeds_list_ctl), intent(inout) :: seeds_ctl +! +! + call calypso_mpi_bcast_character(seeds_ctl%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(seeds_ctl%i_seeds_list_ctl, 0) +! + call bcast_ctl_array_r3(seeds_ctl%seed_point_ctl) + call bcast_ctl_array_r3(seeds_ctl%seed_geological_ctl) + call bcast_ctl_array_r3(seeds_ctl%seed_spherical_ctl) +! + call bcast_ctl_array_i2(seeds_ctl%seed_surface_ctl) +! + end subroutine bcast_fline_seeds_list_ctl +! +! --------------------------------------------------------------------- +! + end module bcast_ctl_data_field_line diff --git a/src/Fortran_libraries/VIZ_src/fieldline/cal_field_on_surf_viz.f90 b/src/Fortran_libraries/VIZ_src/fieldline/cal_field_on_surf_viz.f90 new file mode 100644 index 00000000..df8427f5 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/cal_field_on_surf_viz.f90 @@ -0,0 +1,178 @@ +!>@file cal_field_on_surf_viz.f90 +!! module cal_field_on_surf_viz +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief easy field evaluation on surface by linear interpolation +!! +!!@verbatim +!! subroutine element_ave_4_viz(nnod, nele, ie, v_nod, s_nod, & +!! & iele, v_ave, s_ave) +!! +!! subroutine cal_field_on_surf_vect4(nnod, nsurf, nnod_sf, & +!! & ie_surf, isurf, xi, v_nod, v4_tgt) +!! subroutine cal_field_on_surf_vector(nnod, nsurf, nnod_sf, & +!! & ie_surf, isurf, xi, v_nod, v_tgt) +!! subroutine cal_field_on_surf_scalar(nnod, nsurf, nnod_sf, & +!! & ie_surf, isurf, xi, s_nod, s_tgt) +!! +!! subroutine cal_surf_field_value_2d(nd, xi, fd, ft) +!! integer(kind = kint), intent(in) :: nd +!! real(kind = kreal), intent(in) :: xi(2) +!! real(kind = kreal), intent(in) :: fd(nd,4) +!! real(kind = kreal), intent(inout) :: ft(nd) +!!@endverbatim +! + module cal_field_on_surf_viz +! + use m_precision + use m_constants +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine element_ave_4_viz(nnod, nele, ie, v_nod, s_nod, & + & iele, v_ave, s_ave) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: nele, nnod + integer(kind = kint), intent(in) :: ie(nele,num_t_linear) + real(kind = kreal), intent(in) :: v_nod(nnod,3), s_nod(nnod) + integer(kind = kint), intent(in) :: iele +! + real(kind = kreal), intent(inout) :: v_ave(3), s_ave +! + integer(kind = kint) :: k1, inod + real(kind = kreal) :: v_ele(3,num_t_linear), s_ele(num_t_linear) +! +! + do k1 = 1, num_t_linear + inod = ie(iele,k1) + v_ele(1,k1) = v_nod(inod,1) + v_ele(2,k1) = v_nod(inod,2) + v_ele(3,k1) = v_nod(inod,3) + s_ele(k1) = s_nod(inod) + end do +! + v_ave(1) = (v_ele(1,1) + v_ele(1,2) + v_ele(1,3) + v_ele(1,4) & + & + v_ele(1,5) + v_ele(1,6) + v_ele(1,7) + v_ele(1,8)) & + & * r125 + v_ave(2) = (v_ele(2,1) + v_ele(2,2) + v_ele(2,3) + v_ele(2,4) & + & + v_ele(2,5) + v_ele(2,6) + v_ele(2,7) + v_ele(2,8)) & + & * r125 + v_ave(3) = (v_ele(3,1) + v_ele(3,2) + v_ele(3,3) + v_ele(3,4) & + & + v_ele(3,5) + v_ele(3,6) + v_ele(3,7) + v_ele(3,8)) & + & * r125 + s_ave = (s_ele(1) + s_ele(2) + s_ele(3) + s_ele(4) & + & + s_ele(5) + s_ele(6) + s_ele(7) + s_ele(8)) * r125 +! + end subroutine element_ave_4_viz +! +! --------------------------------------------------------------------- +! + subroutine cal_field_on_surf_vect4(nnod, nsurf, nnod_sf, & + & ie_surf, isurf, xi, v_nod, v4_tgt) +! + integer(kind = kint), intent(in) :: isurf + integer(kind = kint), intent(in) :: nnod, nsurf, nnod_sf + integer(kind = kint), intent(in) :: ie_surf(nsurf,nnod_sf) + real(kind = kreal), intent(in) :: xi(2) + real(kind = kreal), intent(in) :: v_nod(nnod,3) + real(kind = kreal), intent(inout) :: v4_tgt(4) +! + real(kind = kreal) :: fd(4,4) + integer(kind = kint) :: k1, inod +! +! + do k1 = 1, 4 + inod = ie_surf(isurf,k1) + fd(1:3,k1) = v_nod(inod,1:3) + fd(4,k1) = one + end do +! + call cal_surf_field_value_2d(ifour, xi, fd, v4_tgt(1)) +! + end subroutine cal_field_on_surf_vect4 +! +! --------------------------------------------------------------------- +! + subroutine cal_field_on_surf_vector(nnod, nsurf, nnod_sf, & + & ie_surf, isurf, xi, v_nod, v_tgt) +! + integer(kind = kint), intent(in) :: isurf + integer(kind = kint), intent(in) :: nnod, nsurf, nnod_sf + integer(kind = kint), intent(in) :: ie_surf(nsurf,nnod_sf) + real(kind = kreal), intent(in) :: xi(2) + real(kind = kreal), intent(in) :: v_nod(nnod,3) + real(kind = kreal), intent(inout) :: v_tgt(3) +! + real(kind = kreal) :: fd(3,4) + integer(kind = kint) :: k1, inod +! +! + do k1 = 1, 4 + inod = ie_surf(isurf,k1) + fd(1:3,k1) = v_nod(inod,1:3) + end do +! + call cal_surf_field_value_2d(ithree, xi, fd, v_tgt) +! + end subroutine cal_field_on_surf_vector +! +! --------------------------------------------------------------------- +! + subroutine cal_field_on_surf_scalar(nnod, nsurf, nnod_sf, & + & ie_surf, isurf, xi, s_nod, s_tgt) +! + integer(kind = kint), intent(in) :: isurf + integer(kind = kint), intent(in) :: nnod, nsurf, nnod_sf + integer(kind = kint), intent(in) :: ie_surf(nsurf,nnod_sf) + real(kind = kreal), intent(in) :: s_nod(nnod) + real(kind = kreal), intent(in) :: xi(2) + real(kind = kreal), intent(inout) :: s_tgt(1) +! + real(kind = kreal) :: fd(4) + integer(kind = kint) :: k1, inod +! +! + do k1 = 1, 4 + inod = ie_surf(isurf,k1) + fd(k1) = s_nod(inod) + end do +! + call cal_surf_field_value_2d(ione, xi, fd(1), s_tgt(1)) +! + end subroutine cal_field_on_surf_scalar +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine cal_surf_field_value_2d(nd, xi, fd, ft) +! + integer(kind = kint), intent(in) :: nd + real(kind = kreal), intent(in) :: xi(2) + real(kind = kreal), intent(in) :: fd(nd,4) + real(kind = kreal), intent(inout) :: ft(nd) +! + real(kind = kreal) :: an(4) +! + an(1) = half*half * (one-xi(1)) * (one-xi(2)) + an(2) = half*half * (one+xi(1)) * (one-xi(2)) + an(3) = half*half * (one+xi(1)) * (one+xi(2)) + an(4) = half*half * (one-xi(1)) * (one+xi(2)) +! + ft(1:nd) = (an(1)*fd(1:nd,1) + an(2)*fd(1:nd,2) & + & + an(3)*fd(1:nd,3) + an(4)*fd(1:nd,4)) +! + end subroutine cal_surf_field_value_2d +! +! --------------------------------------------------------------------- +! + end module cal_field_on_surf_viz diff --git a/src/Fortran_libraries/VIZ_src/fieldline/cal_fline_in_cube.f90 b/src/Fortran_libraries/VIZ_src/fieldline/cal_fline_in_cube.f90 new file mode 100644 index 00000000..2c231eaa --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/cal_fline_in_cube.f90 @@ -0,0 +1,373 @@ +!>@file cal_fline_in_cube.f90 +!! module cal_fline_in_cube +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief trace field line in one cube element +!! +!!@verbatim +!! subroutine vector_at_each_element(iele, node, ele, v_trace, & +!! & v4_ele) +!! integer(kind = kint), intent(in) :: iele +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! real(kind = kreal), intent(in) :: v_trace(node%numnod,3) +!! real(kind = kreal), intent(inout) :: v4_ele(4,ele%nnod_4_ele) +!! subroutine position_on_each_ele_surfs & +!! & (surf, numnod, xx, iele, xx4_ele_surf) +!! subroutine position_on_each_ele_sfs_wone & +!! & (surf, numnod, xx, iele, xx4_ele_surf) +!! type(surface_data), intent(in) :: surf +!! integer(kind = kint), intent(in) :: numnod +!! real(kind = kreal), intent(in) :: xx(numnod,3) +!! integer(kind = kint), intent(in) :: iele, isf_org +!! real(kind = kreal), intent(inout) & +!! & :: xx4_ele_surf(4,num_linear_sf,nsurf_4_ele) +!! +!! subroutine find_line_end_in_ele_8(iflag_dir, isf_org, & +!! & nnod_4_ele, nnod_4_surf, node_on_sf, fline, & +!! & x0, xx4_ele, isf_tgt, x4_tgt, xi) +!! integer(kind = kint), intent(in) :: iflag_dir +!! integer(kind = kint), intent(in) :: isf_org +!! integer(kind = kint), intent(in) :: nnod_4_ele, nnod_4_surf +!! integer(kind = kint), intent(in) & +!! & :: node_on_sf(nnod_4_surf,nsurf_4_ele) +!! real(kind = kreal), intent(in) :: fline(4), x0(4) +!! real(kind = kreal), intent(in) :: xx4_ele(4,nnod_4_ele) +!! integer(kind = kint), intent(inout) :: isf_tgt +!! real(kind = kreal), intent(inout) :: x4_tgt(4) +!! real(kind = kreal), intent(inout) :: xi(2) +!! subroutine find_line_end_in_1ele(iflag_dir, isf_org, fline, x0, & +!! & xx4_ele_surf, isf_tgt, x4_tgt, xi) +!! integer(kind = kint), intent(in) :: iflag_dir +!! integer(kind = kint), intent(in) :: isf_org +!! real(kind = kreal), intent(in) :: fline(4), x0(4) +!! real(kind = kreal), intent(in) & +!! & :: xx4_ele_surf(4,num_linear_sf,nsurf_4_ele) +!! integer(kind = kint), intent(inout) :: isf_tgt +!! real(kind = kreal), intent(inout) :: x4_tgt(4) +!! real(kind = kreal), intent(inout) :: xi(2) +!! +!! subroutine cal_fline_to_square(x0, vec, x_quad, x_tgt, ierr) +!! subroutine cal_filne_to_triangle(x0, vec, x_tri, x_tgt, ierr) +!!@endverbatim +! + module cal_fline_in_cube +! + use m_precision +! + use m_constants + use m_geometry_constants + use t_geometry_data + use t_surface_data +! +! + implicit none +! + integer(kind = kint), parameter :: iflag_forward_line = 1 + integer(kind = kint), parameter :: iflag_backward_line = -1 +! + private :: cal_fline_to_square, cal_filne_to_triangle +! +!------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------ +! + subroutine vector_at_each_element(iele, node, ele, v_trace, & + & v4_ele) +! + integer(kind = kint), intent(in) :: iele + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + real(kind = kreal), intent(in) :: v_trace(node%numnod,3) +! + real(kind = kreal), intent(inout) :: v4_ele(4,ele%nnod_4_ele) +! + integer(kind = kint) :: k1, inod +! + do k1 = 1, ele%nnod_4_ele + inod = ele%ie(iele,k1) + v4_ele(1:3,k1) = v_trace(inod,1:3) + v4_ele(4,k1) = one + end do +! + end subroutine vector_at_each_element +! +! --------------------------------------------------------------------- +! + subroutine position_on_each_ele_surfs & + & (surf, numnod, xx, iele, xx4_ele_surf) +! + type(surface_data), intent(in) :: surf + integer(kind = kint), intent(in) :: numnod + real(kind = kreal), intent(in) :: xx(numnod,3) + integer(kind = kint), intent(in) :: iele +! + real(kind = kreal), intent(inout) & + & :: xx4_ele_surf(4,num_linear_sf,nsurf_4_ele) +! + integer(kind = kint) :: ksf, k2 + integer(kind = kint) :: inod, isurf +! +! + do ksf = 1, nsurf_4_ele + isurf = abs(surf%isf_4_ele(iele,ksf)) + do k2 = 1, num_linear_sf + inod = surf%ie_surf(isurf,k2) + xx4_ele_surf(1,k2,ksf) = xx(inod,1) + xx4_ele_surf(2,k2,ksf) = xx(inod,2) + xx4_ele_surf(3,k2,ksf) = xx(inod,3) + xx4_ele_surf(4,k2,ksf) = zero + end do + end do +! + end subroutine position_on_each_ele_surfs +! +!------------------------------------------------------------------ +! + subroutine position_on_each_ele_sfs_wone & + & (surf, numnod, xx, iele, xx4_ele_surf) +! + type(surface_data), intent(in) :: surf + integer(kind = kint), intent(in) :: numnod + real(kind = kreal), intent(in) :: xx(numnod,3) + integer(kind = kint), intent(in) :: iele +! + real(kind = kreal), intent(inout) & + & :: xx4_ele_surf(4,num_linear_sf,nsurf_4_ele) +! + integer(kind = kint) :: ksf, k2 + integer(kind = kint) :: inod, isurf +! +! + do ksf = 1, nsurf_4_ele + isurf = abs(surf%isf_4_ele(iele,ksf)) + do k2 = 1, num_linear_sf + inod = surf%ie_surf(isurf,k2) + xx4_ele_surf(1,k2,ksf) = xx(inod,1) + xx4_ele_surf(2,k2,ksf) = xx(inod,2) + xx4_ele_surf(3,k2,ksf) = xx(inod,3) + xx4_ele_surf(4,k2,ksf) = one + end do + end do +! + end subroutine position_on_each_ele_sfs_wone +! +!------------------------------------------------------------------ +! + subroutine find_line_end_in_ele_8(iflag_dir, isf_org, & + & nnod_4_ele, nnod_4_surf, node_on_sf, fline, & + & x0, xx4_ele, isf_tgt, x4_tgt, xi) +! + integer(kind = kint), intent(in) :: iflag_dir + integer(kind = kint), intent(in) :: isf_org + integer(kind = kint), intent(in) :: nnod_4_ele, nnod_4_surf + integer(kind = kint), intent(in) & + & :: node_on_sf(nnod_4_surf,nsurf_4_ele) + real(kind = kreal), intent(in) :: fline(4), x0(4) + real(kind = kreal), intent(in) :: xx4_ele(4,nnod_4_ele) +! + integer(kind = kint), intent(inout) :: isf_tgt + real(kind = kreal), intent(inout) :: x4_tgt(4) + real(kind = kreal), intent(inout) :: xi(2) +! + real(kind = kreal) :: xx_surf(4,4), b_ray(4) + real(kind = kreal) :: quad_wk(4*(2+num_triangle)) + real(kind = kreal) :: tri_wk(4+3*3) + integer(kind = kint) :: inod(4) + integer(kind = kint) :: ierr + integer(kind = kint) :: ist, ied, inc, k, ksf +! +! + b_ray(1:4) = dble(iflag_dir) * fline(1:4) +! + if(isf_org .eq. 0) then + ist = 1 + ied = nsurf_4_ele + inc = 1 + else if(mod(isf_org,itwo) .eq. ione) then + ist = 1 + ied = nsurf_4_ele-1 + inc = 1 + else + ist = nsurf_4_ele-1 + ied = 1 + inc = -1 + end if +! + isf_tgt = izero + do k = ist, ied, inc + ksf = mod(isf_org+k-ione,nsurf_4_ele) + ione + inod(1:nnod_4_surf) = node_on_sf(1:nnod_4_surf,ksf) + xx_surf(1:4,1) = xx4_ele(1:4,inod(1)) + xx_surf(1:4,2) = xx4_ele(1:4,inod(2)) + xx_surf(1:4,3) = xx4_ele(1:4,inod(3)) + xx_surf(1:4,4) = xx4_ele(1:4,inod(4)) + call cal_fline_to_square(x0, b_ray, xx_surf, & + & x4_tgt, xi, quad_wk(9), quad_wk(1), tri_wk, ierr) + if(ierr.eq.zero) then + isf_tgt = ksf + exit + end if + end do +! + if(isf_tgt .gt. izero) return +! +! write(my_rank+60,'(i3,1p3e16.7)') (-ione), b_ray(1:4) +! write(my_rank+60,'(i3,1p3e16.7)') izero, x0(1:4) +! + do k = ist, ied, inc + ksf = mod(isf_org+k-ione,nsurf_4_ele) + ione + inod(1:nnod_4_surf) = node_on_sf(1:nnod_4_surf,ksf) + xx_surf(1:4,1) = xx4_ele(1:4,inod(1)) + xx_surf(1:4,2) = xx4_ele(1:4,inod(2)) + xx_surf(1:4,3) = xx4_ele(1:4,inod(3)) + xx_surf(1:4,4) = xx4_ele(1:4,inod(4)) + call cal_fline_to_square(x0, b_ray, xx_surf, & + & x4_tgt, xi, quad_wk(9), quad_wk(1), tri_wk, ierr) + end do +! + end subroutine find_line_end_in_ele_8 +! +!------------------------------------------------------------------ +! + subroutine find_line_end_in_1ele(iflag_dir, isf_org, fline, x0, & + & xx4_ele_surf, isf_tgt, x4_tgt, xi) +! + integer(kind = kint), intent(in) :: iflag_dir + integer(kind = kint), intent(in) :: isf_org + real(kind = kreal), intent(in) :: fline(4), x0(4) + real(kind = kreal), intent(in) & + & :: xx4_ele_surf(4,num_linear_sf,nsurf_4_ele) +! + integer(kind = kint), intent(inout) :: isf_tgt + real(kind = kreal), intent(inout) :: x4_tgt(4) + real(kind = kreal), intent(inout) :: xi(2) +! + real(kind = kreal) :: b_ray(4) + real(kind = kreal) :: quad_wk(4*(2+num_triangle)) + real(kind = kreal) :: tri_wk(4+3*3) + integer(kind = kint) :: ierr + integer(kind = kint) :: ist, ied, inc, k, ksf +! +! + b_ray(1:4) = dble(iflag_dir) * fline(1:4) +! + if(isf_org .eq. 0) then + ist = 1 + ied = nsurf_4_ele + inc = 1 + else if(mod(isf_org,itwo) .eq. ione) then + ist = 1 + ied = nsurf_4_ele-1 + inc = 1 + else + ist = nsurf_4_ele-1 + ied = 1 + inc = -1 + end if +! + isf_tgt = izero + do k = ist, ied, inc + ksf = mod(isf_org+k-ione,nsurf_4_ele) + ione + call cal_fline_to_square(x0, b_ray, xx4_ele_surf(1,1,ksf), & + & x4_tgt, xi, quad_wk(9), quad_wk(1), tri_wk, ierr) + if(ierr.eq.zero) then + isf_tgt = ksf + exit + end if + end do +! + if(isf_tgt .gt. izero) return +! +! write(my_rank+60,'(i3,1p3e16.7)') (-ione), b_ray(1:4) +! write(my_rank+60,'(i3,1p3e16.7)') izero, x0(1:4) +! + do k = ist, ied, inc + ksf = mod(isf_org+k-ione,nsurf_4_ele) + ione + call cal_fline_to_square(x0, b_ray, xx4_ele_surf(1,1,ksf), & + & x4_tgt, xi, quad_wk(9), quad_wk(1), tri_wk, ierr) + end do +! + end subroutine find_line_end_in_1ele +! +!------------------------------------------------------------------ +! + subroutine cal_fline_to_square(x0, vec, x_quad, x4_tgt, xi, & + & x4_tri, sol_q, tri_wk, ierr) +! + real(kind = kreal), intent(in) :: x_quad(4,num_linear_sf) + real(kind = kreal), intent(in) :: vec(4), x0(4) + real(kind = kreal), intent(inout) :: x4_tgt(4), xi(2) + real(kind = kreal), intent(inout) :: x4_tri(4,num_triangle) + real(kind = kreal), intent(inout) :: sol_q(4,2) + real(kind = kreal), intent(inout) :: tri_wk(4+3*3) + + integer(kind = kint), intent(inout) :: ierr +! + x4_tri(1:4,1) = x_quad(1:4,1) + x4_tri(1:4,2) = x_quad(1:4,2) + x4_tri(1:4,3) = x_quad(1:4,4) +! + call cal_filne_to_triangle(x0, vec, x4_tri, x4_tgt, & + & sol_q(1,1), tri_wk(1), tri_wk(5), ierr) +! + if(ierr .eq. izero) then + xi(1) = -one + two*sol_q(1,1) + xi(2) = -one + two*sol_q(2,1) + return + end if +! + x4_tri(1:4,1) = x_quad(1:4,3) + x4_tri(1:4,2) = x_quad(1:4,2) + x4_tri(1:4,3) = x_quad(1:4,4) +! + call cal_filne_to_triangle(x0, vec, x4_tri, x4_tgt, & + & sol_q(1,2), tri_wk(1), tri_wk(5), ierr) + if(ierr .eq. izero) then + xi(1) = one - two*sol_q(2,2) + xi(2) = one - two*sol_q(1,2) + end if +! + end subroutine cal_fline_to_square +! +!------------------------------------------------------------------ +! + subroutine cal_filne_to_triangle(x0, v, x4_tri, x4_tgt, sol, & + & rvec, mat, ierr) +! + use solver_33_array +! + real(kind = kreal), intent(in) :: x4_tri(4,num_triangle) + real(kind = kreal), intent(in) :: v(4), x0(4) + + real(kind = kreal), intent(inout) :: x4_tgt(4), sol(4) + real(kind = kreal), intent(inout) :: rvec(4) + real(kind = kreal), intent(inout) :: mat(3,3) + integer(kind = kint), intent(inout) :: ierr +! +! +! + rvec(1:4) = x0(1:4) - x4_tri(1:4,1) +! + mat(1:3,1) = x4_tri(1:3,2) - x4_tri(1:3,1) + mat(1:3,2) = x4_tri(1:3,3) - x4_tri(1:3,1) + mat(1:3,3) = -v(1:3) + call solve_33_array(sol(1), rvec(1), mat) +! + if(sol(3).gt.zero .and. sol(1).ge.zero .and. sol(2).ge.zero & + & .and. (sol(1)+sol(2)).le.one) then + x4_tgt(1:4) = x0(1:4) + sol(3) * v(1:4) + ierr = 0 + else + ierr = ione + end if +! + end subroutine cal_filne_to_triangle +! +! --------------------------------------------------------------------- +! + end module cal_fline_in_cube diff --git a/src/Fortran_libraries/VIZ_src/fieldline/collect_fline_data.f90 b/src/Fortran_libraries/VIZ_src/fieldline/collect_fline_data.f90 new file mode 100644 index 00000000..b3a61bcc --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/collect_fline_data.f90 @@ -0,0 +1,177 @@ +!>@file collect_fline_data.f90 +!!@brief module collect_fline_data +!! +!!@author H. Matsui +!!@date Programmed on Aug., 2011 +! +!> @brief MPI communication To collect field line data +!! +!!@verbatim +!! subroutine copy_local_fieldline_to_IO(viz_fields, fline_lc, ucd) +!! subroutine copy_local_particles_to_IO(viz_fields, fline_lc, ucd) +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! type(local_fieldline), intent(in) :: fline_lc +!! type(ucd_data), intent(inout) :: ucd +!!@endverbatim +! + module collect_fline_data +! + use m_precision +! + use calypso_mpi + use m_constants + use m_geometry_constants + use t_control_params_4_fline + use t_local_fline +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine copy_local_fieldline_to_IO(viz_fields, fline_lc, ucd) +! + use t_ucd_data + use const_global_element_ids +! + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(local_fieldline), intent(in) :: fline_lc +! + type(ucd_data), intent(inout) :: ucd +! + integer(kind = kint_gl) :: i, nd +! +! + ucd%nnod = fline_lc%nnod_line_l + ucd%nele = fline_lc%nele_line_l + ucd%nnod_4_ele = num_linear_edge +! + call alloc_merged_ucd_nod_stack(nprocs, ucd) + call alloc_merged_ucd_ele_stack(nprocs, ucd) + call count_number_of_node_stack(fline_lc%nnod_line_l, & + & ucd%istack_merged_nod) + call count_number_of_node_stack(fline_lc%nele_line_l, & + & ucd%istack_merged_ele) + write(*,*) 'ucd%istack_merged_nod', ucd%istack_merged_nod + write(*,*) 'ucd%istack_merged_ele', ucd%istack_merged_ele +! +!$omp parallel workshare + ucd%istack_merged_intnod(0:nprocs) & + & = ucd%istack_merged_nod(0:nprocs) +!$omp end parallel workshare +! + call allocate_ucd_node(ucd) +!$omp parallel do + do i = 1, ucd%nnod + ucd%inod_global(i) = fline_lc%iglobal_fline(i) + ucd%xx(i,1) = fline_lc%xx_line_l(1,i) + ucd%xx(i,2) = fline_lc%xx_line_l(2,i) + ucd%xx(i,3) = fline_lc%xx_line_l(3,i) + end do +!$omp end parallel do + + call allocate_ucd_ele(ucd) +!$omp parallel do + do i = 1, ucd%nele + ucd%iele_global(i) = i + ucd%istack_merged_ele(my_rank) + ucd%ie(i,1) = fline_lc%iedge_line_l(1,i) & + & + ucd%istack_merged_nod(my_rank) + ucd%ie(i,2) = fline_lc%iedge_line_l(2,i) & + & + ucd%istack_merged_nod(my_rank) + end do +!$omp end parallel do + + ucd%num_field = viz_fields%num_color_fields + call allocate_ucd_phys_name(ucd) +!$omp parallel workshare + ucd%phys_name(1:ucd%num_field) & + & = viz_fields%color_field_name(1:ucd%num_field) + ucd%num_comp(1:ucd%num_field) & + & = viz_fields%ncomp_color_field(1:ucd%num_field) +!$omp end parallel workshare + + ucd%ntot_comp = viz_fields%ntot_color_comp + call allocate_ucd_phys_data(ucd) + do nd = 1, ucd%ntot_comp +!$omp parallel workshare + ucd%d_ucd(1:ucd%nnod,nd) = fline_lc%col_line_l(nd,1:ucd%nnod) +!$omp end parallel workshare + end do +! + end subroutine copy_local_fieldline_to_IO +! +! --------------------------------------------------------------------- +! + subroutine copy_local_particles_to_IO(viz_fields, fline_lc, ucd) +! + use t_ucd_data + use t_source_of_filed_line + use const_global_element_ids +! + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(local_fieldline), intent(in) :: fline_lc +! + type(ucd_data), intent(inout) :: ucd +! + integer(kind = kint_gl) :: i, nd +! +! + ucd%nnod = fline_lc%nnod_line_l + ucd%nele = ucd%nnod + ucd%nnod_4_ele = num_linear_point +! + call alloc_merged_ucd_nod_stack(nprocs, ucd) + call alloc_merged_ucd_ele_stack(nprocs, ucd) + call count_number_of_node_stack(fline_lc%nnod_line_l, & + & ucd%istack_merged_nod) +! +!$omp parallel workshare + ucd%istack_merged_ele(0:nprocs) & + & = ucd%istack_merged_nod(0:nprocs) + ucd%istack_merged_intnod(0:nprocs) & + & = ucd%istack_merged_nod(0:nprocs) +!$omp end parallel workshare +! + call allocate_ucd_node(ucd) +!$omp parallel do + do i = 1, ucd%nnod + ucd%inod_global(i) = fline_lc%iglobal_fline(i) + ucd%xx(i,1) = fline_lc%xx_line_l(1,i) + ucd%xx(i,2) = fline_lc%xx_line_l(2,i) + ucd%xx(i,3) = fline_lc%xx_line_l(3,i) + end do +!$omp end parallel do + + call allocate_ucd_ele(ucd) +!$omp parallel do + do i = 1, ucd%nele + ucd%iele_global(i) = ucd%inod_global(i) + ucd%ie(i,1) = fline_lc%iglobal_fline(i) + end do +!$omp end parallel do + + ucd%num_field = viz_fields%num_color_fields + call allocate_ucd_phys_name(ucd) +!$omp parallel workshare + ucd%phys_name(1:ucd%num_field) & + & = viz_fields%color_field_name(1:ucd%num_field) + ucd%num_comp(1:ucd%num_field) & + & = viz_fields%ncomp_color_field(1:ucd%num_field) +!$omp end parallel workshare + + ucd%ntot_comp = viz_fields%ntot_color_comp + call allocate_ucd_phys_data(ucd) + do nd = 1, ucd%ntot_comp +!$omp parallel workshare + ucd%d_ucd(1:ucd%nnod,nd) = fline_lc%col_line_l(nd,1:ucd%nnod) +!$omp end parallel workshare + end do +! + end subroutine copy_local_particles_to_IO +! +! --------------------------------------------------------------------- +! + end module collect_fline_data diff --git a/src/Fortran_libraries/VIZ_src/fieldline/const_field_lines.f90 b/src/Fortran_libraries/VIZ_src/fieldline/const_field_lines.f90 new file mode 100644 index 00000000..60a65cda --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/const_field_lines.f90 @@ -0,0 +1,126 @@ +!>@file const_field_lines.f90 +!!@brief module const_field_lines +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Routines to construct field lines +!! +!!@verbatim +!! subroutine const_each_field_line & +!! & (elps_fline, mesh, para_surf, nod_fld, fln_prm, & +!! & fln_tce, fln_SR, fln_bcast, fline_lc, m_SR) +!! type(elapsed_lables), intent(in) :: elps_fline +!! type(mesh_geometry), intent(in) :: mesh +!! type(paralell_surface_indices), intent(in) :: para_surf +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_paramter), intent(in) :: fln_prm +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!! type(local_fieldline), intent(inout) :: fline_lc +!! type(trace_data_send_recv), intent(inout) :: fln_SR +!! type(broadcast_trace_data), intent(inout) :: fln_bcast +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module const_field_lines +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter + use m_geometry_constants + use m_work_time +! + use t_mesh_SR + use t_mesh_data + use t_control_params_4_fline + use t_comm_table + use t_phys_data + use t_parallel_surface_indices + use t_local_fline + use t_next_node_ele_4_node + use t_trace_data_send_recv + use t_broadcast_trace_data + use t_tracing_data + use t_mesh_SR +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine const_each_field_line & + & (elps_fline, mesh, para_surf, nod_fld, fln_prm, & + & fln_tce, fln_SR, fln_bcast, fline_lc, m_SR) +! + use calypso_SR + use transfer_to_long_integers + use extend_field_line +! + type(elapsed_lables), intent(in) :: elps_fline + type(mesh_geometry), intent(in) :: mesh + type(paralell_surface_indices), intent(in) :: para_surf + type(phys_data), intent(in) :: nod_fld +! + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_trace), intent(inout) :: fln_tce + type(local_fieldline), intent(inout) :: fline_lc + type(trace_data_send_recv), intent(inout) :: fln_SR + type(broadcast_trace_data), intent(inout) :: fln_bcast + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: nline, inum, ip + integer(kind = kint) :: jcou +! +! + fln_tce%trace_length(1:fln_tce%num_current_fline) = 0.0d0 +! write(*,*) my_rank, 'reset_fline_start loop' + call reset_fline_start(fline_lc) +! + jcou = 0 + do + jcou = jcou + 1 + if(elps_fline%flag_elapsed) & + & call start_elapsed_time(elps_fline%ist_elapsed+2) + do inum = 1, fln_tce%num_current_fline + call s_extend_field_line(mesh%node, mesh%ele, mesh%surf, & + & para_surf, nod_fld, fln_prm%fline_fields, & + & fln_prm%max_line_stepping, fln_prm%max_trace_length, & + & fln_prm%iflag_fline_used_ele, & + & fln_tce%iline_original(inum), & + & fln_tce%iflag_direction(inum), fln_prm%iphys_4_fline, & + & fln_tce%isf_dbl_start(1,inum), & + & fln_tce%xx_fline_start(1,inum), & + & fln_tce%v_fline_start(1,inum), & + & fln_tce%c_fline_start(1,inum), & + & fln_tce%icount_fline(inum), fln_tce%trace_length(inum), & + & fln_tce%iflag_comm_start(inum), fline_lc, inum) + end do + call calypso_mpi_barrier() + if(elps_fline%flag_elapsed) & + & call end_elapsed_time(elps_fline%ist_elapsed+2) +! + if(elps_fline%flag_elapsed) & + & call start_elapsed_time(elps_fline%ist_elapsed+3) + if(fln_prm%flag_use_broadcast) then + call s_broadcast_trace_data(fln_prm, fln_tce, & + & fln_bcast, nline) + else + call s_trace_data_send_recv(fln_prm, fln_tce, fln_SR, & + & m_SR%SR_sig, nline) + end if + if(elps_fline%flag_elapsed) & + & call end_elapsed_time(elps_fline%ist_elapsed+3) +! + if(nline .le. 0) exit + end do +! + end subroutine const_each_field_line +! +! --------------------------------------------------------------------- +! + end module const_field_lines diff --git a/src/Fortran_libraries/VIZ_src/fieldline/ctl_data_field_line_IO.f90 b/src/Fortran_libraries/VIZ_src/fieldline/ctl_data_field_line_IO.f90 new file mode 100644 index 00000000..252d5876 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/ctl_data_field_line_IO.f90 @@ -0,0 +1,421 @@ +!>@file ctl_data_field_line_IO.f90 +!!@brief module ctl_data_field_line_IO +!! +!!@date Programmed by H.Matsui in May, 2006 +! +!>@brief control data for each field line +!! +!!@verbatim +!! subroutine init_field_line_ctl_label(hd_block, fln) +!! subroutine s_read_field_line_ctl(id_control, hd_block, & +!! & fln, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(fline_ctl), intent(inout) :: fln +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_field_line_ctl(id_control, hd_block, & +!! & fln, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(fline_ctl), intent(in) :: fln +!! integer(kind = kint), intent(inout) :: level +!! --------------------------------------------------------------------- +!! example of control for Kemo's field line +!! +!! begin fieldline +!! fline_file_prefix 'fline' +!! fline_output_format ucd +!! +!! field_line_field_ctl magnetic_field +!! coloring_field_ctl magnetic_field end +!! coloring_comp_ctl radial end +!! array output_field +!! output_field velocity vector +!! output_field magnetic_field radial +!! end array output_field +!! +!! array chosen_ele_grp_ctl +!! chosen_ele_grp_ctl outer_core end +!! end array chosen_ele_grp_ctl +!! +!! starting_type: position_list, surface_list, +!! spray_in_domain, or surface_group +!! line_direction_ctl forward +!! max_line_stepping_ctl 1000 +!! max_trace_length_ctl 20.0 +!! +!! communication_mode_ctl send_recv +!! starting_type_ctl position_list +!! +!! seed_surface_grp_ctl icb_surf +!! seed_element_grp_ctl outer_core +!! num_fieldline_ctl 10 +!! +!! seed_reference_field_ctl magnetic_field +!! seed_reference_component_ctl radial +!! +!! selection_type_ctl: amplitude, area_size +!! +!! begin seed_lists_ctl +!! array seed_point_ctl +!! seed_point_ctl 0.0 0.0 0.0 +!! end array seed_point_ctl +!! +!! array seed_geological_ctl +!! seed_geological_ctl 1.03 36.5 140.0 +!! end array seed_geological_ctl +!! +!! array seed_spherical_ctl +!! seed_geological_ctl 0.75 -1.047 3.141592 +!! end array seed_spherical_ctl +!! +!! array starting_gl_surface_id 10 +!! starting_gl_surface_id 12 3 +!! end array +!! end seed_lists_ctl +!! end fieldline +!! --------------------------------------------------------------------- +!!@endverbatim +! + module ctl_data_field_line_IO +! + use m_precision +! + use m_machine_parameter + use t_ctl_data_field_line + use t_read_control_elements + use t_control_array_integer + use t_control_array_character + use t_control_array_integer2 + use t_control_array_real + use t_control_array_real3 + use t_fline_seeds_list_ctl + use calypso_mpi +! + implicit none +! + character(len=kchara), parameter, private & + & :: hd_fline_file_prefix = 'fline_file_prefix' + character(len=kchara), parameter, private & + & :: hd_fline_output_format = 'fline_output_format' +! + character(len=kchara), parameter, private & + & :: hd_fline_rst_prefix = 'tracer_restart_prefix' + character(len=kchara), parameter, private & + & :: hd_fline_rst_format = 'tracer_restart_format' +! + character(len=kchara), parameter, private & + & :: hd_field_line_field = 'field_line_field_ctl' + character(len=kchara), parameter, private & + & :: hd_coloring_field = 'coloring_field_ctl' + character(len=kchara), parameter, private & + & :: hd_coloring_comp = 'coloring_comp_ctl' + character(len=kchara), parameter & + & :: hd_fline_result_field = 'output_field' +! + character(len=kchara), parameter, private & + & :: hd_fline_grp = 'chosen_ele_grp_ctl' +! + character(len=kchara), parameter, private & + & :: hd_line_direction = 'line_direction_ctl' + character(len=kchara), parameter, private & + & :: hd_max_line_stepping = 'max_line_stepping_ctl' + character(len=kchara), parameter, private & + & :: hd_max_trace_length = 'max_trace_length_ctl' + character(len=kchara), parameter, private & + & :: hd_starting_type = 'starting_type_ctl' +! + character(len=kchara), parameter, private & + & :: hd_fline_comm_type = 'communication_mode_ctl' +! + character(len=kchara), parameter, private & + & :: hd_seed_surf_grp = 'seed_surface_grp_ctl' + character(len=kchara), parameter, private & + & :: hd_seed_ele_grp = 'seed_element_grp_ctl' +! + character(len=kchara), parameter, private & + & :: hd_seed_ref_field = 'seed_reference_field_ctl' + character(len=kchara), parameter, private & + & :: hd_seed_ref_comp = 'seed_reference_component_ctl' +! + character(len=kchara), parameter, private & + & :: hd_seed_file_prefix = 'seed_file_prefix_ctl' +! + character(len=kchara), parameter, private & + & :: hd_num_fieldline = 'num_fieldline_ctl' + character(len=kchara), parameter, private & + & :: hd_selection_type = 'selection_type_ctl' +! + character(len=kchara), parameter, private & + & :: hd_seed_lists = 'seed_lists_ctl' +! +! Deprecated labels + character(len=kchara), parameter, private & + & :: hd_fline_file_head = 'fline_file_head' + character(len=kchara), parameter, private & + & :: hd_fline_output_type = 'fline_output_type' + character(len=kchara), parameter, private & + & :: hd_start_surf_grp = 'start_surf_grp_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_read_field_line_ctl(id_control, hd_block, & + & fln, c_buf) +! + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(fline_ctl), intent(inout) :: fln + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return +! + if (fln%i_vr_fline_ctl.gt.0) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_fline_seeds_list_ctl(id_control, hd_seed_lists, & + & fln%seeds_ctl, c_buf) +! + call read_control_array_c1(id_control, & + & hd_fline_grp, fln%fline_area_grp_ctl, c_buf) +! + call read_control_array_c2(id_control, & + & hd_fline_result_field, fln%fline_field_output_ctl, c_buf) +! + call read_chara_ctl_type(c_buf, hd_fline_file_prefix, & + & fln%fline_file_head_ctl) + call read_chara_ctl_type(c_buf, hd_fline_output_format, & + & fln%fline_output_type_ctl) +! + call read_chara_ctl_type(c_buf, hd_fline_rst_prefix, & + & fln%fline_rst_prefix_ctl) + call read_chara_ctl_type(c_buf, hd_fline_rst_format, & + & fln%fline_rst_format_ctl) +! + call read_chara_ctl_type(c_buf, hd_field_line_field, & + & fln%fline_field_ctl) + call read_chara_ctl_type(c_buf, hd_coloring_field, & + & fln%fline_color_field_ctl) + call read_chara_ctl_type(c_buf, hd_coloring_comp, & + & fln%fline_color_comp_ctl) + call read_chara_ctl_type(c_buf, hd_starting_type, & + & fln%starting_type_ctl) + call read_chara_ctl_type(c_buf, hd_fline_comm_type, & + & fln%fline_comm_mode_ctl) +! + call read_chara_ctl_type(c_buf, hd_seed_surf_grp, & + & fln%seed_surf_grp_ctl) + call read_chara_ctl_type(c_buf, hd_seed_ele_grp, & + & fln%seed_ele_grp_ctl) +! + call read_chara_ctl_type(c_buf, hd_seed_ref_field, & + & fln%seed_ref_field_ctl) + call read_chara_ctl_type(c_buf, hd_seed_ref_comp, & + & fln%seed_ref_comp_ctl) +! + call read_chara_ctl_type(c_buf, hd_seed_file_prefix, & + & fln%seed_file_prefix_ctl) +! + call read_chara_ctl_type(c_buf, hd_selection_type, & + & fln%selection_type_ctl ) + call read_chara_ctl_type(c_buf, hd_line_direction, & + & fln%line_direction_ctl ) +! + call read_integer_ctl_type(c_buf, hd_num_fieldline, & + & fln%num_fieldline_ctl ) + call read_integer_ctl_type(c_buf, hd_max_line_stepping, & + & fln%max_line_stepping_ctl) + + call read_real_ctl_type(c_buf, hd_max_trace_length, & + & fln%max_trace_length_ctl) +! +! ---------------Deprecated items + call read_chara_ctl_type(c_buf, hd_start_surf_grp, & + & fln%seed_surf_grp_ctl) + call read_chara_ctl_type(c_buf, hd_fline_file_head, & + & fln%fline_file_head_ctl) + call read_chara_ctl_type(c_buf, hd_fline_output_type, & + & fln%fline_output_type_ctl) + end do + fln%i_vr_fline_ctl = 1 +! + end subroutine s_read_field_line_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_field_line_ctl(id_control, hd_block, & + & fln, level) +! + use skip_comment_f + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(fline_ctl), intent(in) :: fln +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(fln%i_vr_fline_ctl .le. 0) return +! + maxlen = len_trim(hd_fline_file_prefix) + maxlen = max(maxlen, len_trim(hd_fline_output_format)) + maxlen = max(maxlen, len_trim(hd_fline_rst_prefix)) + maxlen = max(maxlen, len_trim(hd_fline_rst_format)) + maxlen = max(maxlen, len_trim(hd_field_line_field)) + maxlen = max(maxlen, len_trim(hd_coloring_field)) + maxlen = max(maxlen, len_trim(hd_coloring_comp)) + maxlen = max(maxlen, len_trim(hd_line_direction)) + maxlen = max(maxlen, len_trim(hd_max_line_stepping)) + maxlen = max(maxlen, len_trim(hd_starting_type)) + maxlen = max(maxlen, len_trim(hd_fline_comm_type)) + maxlen = max(maxlen, len_trim(hd_seed_surf_grp)) + maxlen = max(maxlen, len_trim(hd_seed_ele_grp)) + maxlen = max(maxlen, len_trim(hd_seed_ref_field)) + maxlen = max(maxlen, len_trim(hd_seed_ref_comp)) + maxlen = max(maxlen, len_trim(hd_seed_file_prefix)) + maxlen = max(maxlen, len_trim(hd_num_fieldline)) + maxlen = max(maxlen, len_trim(hd_selection_type)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%fline_file_head_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%fline_output_type_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%fline_field_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%fline_color_field_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%fline_color_comp_ctl) + call write_control_array_c2(id_control, level, & + & fln%fline_field_output_ctl) +! + call write_control_array_c1(id_control, level, & + & fln%fline_area_grp_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%line_direction_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & fln%max_line_stepping_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & fln%max_trace_length_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%starting_type_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%fline_comm_mode_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%seed_surf_grp_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%seed_ele_grp_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%seed_file_prefix_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%seed_ref_field_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%seed_ref_comp_ctl) +! + call write_integer_ctl_type(id_control, level, maxlen, & + & fln%num_fieldline_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & fln%selection_type_ctl) +! + call write_fline_seeds_list_ctl(id_control, fln%seeds_ctl, level) +! + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_field_line_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_field_line_ctl_label(hd_block, fln) +! + character(len=kchara), intent(in) :: hd_block + type(fline_ctl), intent(inout) :: fln +! +! + fln%block_name = hd_block +! + call init_fline_seeds_list_ctl(hd_seed_lists, fln%seeds_ctl) +! + call init_chara_ctl_array_label & + & (hd_fline_grp, fln%fline_area_grp_ctl) +! + call init_chara2_ctl_array_label & + & (hd_fline_result_field, fln%fline_field_output_ctl) +! + call init_chara_ctl_item_label(hd_fline_file_prefix, & + & fln%fline_file_head_ctl) + call init_chara_ctl_item_label(hd_fline_output_format, & + & fln%fline_output_type_ctl) +! + call init_chara_ctl_item_label(hd_fline_rst_prefix, & + & fln%fline_rst_prefix_ctl) + call init_chara_ctl_item_label(hd_fline_rst_format, & + & fln%fline_rst_format_ctl) +! + call init_chara_ctl_item_label(hd_field_line_field, & + & fln%fline_field_ctl) + call init_chara_ctl_item_label(hd_coloring_field, & + & fln%fline_color_field_ctl) + call init_chara_ctl_item_label(hd_coloring_comp, & + & fln%fline_color_comp_ctl) + call init_chara_ctl_item_label(hd_starting_type, & + & fln%starting_type_ctl) +! + call init_chara_ctl_item_label(hd_fline_comm_type, & + & fln%fline_comm_mode_ctl) +! + call init_chara_ctl_item_label(hd_seed_surf_grp, & + & fln%seed_surf_grp_ctl) + call init_chara_ctl_item_label(hd_seed_ele_grp, & + & fln%seed_ele_grp_ctl) +! + call init_chara_ctl_item_label(hd_seed_ref_field, & + & fln%seed_ref_field_ctl) + call init_chara_ctl_item_label(hd_seed_ref_comp, & + & fln%seed_ref_comp_ctl) +! + call init_chara_ctl_item_label(hd_seed_file_prefix, & + & fln%seed_file_prefix_ctl) +! + call init_chara_ctl_item_label(hd_selection_type, & + & fln%selection_type_ctl) + call init_chara_ctl_item_label(hd_line_direction, & + & fln%line_direction_ctl) +! + call init_int_ctl_item_label(hd_num_fieldline, & + & fln%num_fieldline_ctl) + call init_int_ctl_item_label(hd_max_line_stepping, & + & fln%max_line_stepping_ctl) + call init_real_ctl_item_label(hd_max_trace_length, & + & fln%max_trace_length_ctl) +! +! ---------------Deprecated items + call init_chara_ctl_item_label(hd_fline_file_head, & + & fln%fline_file_head_ctl) + call init_chara_ctl_item_label(hd_fline_output_type, & + & fln%fline_output_type_ctl) +! + end subroutine init_field_line_ctl_label +! +! --------------------------------------------------------------------- +! + end module ctl_data_field_line_IO diff --git a/src/Fortran_libraries/VIZ_src/fieldline/ctl_file_fieldlines_IO.f90 b/src/Fortran_libraries/VIZ_src/fieldline/ctl_file_fieldlines_IO.f90 new file mode 100644 index 00000000..069fdb9d --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/ctl_file_fieldlines_IO.f90 @@ -0,0 +1,249 @@ +!>@file ctl_file_fieldlines_IO.f90 +!!@brief module ctl_file_fieldlines_IO +!! +!!@date Programmed by H.Matsui in May, 2006 +! +!>@brief control data for cross sections +!! +!!@verbatim +!! subroutine read_files_4_fline_ctl & +!! & (id_control, hd_block, fline_ctls, c_buf) +!! subroutine sel_read_fline_control(id_control, hd_block, & +!! & file_name, fline_ctl_struct, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! character(len = kchara), intent(inout) :: file_name +!! type(fieldline_controls), intent(inout) :: fline_ctls +!! type(fline_ctl), intent(inout) :: fline_ctl_struct +!! type(buffer_for_control), intent(inout) :: c_buf +!! +!! subroutine write_files_4_fline_ctl(id_control, hd_block, & +!! & fline_ctls, level) +!! subroutine sel_write_fline_control(id_control, hd_block, & +!! & file_name, fline_ctl_struct, level) +!! subroutine write_fline_control_file(id_control, file_name, & +!! & hd_block, fline_ctl_struct) +!! integer(kind = kint), intent(in) :: id_control +!! character(len = kchara), intent(in) :: file_name +!! character(len=kchara), intent(in) :: hd_block +!! type(fieldline_controls), intent(in) :: fline_ctls +!! type(fline_ctl), intent(in) :: fline_ctl_struct +!! integer(kind = kint), intent(inout) :: level +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array fieldline +!! file fieldline 'ctl_fline_magne' +!! end array fieldline +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module ctl_file_fieldlines_IO +! + use m_precision + use m_constants +! + use m_machine_parameter + use t_ctl_data_field_line + use t_control_data_flines +! + implicit none +! + private :: read_fline_control_file +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_files_4_fline_ctl & + & (id_control, hd_block, fline_ctls, c_buf) +! + use t_read_control_elements + use skip_comment_f + use ctl_data_field_line_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(fieldline_controls), intent(inout) :: fline_ctls + type(buffer_for_control), intent(inout) :: c_buf +! + integer(kind = kint) :: n_append +! + if(check_array_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(allocated(fline_ctls%fline_ctl_struct)) return + call alloc_fline_ctl_struct(fline_ctls) +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_array_flag(c_buf, hd_block)) exit +! + if(check_file_flag(c_buf, hd_block) & + & .or. check_begin_flag(c_buf, hd_block)) then + n_append = fline_ctls%num_fline_ctl + call append_fline_control(n_append, hd_block, fline_ctls) +! + call write_multi_ctl_file_message & + & (hd_block, fline_ctls%num_fline_ctl, c_buf%level) + call sel_read_fline_control(id_control, hd_block, & + & fline_ctls%fname_fline_ctl(fline_ctls%num_fline_ctl), & + & fline_ctls%fline_ctl_struct(fline_ctls%num_fline_ctl), & + & c_buf) + end if + end do +! + end subroutine read_files_4_fline_ctl +! +! -------------------------------------------------------------------- +! + subroutine sel_read_fline_control(id_control, hd_block, & + & file_name, fline_ctl_struct, c_buf) +! + use ctl_data_field_line_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + character(len = kchara), intent(inout) :: file_name + type(fline_ctl), intent(inout) :: fline_ctl_struct + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_file_flag(c_buf, hd_block)) then + file_name = third_word(c_buf) +! + write(*,'(3a,i4,a)', ADVANCE='NO') 'is read from ' + call read_fline_control_file((id_control+2), file_name, & + & hd_block, fline_ctl_struct, c_buf) + else if(check_begin_flag(c_buf, hd_block)) then + file_name = 'NO_FILE' +! + write(*,'(a)') ' is included' + call s_read_field_line_ctl(id_control, hd_block, & + & fline_ctl_struct, c_buf) + end if +! + end subroutine sel_read_fline_control +! +! --------------------------------------------------------------------- +! + subroutine read_fline_control_file(id_control, file_name, & + & hd_block, fline_ctl_struct, c_buf) +! + use ctl_data_field_line_IO +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(fline_ctl), intent(inout) :: fline_ctl_struct + type(buffer_for_control), intent(inout) :: c_buf +! +! + c_buf%level = c_buf%level + 1 + write(*,*) 'Control file: ', trim(file_name) + call reset_fline_control_flags(fline_ctl_struct) + open(id_control, file=file_name, status='old') +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit +! + call s_read_field_line_ctl(id_control, hd_block, & + & fline_ctl_struct, c_buf) + if(fline_ctl_struct%i_vr_fline_ctl .gt. 0) exit + end do + close(id_control) +! + c_buf%level = c_buf%level - 1 +! + end subroutine read_fline_control_file +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine write_files_4_fline_ctl(id_control, hd_block, & + & fline_ctls, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(fieldline_controls), intent(in) :: fline_ctls + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: i +! + if(fline_ctls%num_fline_ctl .le. 0) return +! + level = write_array_flag_for_ctl(id_control, level, hd_block) + do i = 1, fline_ctls%num_fline_ctl + write(*,'(3a,i4,a)', ADVANCE='NO') '! ', trim(hd_block), & + & ' No. ', fline_ctls%num_fline_ctl + call sel_write_fline_control & + & (id_control, hd_block, fline_ctls%fname_fline_ctl(i), & + & fline_ctls%fline_ctl_struct(i), level) + end do + level = write_end_array_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_files_4_fline_ctl +! +! -------------------------------------------------------------------- +! + subroutine sel_write_fline_control(id_control, hd_block, & + & file_name, fline_ctl_struct, level) +! + use ctl_data_field_line_IO + use write_control_elements + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(fline_ctl), intent(in) :: fline_ctl_struct + integer(kind = kint), intent(inout) :: level +! +! + if(no_file_flag(file_name)) then + write(*,'(a)') ' is included.' + call write_field_line_ctl(id_control, hd_block, & + & fline_ctl_struct, level) + else if(id_control .eq. id_monitor) then + write(*,'(2a)') 'shuld be written to ', trim(file_name) + call write_field_line_ctl(id_control, hd_block, & + & fline_ctl_struct, level) + else + write(*,'(2a)') 'is written to ', trim(file_name) + call write_file_name_for_ctl_line(id_control, level, & + & hd_block, file_name) + call write_fline_control_file((id_control+2), file_name, & + & hd_block, fline_ctl_struct) + end if +! + end subroutine sel_write_fline_control +! +! --------------------------------------------------------------------- +! + subroutine write_fline_control_file(id_control, file_name, & + & hd_block, fline_ctl_struct) +! + use ctl_data_field_line_IO +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(fline_ctl), intent(in) :: fline_ctl_struct +! + integer(kind = kint) :: level +! +! + level = 0 + open(id_control, file=file_name) + call write_field_line_ctl(id_control, hd_block, & + & fline_ctl_struct, level) + close(id_control) +! + end subroutine write_fline_control_file +! +! --------------------------------------------------------------------- +! + end module ctl_file_fieldlines_IO diff --git a/src/Fortran_libraries/VIZ_src/fieldline/elapsed_labels_4_FLINE.f90 b/src/Fortran_libraries/VIZ_src/fieldline/elapsed_labels_4_FLINE.f90 new file mode 100644 index 00000000..fa466217 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/elapsed_labels_4_FLINE.f90 @@ -0,0 +1,81 @@ +!>@file elapsed_labels_4_FLINE.f90 +!!@brief module elapsed_labels_4_FLINE +!! +!!@author H. Matsui +!!@date Programmed in April, 2013 +! +!>@brief Initialize elepsed time monitoring +!! +!!@verbatim +!! subroutine elpsed_label_4_FLINE(elps_fline, elps) +!! type(elapsed_lables), intent(inout) :: elps_fline +!! type(elapsed_time_data), intent(inout) :: elps +!! subroutine elpsed_label_4_TRACER(elps_tracer, elps) +!! type(elapsed_lables), intent(inout) :: elps_tracer +!! type(elapsed_time_data), intent(inout) :: elps +!!@endverbatim +! + module elapsed_labels_4_FLINE +! + use m_precision + use m_work_time +! + implicit none +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine elpsed_label_4_FLINE(elps_fline, elps) +! + type(elapsed_lables), intent(inout) :: elps_fline + type(elapsed_time_data), intent(inout) :: elps +! + integer(kind = kint), parameter :: num_append = 4 +! +! + call append_elapsed_timer(num_append, elps_fline%ist_elapsed, & + & elps_fline%ied_elapsed, elps) +! + elps%labels(elps_fline%ist_elapsed+1) & + & = 'Set Seed points ' + elps%labels(elps_fline%ist_elapsed+2) & + & = 'Trace field line ' + elps%labels(elps_fline%ist_elapsed+3) & + & = 'Communication for field line ' + elps%labels(elps_fline%ist_elapsed+4) & + & = 'Output field line file ' +! + elps_fline%flag_elapsed = .TRUE. +! + end subroutine elpsed_label_4_FLINE +! +!----------------------------------------------------------------------- +! + subroutine elpsed_label_4_TRACER(elps_tracer, elps) +! + type(elapsed_lables), intent(inout) :: elps_tracer + type(elapsed_time_data), intent(inout) :: elps + integer(kind = kint), parameter :: num_append = 3 +! +! + call append_elapsed_timer(num_append, elps_tracer%ist_elapsed, & + & elps_tracer%ied_elapsed, elps) +! + elps%labels(elps_tracer%ist_elapsed+1) & + & = 'Trace in elements ' + elps%labels(elps_tracer%ist_elapsed+2) & + & = 'Communication for tracers ' + elps%labels(elps_tracer%ist_elapsed+3) & + & = 'Output tracer file ' +! +! + elps_tracer%flag_elapsed = .TRUE. +! + end subroutine elpsed_label_4_TRACER +! +!----------------------------------------------------------------------- +! + end module elapsed_labels_4_FLINE diff --git a/src/Fortran_libraries/VIZ_src/fieldline/extend_field_line.f90 b/src/Fortran_libraries/VIZ_src/fieldline/extend_field_line.f90 new file mode 100644 index 00000000..3d0dcab7 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/extend_field_line.f90 @@ -0,0 +1,293 @@ +!>@file extend_field_line.f90 +!! module extend_field_line +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief extend field line in each domain +!! +!!@verbatim +!! subroutine s_extend_field_line(node, ele, surf, para_surf, & +!! & nod_fld, viz_fields, max_line_step, end_trace, & +!! & iflag_used_ele, iglobal_fline, iflag_dir, i_fline, & +!! & isurf_org_dbl, x4_start, v4_start, c_field, & +!! & c_field, icount_line, iflag_comm, fline_lc) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(phys_data), intent(in) :: nod_fld +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! real(kind = kreal), intent(in) :: end_trace +!! integer(kind = kint_gl), intent(in) :: iglobal_fline +!! integer(kind = kint), intent(in) :: iflag_dir, max_line_step +!! integer(kind = kint), intent(in) :: iflag_used_ele(ele%numele) +!! integer(kind = kint), intent(inout) :: isurf_org_dbl(3) +!! integer(kind = kint), intent(inout) :: icount_line, iflag_comm +!! real(kind = kreal), intent(inout) :: v4_start(4), x4_start(4) +!! real(kind = kreal), intent(inout) :: c_field(1) +!! type(local_fieldline), intent(inout) :: fline_lc +!!@endverbatim +! + module extend_field_line +! + use m_precision +! + use m_constants + use m_geometry_constants + use calypso_mpi +! + use t_geometry_data + use t_surface_data + use t_parallel_surface_indices + use t_phys_data + use t_ctl_params_viz_fields +! + implicit none +! + private :: fline_trace_in_element, ratio_of_trace_to_wall_fline +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_extend_field_line(node, ele, surf, para_surf, & + & nod_fld, viz_fields, max_line_step, end_trace, & + & iflag_used_ele, iglobal_fline, iflag_dir, i_fline, & + & isurf_org_dbl, x4_start, v4_start, c_field, & + & icount_line, trace_length, iflag_comm, fline_lc, inum) +! + use t_local_fline + use trace_in_element + use set_fields_after_tracing +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(paralell_surface_indices), intent(in) :: para_surf + type(phys_data), intent(in) :: nod_fld + type(ctl_params_viz_fields), intent(in) :: viz_fields + integer(kind = kint), intent(in) :: i_fline + integer(kind = kint_gl), intent(in) :: iglobal_fline +! + integer(kind = kint), intent(in) :: inum + real(kind = kreal), intent(in) :: end_trace + integer(kind = kint), intent(in) :: iflag_dir, max_line_step + integer(kind = kint), intent(in) :: iflag_used_ele(ele%numele) +! + integer(kind = kint), intent(inout) :: isurf_org_dbl(3) + real(kind = kreal), intent(inout) :: v4_start(4), x4_start(4) + real(kind = kreal), intent(inout) & + & :: c_field(viz_fields%ntot_color_comp) +! + type(local_fieldline), intent(inout) :: fline_lc + real(kind = kreal), intent(inout) :: trace_length + integer(kind = kint), intent(inout) :: icount_line, iflag_comm +! + real(kind = kreal) :: x4_ele(4,ele%nnod_4_ele) + real(kind = kreal) :: v4_ele(4,ele%nnod_4_ele) + real(kind = kreal) & + & :: color_ele(viz_fields%ntot_org_comp, ele%nnod_4_ele) + integer(kind = kint) :: isf_tgt, jcou + integer(kind = kint) :: isurf_org(2) +! +! + if(isurf_org_dbl(2) .eq. 0) then + iflag_comm = 0 +! write(*,*) 'Exit at initial tracing', my_rank, inum + return + end if +! + isurf_org(1:2) = isurf_org_dbl(2:3) + if(isurf_org(2) .gt. 0) then + call find_backside_by_flux(surf, iflag_dir, & + & v4_start, isurf_org) + end if +! + call add_fline_start(x4_start, v4_start, & + & viz_fields%ntot_color_comp, c_field(1), fline_lc) +! + jcou = 0 + iflag_comm = 0 + do + jcou = jcou + 1 + icount_line = icount_line + 1 + call fline_vector_at_one_element(isurf_org(1), node, ele, & + & node%xx, x4_ele) + call fline_vector_at_one_element(isurf_org(1), node, ele, & + & nod_fld%d_fld(1,i_fline), v4_ele) + call fline_colors_at_one_element(isurf_org(1), ele, & + & nod_fld, viz_fields, color_ele) +! +! extend in the middle of element + call fline_trace_in_element(half, end_trace, trace_length, & + & isurf_org(2), iflag_dir, ele, surf, & + & viz_fields, x4_ele, v4_ele, color_ele, & + & isf_tgt, x4_start, v4_start, c_field) + if(isf_tgt .lt. 0) then + iflag_comm = isf_tgt +! write(*,*) 'Trace stops by zero vector', my_rank, inum, & +! & ' at ', jcou, ': ', isurf_org(1:2) + exit + end if + if(isf_tgt .eq. 0) then + iflag_comm = -1 +! write(*,*) 'Error at trace to mid point', my_rank, inum, & +! & ' at ', jcou, ': ', isurf_org(1:2) + exit + end if + call add_fline_list(iglobal_fline, x4_start, v4_start, & + & viz_fields%ntot_color_comp, c_field(1), fline_lc) + if(trace_length.ge.end_trace .and. end_trace.gt.zero) return +! +! extend to surface of element + call fline_trace_in_element(one, end_trace, trace_length, & + & izero, iflag_dir, ele, surf, & + & viz_fields, x4_ele, v4_ele, color_ele, & + & isf_tgt, x4_start, v4_start, c_field) + if(isf_tgt .lt. 0) then + iflag_comm = isf_tgt +! write(*,*) 'Trace stops by zero vector', my_rank, inum, & +! & ' at ', jcou, ': ', isurf_org(1:2) + exit + end if + if(isf_tgt .eq. 0) then + iflag_comm = -1 +! write(*,*) 'Error at trace to end point', my_rank, inum, & +! & ' at ', jcou, ': ', isurf_org(1:2) + exit + end if + call add_fline_list(iglobal_fline, x4_start, v4_start, & + & viz_fields%ntot_color_comp, c_field(1), fline_lc) + if(trace_length.ge.end_trace .and. end_trace.gt.zero) exit +! + isurf_org(2) = isf_tgt +! +! Check domain of new starting surface + call check_exit_in_double_number(surf, para_surf, & + & isurf_org, isurf_org_dbl) + if(isurf_org_dbl(1) .ne. my_rank & + & .or. isurf_org_dbl(3) .eq. 0) then + iflag_comm = 1 +! write(*,*) 'Exit for external surface', my_rank, inum +! & ': ', isurf_org_dbl(1:3), ': ', & +! & para_surf%isf_4_ele_dbl(isurf_org(1),isf_tgt,2) + exit + end if +! +! Check domain of backside element and surface + call find_backside_by_flux(surf, iflag_dir, & + & v4_start, isurf_org) +! + if(max_line_step.gt.0 .and. icount_line.gt.max_line_step) then + iflag_comm = 0 +! write(*,*) 'Exit by trace counts', my_rank, inum + exit + end if + if(iflag_used_ele(isurf_org(1)) .eq. 0) then + iflag_comm = 1 +! write(*,*) 'Exit from tracing area', my_rank, inum + exit + end if + if(isurf_org(1) .eq. 0) then + iflag_comm = -2 +! write(*,*) 'Trace leaves from domain', my_rank, inum + exit + end if + end do +! + end subroutine s_extend_field_line +! +! --------------------------------------------------------------------- +! + subroutine fline_trace_in_element & + & (trace_ratio, end_trace, trace_length, & + & isf_org, iflag_dir, ele, surf, & + & viz_fields, x4_ele, v4_ele, c_ele, & + & isf_tgt, x4_start, v4_start, c_field) +! + use coordinate_converter + use convert_components_4_viz + use cal_field_on_surf_viz + use cal_fline_in_cube + use trace_in_element + use tracer_field_interpolate +! + real(kind = kreal), intent(in) :: trace_ratio + real(kind = kreal), intent(in) :: end_trace + real(kind = kreal), intent(inout) :: trace_length +! + integer(kind = kint), intent(in) :: isf_org + integer(kind = kint), intent(in) :: iflag_dir +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(ctl_params_viz_fields), intent(in) :: viz_fields +! + real(kind = kreal), intent(in) :: x4_ele(4,ele%nnod_4_ele) + real(kind = kreal), intent(in) :: v4_ele(4,ele%nnod_4_ele) + real(kind = kreal), intent(in) & + & :: c_ele(viz_fields%ntot_org_comp, ele%nnod_4_ele) +! + integer(kind = kint), intent(inout) :: isf_tgt + real(kind = kreal), intent(inout) :: x4_start(4) + real(kind = kreal), intent(inout) :: v4_start(4) + real(kind = kreal), intent(inout) & + & :: c_field(viz_fields%ntot_color_comp) +! + real(kind = kreal) :: v4_tgt(4), x4_tgt_8(4) + real(kind = kreal) :: c_tgt(viz_fields%ntot_color_comp) + real(kind = kreal) :: ratio +! +! + if((v4_start(1)**2+v4_start(2)**2+v4_start(3)**2) .le. zero) then + isf_tgt = -3 + return + end if +! + call trace_to_element_wall(isf_org, iflag_dir, ele, surf, & + & viz_fields, x4_ele, v4_ele, c_ele, x4_start, v4_start, & + & isf_tgt, x4_tgt_8, v4_tgt, c_tgt) + if(isf_tgt .le. 0) return +! + call ratio_of_trace_to_wall_fline(end_trace, trace_ratio, & + & x4_tgt_8, x4_start, & + & ratio, trace_length) + call update_fline_position(ratio, viz_fields%ntot_color_comp, & + & x4_tgt_8, v4_tgt, c_tgt, & + & x4_start, v4_start, c_field) +! + end subroutine fline_trace_in_element +! +! --------------------------------------------------------------------- +! + subroutine ratio_of_trace_to_wall_fline(end_trace, trace_ratio, & + & x4_tgt, x4_start, & + & ratio, trace_length) + + real(kind = kreal), intent(in) :: x4_tgt(4), x4_start(4) + real(kind = kreal), intent(in) :: end_trace + real(kind = kreal), intent(in) :: trace_ratio + real(kind = kreal), intent(inout) :: ratio, trace_length +! + real(kind = kreal) :: trip, rest_trace +! +! + if(trace_length .ge. end_trace .and. end_trace .gt. zero) then + rest_trace = (end_trace - trace_length) + trip = sqrt((x4_tgt(1)-x4_start(1)) * (x4_tgt(1) - x4_start(1)) & + & + (x4_tgt(2)-x4_start(2)) * (x4_tgt(2) - x4_start(2)) & + & + (x4_tgt(3)-x4_start(3)) * (x4_tgt(3) - x4_start(3))) + ratio = min(rest_trace/trip, trace_ratio) + trace_length = trace_length + (one - ratio) * trip + else + ratio = trace_ratio + end if +! + end subroutine ratio_of_trace_to_wall_fline +! +! --------------------------------------------------------------------- +! + end module extend_field_line + diff --git a/src/Fortran_libraries/VIZ_src/fieldline/gz_MPI_particle_file_IO.f90 b/src/Fortran_libraries/VIZ_src/fieldline/gz_MPI_particle_file_IO.f90 new file mode 100644 index 00000000..36bb4130 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/gz_MPI_particle_file_IO.f90 @@ -0,0 +1,147 @@ +!>@file gz_MPI_particle_file_IO.f90 +!! module gz_MPI_particle_file_IO +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2006 +! +!>@brief File IO for element communication table +!! +!!@verbatim +!! subroutine gz_mpi_read_particle_file & +!! & (num_pe, id_rank, file_name, t_IO, particle_IO) +!! integer, intent(in) :: num_pe, id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(inout) :: t_IO +!! type(surf_edge_IO_file), intent(inout) :: particle_IO +!! subroutine gz_mpi_write_particle_file(file_name, & +!! & t_IO, particle_IO) +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(in) :: t_IO +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!!@endverbatim +!! +!!@param id_rank MPI rank +! + module gz_MPI_particle_file_IO +! + use m_precision + use m_machine_parameter +! + use m_file_format_switch + use t_calypso_mpi_IO_param + use t_read_mesh_data + use t_time_data +! + implicit none +! + type(calypso_MPI_IO_params), save, private :: IO_param +! +!------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------ +! + subroutine gz_mpi_read_particle_file & + & (num_pe, id_rank, file_name, t_IO, particle_IO) +! + use m_fem_mesh_labels + use local_fline_restart_IO + use MPI_ascii_data_IO + use gz_MPI_ascii_data_IO + use gz_MPI_domain_data_IO + use gz_MPI_element_connect_IO + use gz_MPI_node_geometry_IO + use gz_field_block_MPI_IO +! + integer, intent(in) :: num_pe, id_rank + character(len=kchara), intent(in) :: file_name + type(time_data), intent(inout) :: t_IO + type(surf_edge_IO_file), intent(inout) :: particle_IO +! +! + if(id_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Read gzipped merged particle file: ', trim(file_name) +! + call open_read_mpi_file & + & (file_name, num_pe, id_rank, IO_param) +! + call gz_mpi_skip_header(IO_param, len(hd_fem_para())) + call gz_mpi_read_domain_info(IO_param, particle_IO%comm) +! + call gz_mpi_skip_header(IO_param, len(hd_fem_node())) + call gz_mpi_read_geometry_info(IO_param, particle_IO%node) +! + call gz_mpi_skip_header(IO_param, len(hd_particle_connect())) + call gz_mpi_read_element_info(IO_param, particle_IO%ele) +! + call gz_mpi_skip_header(IO_param, len(hd_particle_velocity())) + call gz_mpi_read_vect_in_ele(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call gz_mpi_skip_header(IO_param, len(hd_particle_marker())) + call gz_mpi_read_scl_in_ele(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call read_field_step_gz_mpi(IO_param%id_file, nprocs, & + & IO_param%ioff_gl,t_IO) + call close_mpi_file(IO_param) +! + end subroutine gz_mpi_read_particle_file +! +! --------------------------------------------------------------------- +! + subroutine gz_mpi_write_particle_file(file_name, & + & t_IO, particle_IO) +! + use m_fem_mesh_labels + use time_data_IO + use local_fline_restart_IO + use MPI_ascii_data_IO + use gz_MPI_domain_data_IO + use gz_MPI_element_connect_IO + use gz_MPI_node_geometry_IO + use gz_field_block_MPI_IO +! + character(len=kchara), intent(in) :: file_name + type(time_data), intent(in) :: t_IO + type(surf_edge_IO_file), intent(in) :: particle_IO +! +! + if(my_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Write gzipped merged particle file: ', trim(file_name) +! + call open_write_mpi_file(file_name, IO_param) +! + call gz_mpi_write_charahead & + & (IO_param, len(hd_fem_para()), hd_fem_para()) + call gz_mpi_write_domain_info(IO_param, particle_IO%comm) +! + call gz_mpi_write_charahead & + & (IO_param, len(hd_fem_node()), hd_fem_node()) + call gz_mpi_write_geometry_info(IO_param, particle_IO%node) +! + call gz_mpi_write_charahead & + & (IO_param, len(hd_particle_connect()), hd_particle_connect()) + call gz_mpi_write_element_info(IO_param, particle_IO%ele) +! + call gz_mpi_write_charahead & + & (IO_param, len(hd_particle_velocity()), hd_particle_velocity()) + call gz_mpi_write_vect_in_ele(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call gz_mpi_write_charahead & + & (IO_param, len(hd_particle_marker()), hd_particle_marker()) + call gz_mpi_write_scl_in_ele(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call gz_mpi_write_charahead(IO_param, & + & len(step_data_buffer(my_rank, t_IO)), & + & step_data_buffer(my_rank, t_IO)) + call close_mpi_file(IO_param) +! + end subroutine gz_mpi_write_particle_file +! +!------------------------------------------------------------------ +! + end module gz_MPI_particle_file_IO diff --git a/src/Fortran_libraries/VIZ_src/fieldline/gz_MPI_particle_file_IO_b.f90 b/src/Fortran_libraries/VIZ_src/fieldline/gz_MPI_particle_file_IO_b.f90 new file mode 100644 index 00000000..17c1e60c --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/gz_MPI_particle_file_IO_b.f90 @@ -0,0 +1,122 @@ +!>@file gz_MPI_particle_file_IO_b.f90 +!!@brief module gz_MPI_particle_file_IO_b +!! +!!@author H.Matsui +!!@date Programmed in Aug., 2016 +! +!>@brief particle file IO for gxipped format +!! +!!@verbatim +!! subroutine gz_mpi_read_particle_file_b & +!! & (num_pe, id_rank, file_name, t_IO, particle_IO) +!! integer, intent(in) :: num_pe, id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(surf_edge_IO_file), intent(inout) :: particle_IO +!! type(time_data), intent(inout) :: t_IO +!! subroutine gz_mpi_write_particle_file_b & +!! & (file_name, t_IO, particle_IO) +!! character(len=kchara), intent(in) :: file_name +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!! type(time_data), intent(in) :: t_IO +!!@endverbatim + module gz_MPI_particle_file_IO_b +! + use m_precision + use m_machine_parameter +! + use m_calypso_mpi_IO + use t_time_data + use t_read_mesh_data + use t_calypso_mpi_IO_param + use gz_MPI_mesh_data_IO_b + use MPI_ascii_data_IO + use t_time_data +! + implicit none +! + type(calypso_MPI_IO_params), save, private :: IO_param +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine gz_mpi_read_particle_file_b & + & (num_pe, id_rank, file_name, t_IO, particle_IO) +! + use m_machine_parameter + use gz_MPI_binary_datum_IO + use MPI_binary_head_IO + use MPI_ascii_data_IO + use gz_field_block_MPI_IO_b +! + integer, intent(in) :: num_pe, id_rank + character(len=kchara), intent(in) :: file_name +! + type(surf_edge_IO_file), intent(inout) :: particle_IO + type(time_data), intent(inout) :: t_IO +! +! + if(my_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Read gzipped binary merged particle file: ', trim(file_name) +! + call open_read_gz_mpi_file_b & + & (file_name, num_pe, id_rank, IO_param) +! + call gz_mpi_read_domain_info_b(IO_param, particle_IO%comm) + call gz_mpi_read_geometry_info_b(IO_param, particle_IO%node) +! ---- read element data ------- + call gz_mpi_read_ele_info_b(IO_param, particle_IO%ele) + + call gz_mpi_read_vect_in_ele_b(IO_param, particle_IO%node, & + & particle_IO%sfed) + call gz_mpi_read_scl_in_ele_b(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call gz_read_step_data_mpi_b(IO_param, & + & t_IO%i_time_step, t_IO%time, t_IO%dt) + call close_mpi_file(IO_param) +! + end subroutine gz_mpi_read_particle_file_b +! +!------------------------------------------------------------------ +!------------------------------------------------------------------ +! + subroutine gz_mpi_write_particle_file_b & + & (file_name, t_IO, particle_IO) +! + use m_machine_parameter + use gz_MPI_binary_datum_IO + use MPI_binary_head_IO + use MPI_ascii_data_IO + use gz_field_block_MPI_IO_b +! + character(len=kchara), intent(in) :: file_name + type(surf_edge_IO_file), intent(in) :: particle_IO + type(time_data), intent(in) :: t_IO +! +! + if(my_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Write gzipped binary merged perticle file: ', trim(file_name) +! + call open_write_gz_mpi_file_b(file_name, IO_param) + call gz_mpi_write_domain_info_b(IO_param, particle_IO%comm) +! + call gz_mpi_write_geometry_info_b(IO_param, particle_IO%node) + call gz_mpi_write_element_info_b(IO_param, particle_IO%ele) +! + call gz_mpi_write_vect_in_ele_b(IO_param, particle_IO%node, & + & particle_IO%sfed) + call gz_mpi_write_scl_in_ele_b(IO_param, particle_IO%node, & + & particle_IO%sfed) +! + call gz_write_field_time_mpi_b(IO_param, & + & t_IO%i_time_step, t_IO%time, t_IO%dt) + call close_mpi_file(IO_param) +! + end subroutine gz_mpi_write_particle_file_b +! +! --------------------------------------------------------------------- +! + end module gz_MPI_particle_file_IO_b diff --git a/src/Fortran_libraries/VIZ_src/fieldline/gz_particle_file_IO.f90 b/src/Fortran_libraries/VIZ_src/fieldline/gz_particle_file_IO.f90 new file mode 100644 index 00000000..5519c61c --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/gz_particle_file_IO.f90 @@ -0,0 +1,142 @@ +!>@file gz_particle_file_IO.f90 +!! module gz_particle_file_IO +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2006 +! +!>@brief File IO for element communication table +!! +!!@verbatim +!! subroutine gz_read_particle_file & +!! & (id_rank, file_name, t_IO, particle_IO, ierr) +!! integer, intent(in) :: id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(inout) :: t_IO +!! type(surf_edge_IO_file), intent(inout) :: particle_IO +!! integer(kind = kint), intent(inout) :: ierr +!! subroutine gz_write_particle_file & +!! & (id_rank, file_name, t_IO, particle_IO) +!! integer, intent(in) :: id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(in) :: t_IO +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!!@endverbatim +!! +!!@param id_rank MPI rank +! + module gz_particle_file_IO +! + use m_precision + use m_machine_parameter +! + use m_file_format_switch + use t_read_mesh_data + use t_buffer_4_gzip + use t_time_data +! + implicit none +! + type(buffer_4_gzip), private :: zbuf_p + character, pointer, private, save :: FPz_p +! +!------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------ +! + subroutine gz_read_particle_file & + & (id_rank, file_name, t_IO, particle_IO, ierr) +! + use skip_gz_comment + use local_fline_restart_IO + use gzip_file_access + use gz_domain_data_IO + use gz_node_geometry_IO + use gz_element_connect_IO + use gz_field_data_IO +! + integer, intent(in) :: id_rank + character(len=kchara), intent(in) :: file_name +! + type(time_data), intent(inout) :: t_IO + type(surf_edge_IO_file), intent(inout) :: particle_IO + integer(kind = kint), intent(inout) :: ierr +! +! + if(id_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Read gzipped particle file: ', trim(file_name) +! + call open_rd_gzfile_a(FPz_p, file_name, zbuf_p) +! +! write(*,*) 'gz_read_domain_info' + call gz_read_domain_info & + & (FPz_p, id_rank, particle_IO%comm, zbuf_p, ierr) +! + call gz_read_geometry_info(FPz_p, particle_IO%node,zbuf_p) + call gz_read_element_info(FPz_p, particle_IO%ele, zbuf_p) +! + call gz_read_vector_in_element(FPz_p, particle_IO%node, & + & particle_IO%sfed, zbuf_p) + call gz_read_scalar_in_element(FPz_p, particle_IO%node, & + & particle_IO%sfed, zbuf_p) +! + call read_gz_step_data(FPz_p, id_rank, t_IO%i_time_step, & + & t_IO%time, t_IO%dt, zbuf_p, ierr) + call close_gzfile_a(FPz_p, zbuf_p) +! + end subroutine gz_read_particle_file +! +!------------------------------------------------------------------ +! + subroutine gz_write_particle_file & + & (id_rank, file_name, t_IO, particle_IO) +! + use m_fem_mesh_labels + use skip_gz_comment + use local_fline_restart_IO + use gzip_file_access + use gz_domain_data_IO + use gz_node_geometry_IO + use gz_element_connect_IO + use gz_field_data_IO +! + integer, intent(in) :: id_rank + character(len=kchara), intent(in) :: file_name + type(time_data), intent(in) :: t_IO + type(surf_edge_IO_file), intent(in) :: particle_IO +! +! + if(id_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Write gzipped particle file: ', trim(file_name) +! + call open_wt_gzfile_a(FPz_p, file_name, zbuf_p) +! + zbuf_p%fixbuf(1) = hd_fem_node() // char(0) + call gz_write_textbuf_no_lf(FPz_p, zbuf_p) +! + call gz_write_geometry_info(FPz_p, particle_IO%node, zbuf_p) +! + zbuf_p%fixbuf(1) = hd_particle_connect() // char(0) + call gz_write_textbuf_no_lf(FPz_p, zbuf_p) + call gz_write_element_info(FPz_p, particle_IO%ele, zbuf_p) +! + zbuf_p%fixbuf(1) = hd_particle_velocity() // char(0) + call gz_write_textbuf_no_lf(FPz_p, zbuf_p) + call gz_write_vector_in_element(FPz_p, particle_IO%node, & + & particle_IO%sfed, zbuf_p) +! + zbuf_p%fixbuf(1) = hd_particle_marker() // char(0) + call gz_write_textbuf_no_lf(FPz_p, zbuf_p) + call gz_write_scalar_in_element(FPz_p, particle_IO%node, & + & particle_IO%sfed, zbuf_p) +! + call write_gz_step_data(FPz_p, id_rank, t_IO%i_time_step, & + & t_IO%time, t_IO%dt, zbuf_p) + call close_gzfile_a(FPz_p, zbuf_p) +! + end subroutine gz_write_particle_file +! +!------------------------------------------------------------------ +! + end module gz_particle_file_IO diff --git a/src/Fortran_libraries/VIZ_src/fieldline/gz_particle_file_IO_b.f90 b/src/Fortran_libraries/VIZ_src/fieldline/gz_particle_file_IO_b.f90 new file mode 100644 index 00000000..afc91c5a --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/gz_particle_file_IO_b.f90 @@ -0,0 +1,143 @@ +!>@file gz_particle_file_IO_b.f90 +!! module gz_particle_file_IO_b +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2006 +! +!>@brief File IO for element communication table +!! +!!@verbatim +!! subroutine gz_read_particle_file_b(id_rank, file_name, & +!! & t_IO, particle_IO, ierr) +!! integer, intent(in) :: id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(inout) :: t_IO +!! type(surf_edge_IO_file), intent(inout) :: particle_IO +!! integer(kind = kint), intent(inout) :: ierr +!! subroutine gz_write_particle_file_b & +!! & (id_rank, file_name, t_IO, particle_IO) +!! integer, intent(in) :: id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(in) :: t_IO +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!!@endverbatim +!! +!!@param id_rank MPI rank +! + module gz_particle_file_IO_b +! + use m_precision + use m_machine_parameter +! + use m_file_format_switch + use t_read_mesh_data + use t_buffer_4_gzip + use t_time_data + use set_mesh_file_names + use binary_IO +! + implicit none +! + type(buffer_4_gzip), private, save :: zbuf_p + character, pointer, private, save :: FPz_p +! +!------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------ +! + subroutine gz_read_particle_file_b(id_rank, file_name, & + & t_IO, particle_IO, ierr) +! + use gzip_file_access + use gz_domain_data_IO_b + use gz_node_geometry_IO_b + use gz_element_connect_IO_b + use gz_field_data_IO_b +! + integer, intent(in) :: id_rank + character(len=kchara), intent(in) :: file_name +! + type(time_data), intent(inout) :: t_IO + type(surf_edge_IO_file), intent(inout) :: particle_IO + integer(kind = kint), intent(inout) :: ierr +! +! + if(id_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Read gzipped binary particle file: ', trim(file_name) +! + call open_rd_gzfile_b(FPz_p, file_name, id_rank, zbuf_p) + if(zbuf_p%ierr_zlib .ne. 0) go to 99 +! + call gz_read_domain_info_b(FPz_p, id_rank, zbuf_p, & + & particle_IO%comm) + if(zbuf_p%ierr_zlib .ne. 0) return +! + call gz_read_geometry_info_b(FPz_p, zbuf_p, particle_IO%node) + if(zbuf_p%ierr_zlib .ne. 0) return +! + call gz_read_element_info_b(FPz_p, zbuf_p, particle_IO%ele) + if(zbuf_p%ierr_zlib .ne. 0) return +! + call gz_read_vector_in_element_b(FPz_p, zbuf_p, particle_IO%node, & + & particle_IO%sfed) + if(zbuf_p%ierr_zlib .ne. 0) return +! + call gz_read_scalar_in_element_b(FPz_p, zbuf_p, particle_IO%node, & + & particle_IO%sfed) + if(zbuf_p%ierr_zlib .ne. 0) return +! + call gz_read_step_data_b(FPz_p, zbuf_p, id_rank, & + & t_IO%i_time_step, t_IO%time, t_IO%dt) +! + 99 continue + call close_gzfile_b(FPz_p) + ierr = zbuf_p%ierr_zlib +! + end subroutine gz_read_particle_file_b +! +!------------------------------------------------------------------ +! + subroutine gz_write_particle_file_b & + & (id_rank, file_name, t_IO, particle_IO) +! + use gzip_file_access + use gz_domain_data_IO_b + use gz_node_geometry_IO_b + use gz_element_connect_IO_b + use gz_field_data_IO_b +! + integer, intent(in) :: id_rank + character(len=kchara), intent(in) :: file_name + type(time_data), intent(in) :: t_IO + type(surf_edge_IO_file), intent(in) :: particle_IO +! +! + if(id_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Write gzipped binary particle file: ', trim(file_name) +! + call open_wt_gzfile_b(FPz_p, file_name, zbuf_p) +! + call gz_write_geometry_info_b(FPz_p, particle_IO%node, zbuf_p) + if(zbuf_p%ierr_zlib .ne. 0) return +! + call gz_write_element_info_b(FPz_p,particle_IO%ele, zbuf_p) + if(zbuf_p%ierr_zlib .ne. 0) return +! + call gz_write_vector_in_element_b(FPz_p, particle_IO%node, & + & particle_IO%sfed, zbuf_p) + if(zbuf_p%ierr_zlib .ne. 0) return +! + call gz_write_scalar_in_element_b(FPz_p, particle_IO%node, & + & particle_IO%sfed, zbuf_p) +! + call gz_write_step_data_b(FPz_p, id_rank, t_IO%i_time_step, & + & t_IO%time, t_IO%dt, zbuf_p) + call close_gzfile_b(FPz_p) +! + end subroutine gz_write_particle_file_b +! +!------------------------------------------------------------------ +! + end module gz_particle_file_IO_b diff --git a/src/Fortran_libraries/VIZ_src/fieldline/local_fline_restart_IO.f90 b/src/Fortran_libraries/VIZ_src/fieldline/local_fline_restart_IO.f90 new file mode 100644 index 00000000..d05b2d2e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/local_fline_restart_IO.f90 @@ -0,0 +1,256 @@ +!>@file local_fline_restart_IO.f90 +!!@brief module local_fline_restart_IO +!! +!!@author H.Matsui +!!@date Programmed in June, 2024 +! +!>@brief tracer or field line data in each domain +!! +!!@verbatim +!! subroutine copy_local_tracer_to_IO(fline_lc, particle_IO) +!! type(local_fieldline), intent(in) :: fline_lc +!! type(surf_edge_IO_file), intent(inout) :: particle_IO +!! subroutine copy_local_tracer_from_IO(particle_IO, fline_lc) +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!! type(local_fieldline), intent(inout) :: fline_lc +!! +!! character(len=ilen_hd_particle_connect) & +!! & function hd_particle_connect() +!! character(len=ilen_hd_particle_velocity) & +!! & function hd_particle_velocity() +!! character(len=ilen_hd_particle_marker) & +!! & function hd_particle_marker() +!!@endverbatim +! + module local_fline_restart_IO +! + use m_precision + use m_constants + use t_local_fline + use t_read_mesh_data + use calypso_mpi +! + implicit none +! +!> length of hd_particle_connect + integer(kind = kint), parameter & + & :: ilen_hd_particle_connect = 1+25+25+33+1+5 +!> length of ilen_hd_particle_marker + integer(kind = kint), parameter & + & :: ilen_hd_particle_velocity = 1+25+1+3 +!> length of hd_particle_marker + integer(kind = kint), parameter & + & :: ilen_hd_particle_marker = 1+22+1+3 +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine copy_local_tracer_to_IO(fline_lc, particle_IO) +! + use set_nnod_4_ele_by_type +! + type(local_fieldline), intent(in) :: fline_lc + type(surf_edge_IO_file), intent(inout) :: particle_IO +! + integer(kind = kint) :: i +! + particle_IO%comm%num_neib = 0 + call alloc_neighbouring_id(particle_IO%comm) +! + particle_IO%node%numnod = fline_lc%nnod_line_l + particle_IO%node%internal_node = fline_lc%nnod_line_l + call alloc_node_geometry_base(particle_IO%node) + call alloc_ele_vector_IO(particle_IO%node, particle_IO%sfed) + call alloc_ele_scalar_IO(particle_IO%node, particle_IO%sfed) +! +!$omp parallel do + do i = 1, fline_lc%nnod_line_l + particle_IO%node%inod_global(i) = fline_lc%iglobal_fline(i) + particle_IO%node%xx(i,1) = fline_lc%xx_line_l(1,i) + particle_IO%node%xx(i,2) = fline_lc%xx_line_l(2,i) + particle_IO%node%xx(i,3) = fline_lc%xx_line_l(3,i) +! + particle_IO%sfed%ele_vector(i,1) = fline_lc%v_line_l(1,i) + particle_IO%sfed%ele_vector(i,2) = fline_lc%v_line_l(2,i) + particle_IO%sfed%ele_vector(i,3) = fline_lc%v_line_l(3,i) +! + particle_IO%sfed%ele_scalar(i) = fline_lc%col_line_l(1,i) + end do +!$omp end parallel do +! + particle_IO%ele%numele = fline_lc%nnod_line_l + particle_IO%ele%nnod_4_ele = 2 +! + call alloc_element_types(particle_IO%ele) + call alloc_ele_connectivity(particle_IO%ele) +!$omp parallel do + do i = 1, fline_lc%nnod_line_l + particle_IO%ele%iele_global(i) = my_rank + particle_IO%ele%nodelm(i) = particle_IO%ele%nnod_4_ele + particle_IO%ele%elmtyp(i) & + & = linear_eletype_from_num(particle_IO%ele%nnod_4_ele) +! + particle_IO%ele%ie(i,1) = fline_lc%iedge_line_l(1,i) + particle_IO%ele%ie(i,2) = fline_lc%iedge_line_l(2,i) + end do +!$omp end parallel do +! + end subroutine copy_local_tracer_to_IO +! +! --------------------------------------------------------------------- +! + subroutine copy_local_tracer_from_IO(particle_IO, fline_lc) +! + type(surf_edge_IO_file), intent(inout) :: particle_IO + type(local_fieldline), intent(inout) :: fline_lc +! + integer(kind = kint) :: i +! +! + fline_lc%nnod_line_l = particle_IO%node%numnod + if(fline_lc%nnod_line_l .ge. fline_lc%nnod_line_buf) then + call raise_local_fline_data(fline_lc) + end if +! +!$omp parallel do + do i = 1, fline_lc%nnod_line_l + fline_lc%iglobal_fline(i) = particle_IO%node%inod_global(i) + fline_lc%xx_line_l(1,i) = particle_IO%node%xx(i,1) + fline_lc%xx_line_l(2,i) = particle_IO%node%xx(i,2) + fline_lc%xx_line_l(3,i) = particle_IO%node%xx(i,3) + fline_lc%v_line_l(1,i) = particle_IO%sfed%ele_vector(i,1) + fline_lc%v_line_l(2,i) = particle_IO%sfed%ele_vector(i,2) + fline_lc%v_line_l(3,i) = particle_IO%sfed%ele_vector(i,3) + fline_lc%col_line_l(1,i) = particle_IO%sfed%ele_scalar(i) + end do +!$omp end parallel do +! + fline_lc%nele_line_l = particle_IO%ele%numele + if(fline_lc%nele_line_l .ge. fline_lc%nele_line_buf) then + call raise_local_fline_connect(fline_lc) + end if +! +!$omp parallel do + do i = 1, fline_lc%nnod_line_l + fline_lc%iedge_line_l(1,i) = particle_IO%ele%ie(i,1) + fline_lc%iedge_line_l(2,i) = particle_IO%ele%ie(i,2) + end do +!$omp end parallel do +! + end subroutine copy_local_tracer_from_IO +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine field_on_local_tracer_to_IO(viz_fields, fline_lc, & + & fld_IO) +! + use t_ctl_params_viz_fields + use t_field_data_IO +! + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(local_fieldline), intent(in) :: fline_lc + type(field_IO), intent(inout) :: fld_IO +! + integer(kind = kint) :: i +! + fld_IO%num_field_IO = viz_fields%num_color_fields + call alloc_phys_name_IO(fld_IO) +! + fld_IO%istack_comp_IO(0) = 0 + do i = 1, fld_IO%num_field_IO + fld_IO%fld_name(i) = viz_fields%color_field_name(i) + fld_IO%num_comp_IO(i) = viz_fields%ncomp_color_field(i) + fld_IO%istack_comp_IO(i) = viz_fields%istack_color_field(i) + end do + + fld_IO%nnod_IO = fline_lc%nnod_line_l + fld_IO%ntot_comp_IO = fld_IO%istack_comp_IO(fld_IO%num_field_IO) + call alloc_phys_data_IO(fld_IO) + + do i = 1, fline_lc%ntot_comp_l + fld_IO%d_IO(1:fline_lc%nnod_line_l,i) & + & = fline_lc%col_line_l(i,1:fline_lc%nnod_line_l) + end do +! + end subroutine field_on_local_tracer_to_IO +! +! --------------------------------------------------------------------- +! + subroutine field_on_local_tracer_from_IO(fld_IO, viz_fields, & + & fline_lc) +! + use t_field_data_IO + use t_ctl_params_viz_fields +! + type(field_IO), intent(in) :: fld_IO + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(local_fieldline), intent(inout) :: fline_lc +! + integer(kind = kint) :: i, j, jj, num, ist, jst, nd +! +! + do i = 0, fline_lc%ntot_comp_l-1 + do j = 0, fld_IO%num_field_IO-1 + jj = mod(i+j, fld_IO%num_field_IO) + if(viz_fields%color_field_name(i+1) & + & .eq. fld_IO%fld_name(j+1)) then + num = viz_fields%ncomp_color_field(i) + ist = viz_fields%istack_color_field(i) + jst = fld_IO%istack_comp_IO(jj) + do nd = 1, num + fline_lc%col_line_l(nd+ist,1:fline_lc%nnod_line_l) & + & = fld_IO%d_IO(1:fline_lc%nnod_line_l,nd+jst) + end do + exit + end if + end do + end do +! + end subroutine field_on_local_tracer_from_IO +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + character(len=ilen_hd_particle_connect) & + & function hd_particle_connect() +! + hd_particle_connect & + & = '!' // char(10) & + & // '! 2 Particle indexing' // char(10) & + & // '! 2.1 local element ID' // char(10) & + & // '! and surface ID in elememnt' // char(10) & + & // '!' // char(10) +! + end function hd_particle_connect +! +!------------------------------------------------------------------ +! + character(len=ilen_hd_particle_velocity) & + & function hd_particle_velocity() +! + hd_particle_velocity & + & = '!' // char(10) & + & // '! 3.1 particle velocity' // char(10) & + & // '!' // char(10) +! + end function hd_particle_velocity +! +!------------------------------------------------------------------ +! + character(len=ilen_hd_particle_marker) & + & function hd_particle_marker() +! + hd_particle_marker & + & = '!' // char(10) & + & // '! 3.2 scalar marker' // char(10) & + & // '!' // char(10) +! + end function hd_particle_marker +! +!------------------------------------------------------------------ +! + end module local_fline_restart_IO diff --git a/src/Fortran_libraries/VIZ_src/fieldline/m_control_fline_flags.f90 b/src/Fortran_libraries/VIZ_src/fieldline/m_control_fline_flags.f90 new file mode 100644 index 00000000..b72ec62f --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/m_control_fline_flags.f90 @@ -0,0 +1,122 @@ +!>@file m_control_fline_flags.f90 +!!@brief module m_control_fline_flags +!! +!!@date Programmed by H.Matsui in Aug. 2011 +! +!>@brief control parameters for each field line +!! +!!@verbatim +!! subroutine fline_comm_mode_label_array(array_c) +!! subroutine fline_start_label_array(array_c) +!! subroutine fline_direction_label_array(array_c) +!! subroutine fline_seeds_label_array(array_c) +!!! type(ctl_array_chara), intent(inout) :: array_c +!!@endverbatim +! + module m_control_fline_flags +! + use m_precision +! + implicit none +! + character(len = kchara), parameter & + & :: cflag_send_recv = 'send_recv' + character(len = kchara), parameter & + & :: cflag_bcast = 'broadcast' +! + character(len = kchara), parameter & + & :: cflag_surface_group = 'surface_group' + character(len = kchara), parameter & + & :: cflag_surface_list = 'surface_list' + character(len = kchara), parameter & + & :: cflag_position_list = 'position_list' + character(len = kchara), parameter & + & :: cflag_spray_in_domain = 'spray_in_domain' + character(len = kchara), parameter & + & :: cflag_seed_from_tracer = 'tracer' +! + character(len = kchara), parameter & + & :: cflag_forward_trace = 'forward' + character(len = kchara), parameter & + & :: cflag_backward_trace = 'backward' + character(len = kchara), parameter & + & :: cflag_both_trace = 'both' +! + character(len = kchara), parameter & + & :: cflag_random_by_amp = 'amplitude' + character(len = kchara), parameter & + & :: cflag_random_by_area = 'area_size' + character(len = kchara), parameter & + & :: cflag_no_random = 'no_random' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine fline_comm_mode_label_array(array_c) + use t_control_array_character + type(ctl_array_chara), intent(inout) :: array_c +! + array_c%array_name = ' ' + array_c%num = 0 + call alloc_control_array_chara(array_c) +! + call append_c_to_ctl_array(cflag_send_recv, array_c) + call append_c_to_ctl_array(cflag_bcast, array_c) +! + end subroutine fline_comm_mode_label_array +! +! ---------------------------------------------------------------------- +! + subroutine fline_start_label_array(array_c) + use t_control_array_character + type(ctl_array_chara), intent(inout) :: array_c +! + array_c%array_name = ' ' + array_c%num = 0 + call alloc_control_array_chara(array_c) +! + call append_c_to_ctl_array(cflag_surface_group, array_c) + call append_c_to_ctl_array(cflag_surface_list, array_c) + call append_c_to_ctl_array(cflag_position_list, array_c) + call append_c_to_ctl_array(cflag_spray_in_domain, array_c) +! + end subroutine fline_start_label_array +! +! ---------------------------------------------------------------------- +! + subroutine fline_direction_label_array(array_c) + use t_control_array_character + type(ctl_array_chara), intent(inout) :: array_c +! + array_c%array_name = ' ' + array_c%num = 0 + call alloc_control_array_chara(array_c) +! + call append_c_to_ctl_array(cflag_forward_trace, array_c) + call append_c_to_ctl_array(cflag_backward_trace, array_c) + call append_c_to_ctl_array(cflag_both_trace, array_c) +! + end subroutine fline_direction_label_array +! +! ---------------------------------------------------------------------- +! + subroutine fline_seeds_label_array(array_c) + use t_control_array_character + type(ctl_array_chara), intent(inout) :: array_c +! + array_c%array_name = ' ' + array_c%num = 0 + call alloc_control_array_chara(array_c) +! + call append_c_to_ctl_array(cflag_random_by_amp, array_c) + call append_c_to_ctl_array(cflag_random_by_area, array_c) + call append_c_to_ctl_array(cflag_no_random, array_c) +! + end subroutine fline_seeds_label_array +! +! ---------------------------------------------------------------------- +! + end module m_control_fline_flags diff --git a/src/Fortran_libraries/VIZ_src/fieldline/multi_trace_particle.f90 b/src/Fortran_libraries/VIZ_src/fieldline/multi_trace_particle.f90 new file mode 100644 index 00000000..a9c5cbfc --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/multi_trace_particle.f90 @@ -0,0 +1,176 @@ +!>@file multi_trace_particle.f90 +!!@brief module multi_trace_particle +!! +!!@author H. Matsui +!!@date Programmed in May, 2024 +! +!> @brief Main routine for field line module +!! +!!@verbatim +!! subroutine set_tracer_controls(mesh, group, nod_fld, & +!! & num_fline, fline_ctls, fln_prm) +!! type(mesh_geometry), intent(in) :: mesh +!! type(mesh_groups), intent(in) :: group +!! type(phys_data), intent(in) :: nod_fld +!! integer(kind = kint), intent(in) ::num_fline +!! type(fieldline_controls), intent(inout) :: fline_ctls +!! type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) +!! +!! subroutine s_multi_trace_particle(time_d, elps_tracer, & +!! & mesh, para_surf, nod_fld, num_trace, fln_prm, fln_src,& +!! & fln_tce, fline_lc, fln_SR, fln_bcast, m_SR) +!! type(time_data), intent(in) :: time_d +!! type(elapsed_lables), intent(in) :: elps_tracer +!! type(mesh_geometry), intent(in) :: mesh +!! type(paralell_surface_indices), intent(in) :: para_surf +!! type(phys_data), intent(in) :: nod_fld +!! integer(kind = kint), intent(in) :: num_trace +!! type(fieldline_paramter), intent(in) :: fln_prm(num_trace) +!! type(each_fieldline_source), intent(inout) & +!! & :: fln_src(num_trace) +!! type(each_fieldline_trace), intent(inout) :: fln_tce(num_trace) +!! type(local_fieldline), intent(inout) ::fline_lc(num_trace) +!! type(trace_data_send_recv), intent(inout) :: fln_SR(num_trace) +!! type(broadcast_trace_data), intent(inout) & +!! & :: fln_bcast(num_trace) +!! type(mesh_SR), intent(inout) :: m_SR +!! +!! subroutine alloc_each_TRACER_data(node, num_trace, fln_src) +!! type(node_data), intent(in) :: node +!! integer(kind = kint), intent(in) :: num_trace +!! type(each_fieldline_source), intent(inout) & +!! & :: fln_src(num_trace) +!! subroutine dealloc_each_TRACER_data(num_trace, fln_src) +!! integer(kind = kint), intent(in) :: num_trace +!! type(each_fieldline_source), intent(inout) & +!! & :: fln_src(num_trace) +!!@endverbatim +! + module multi_trace_particle +! + use m_precision +! + use m_machine_parameter + use m_geometry_constants +! + use t_time_data + use t_mesh_data + use t_phys_data + use t_parallel_surface_indices + use t_control_params_4_fline + use t_source_of_filed_line + use t_trace_data_send_recv + use t_broadcast_trace_data + use t_tracing_data + use t_local_fline + use t_ucd_data +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_tracer_controls(mesh, group, nod_fld, & + & num_fline, fline_ctls, fln_prm) +! + use t_control_data_flines + use set_fline_control + + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(phys_data), intent(in) :: nod_fld +! + integer(kind = kint), intent(in) ::num_fline + type(fieldline_controls), intent(inout) :: fline_ctls +! + type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) +! + integer(kind = kint) :: i_fln +! + do i_fln = 1, num_fline + call s_set_tracer_control(mesh, group, nod_fld, & + & fline_ctls%fline_ctl_struct(i_fln), fln_prm(i_fln)) + end do +! + end subroutine set_tracer_controls +! +! --------------------------------------------------------------------- +! + subroutine s_multi_trace_particle(time_d, elps_tracer, & + & mesh, para_surf, nod_fld, num_trace, fln_prm, fln_src, & + & fln_tce, fline_lc, fln_SR, fln_bcast, m_SR) +! + use m_work_time + use trace_particle +! + type(time_data), intent(in) :: time_d + type(elapsed_lables), intent(in) :: elps_tracer + type(mesh_geometry), intent(in) :: mesh + type(paralell_surface_indices), intent(in) :: para_surf + type(phys_data), intent(in) :: nod_fld +! + integer(kind = kint), intent(in) :: num_trace + type(fieldline_paramter), intent(in) :: fln_prm(num_trace) + type(each_fieldline_source), intent(inout) :: fln_src(num_trace) + type(each_fieldline_trace), intent(inout) :: fln_tce(num_trace) + type(local_fieldline), intent(inout) :: fline_lc(num_trace) + type(trace_data_send_recv), intent(inout) :: fln_SR(num_trace) + type(broadcast_trace_data), intent(inout) :: fln_bcast(num_trace) + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_fln +! + do i_fln = 1, num_trace + if (iflag_debug.eq.1) write(*,*) & + & 's_trace_particle start', i_fln + call s_trace_particle & + & (time_d%dt, elps_tracer, mesh, para_surf, nod_fld, & + & fln_prm(i_fln), fln_tce(i_fln), fline_lc(i_fln), & + & fln_SR(i_fln), fln_bcast(i_fln), fln_src(i_fln)%v_prev, & + & m_SR) + end do +! + end subroutine s_multi_trace_particle +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine alloc_each_TRACER_data(node, num_trace, fln_src) +! + type(node_data), intent(in) :: node + integer(kind = kint), intent(in) :: num_trace +! + type(each_fieldline_source), intent(inout) & + & :: fln_src(num_trace) +! + integer(kind = kint) :: i_fln +! + do i_fln = 1, num_trace + call alloc_velocity_at_previous(node%numnod, fln_src(i_fln)) + end do +! + end subroutine alloc_each_TRACER_data +! +! --------------------------------------------------------------------- +! + subroutine dealloc_each_TRACER_data(num_trace, fln_src) +! + integer(kind = kint), intent(in) :: num_trace + type(each_fieldline_source), intent(inout) & + & :: fln_src(num_trace) +! + integer(kind = kint) :: i_fln +! + if (num_trace .le. 0) return + do i_fln = 1, num_trace + call dealloc_velocity_at_previous(fln_src(i_fln)) + end do +! + end subroutine dealloc_each_TRACER_data +! +! --------------------------------------------------------------------- +! + end module multi_trace_particle diff --git a/src/Fortran_libraries/VIZ_src/fieldline/multi_tracer_fieldline.f90 b/src/Fortran_libraries/VIZ_src/fieldline/multi_tracer_fieldline.f90 new file mode 100644 index 00000000..57c562f7 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/multi_tracer_fieldline.f90 @@ -0,0 +1,224 @@ +!>@file multi_tracer_fieldline.f90 +!!@brief module multi_tracer_fieldline +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Main routine for field line module +!! +!!@verbatim +!! subroutine alloc_each_FLINE_data(num_fline, fln_prm, fln_src, & +!! & fln_tce, fline_lc, & +!! & fln_SR, fln_bcast) +!! subroutine dealloc_each_FLINE_data(num_fline, fln_prm, fln_src, & +!! & fln_tce, fline_lc, & +!! & fln_SR, fln_bcast) +!! integer(kind = kint), intent(in) :: num_fline +!! type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) +!! type(each_fieldline_source), intent(inout):: fln_src(num_fline) +!! type(each_fieldline_trace), intent(inout) :: fln_tce(num_fline) +!! type(local_fieldline), intent(inout) :: fline_lc(num_fline) +!! type(trace_data_send_recv), intent(inout) :: fln_SR(num_fline) +!! type(broadcast_trace_data),intent(inout):: fln_bcast(num_fline) +!! +!! subroutine set_fixed_FLINE_seed_points(mesh, num_fline, & +!! & fln_prm, fln_src) +!! type(mesh_geometry), intent(in) :: mesh +!! integer(kind = kint), intent(in) :: num_fline +!! type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) +!! type(each_fieldline_source),intent(inout) :: fln_src(num_fline) +!! type(each_fieldline_trace), intent(inout) :: fln_tce(num_fline) +!! subroutine set_FLINE_seed_fields(mesh, group, para_surf, & +!! & nod_fld, num_fline, fln_prm, fln_src, fln_tce) +!! type(mesh_geometry), intent(in) :: mesh +!! type(mesh_groups), intent(in) :: group +!! type(paralell_surface_indices), intent(in) :: para_surf +!! type(phys_data), intent(in) :: nod_fld +!! integer(kind = kint), intent(in) :: num_fline +!! type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) +!! type(each_fieldline_source), intent(inout):: fln_src(num_fline) +!! type(each_fieldline_trace), intent(inout) :: fln_tce(num_fline) +!!@endverbatim +! + module multi_tracer_fieldline +! + use m_precision +! + use m_machine_parameter + use m_geometry_constants + use t_time_data + use t_mesh_data + use t_phys_data + use t_parallel_surface_indices + use t_control_params_4_fline + use t_source_of_filed_line + use t_trace_data_send_recv + use t_broadcast_trace_data + use t_tracing_data + use t_local_fline + use t_IO_step_parameter + use t_ucd_data +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_each_FLINE_data(num_fline, fln_prm, fln_src, & + & fln_tce, fline_lc, & + & fln_SR, fln_bcast) +! + integer(kind = kint), intent(in) :: num_fline +! + type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) + type(each_fieldline_source), intent(inout) :: fln_src(num_fline) + type(each_fieldline_trace), intent(inout) :: fln_tce(num_fline) + type(local_fieldline), intent(inout) :: fline_lc(num_fline) + type(trace_data_send_recv), intent(inout) :: fln_SR(num_fline) + type(broadcast_trace_data), intent(inout) :: fln_bcast(num_fline) +! + integer(kind = kint) :: i_fln +! +! + do i_fln = 1, num_fline + call alloc_start_point_fline(nprocs, fln_prm(i_fln), & + & fln_src(i_fln)) + call alloc_num_gl_start_fline(nprocs, & + & fln_prm(i_fln)%fline_fields, fln_tce(i_fln)) + call alloc_broadcast_trace_data & + & (fln_prm(i_fln)%num_each_field_line, & + & fln_prm(i_fln)%fline_fields, fln_bcast(i_fln)) + call alloc_local_fline(fln_prm(i_fln)%fline_fields, & + & fline_lc(i_fln)) + call alloc_trace_data_SR_num(fln_prm(i_fln)%fline_fields, & + & fln_SR(i_fln)) + end do +! + end subroutine alloc_each_FLINE_data +! +! --------------------------------------------------------------------- +! + subroutine dealloc_each_FLINE_data(num_fline, fln_prm, fln_src, & + & fln_tce, fline_lc, & + & fln_SR, fln_bcast) +! + integer(kind = kint), intent(in) :: num_fline +! + type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) + type(each_fieldline_source), intent(inout) :: fln_src(num_fline) + type(each_fieldline_trace), intent(inout) :: fln_tce(num_fline) + type(local_fieldline), intent(inout) :: fline_lc(num_fline) + type(trace_data_send_recv), intent(inout) :: fln_SR(num_fline) + type(broadcast_trace_data), intent(inout) :: fln_bcast(num_fline) +! + integer(kind = kint) :: i_fln +! +! + if (num_fline .le. 0) return +! + do i_fln = 1, num_fline + call dealloc_local_fline(fline_lc(i_fln)) + call dealloc_iflag_fline_used_ele(fln_prm(i_fln)) + call dealloc_fline_starts_ctl(fln_prm(i_fln)) +! + call dealloc_start_point_fline(fln_src(i_fln)) + call dealloc_num_gl_start_fline(fln_tce(i_fln)) + call dealloc_broadcast_trace_data(fln_bcast(i_fln)) + call dealloc_trace_data_SR_num(fln_SR(i_fln)) + end do +! + end subroutine dealloc_each_FLINE_data +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_fixed_FLINE_seed_points(mesh, num_fline, & + & fln_prm, fln_src) +! + use m_connect_hexa_2_tetra + use t_find_interpolate_in_ele + use set_fline_control + use set_fline_seeds_from_list +! + type(mesh_geometry), intent(in) :: mesh + integer(kind = kint), intent(in) :: num_fline + type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) + type(each_fieldline_source), intent(inout) :: fln_src(num_fline) +! +! + integer(kind = kint) :: i_fln + type(FLINE_element_size) :: fln_dist + logical :: flag_fln_dist +! +! + flag_fln_dist = .FALSE. + do i_fln = 1, num_fline + if(fln_prm(i_fln)%id_fline_seed_type & + & .eq. iflag_position_list) flag_fln_dist = .TRUE. + end do + if(flag_fln_dist) then + call alloc_FLINE_element_size(mesh%ele, fln_dist) + call cal_FLINE_element_size(mesh%node, mesh%ele, fln_dist) + end if + do i_fln = 1, num_fline + if(fln_prm(i_fln)%id_fline_seed_type & + & .eq. iflag_position_list) then + call alloc_init_tracer_position(fln_prm(i_fln), & + & fln_src(i_fln)) + call init_FLINE_seed_from_list(mesh%node, mesh%ele, & + & fln_prm(i_fln), fln_src(i_fln), fln_dist) + end if + end do + if(flag_fln_dist) call dealloc_FLINE_element_size(fln_dist) +! + end subroutine set_fixed_FLINE_seed_points +! +! --------------------------------------------------------------------- +! + subroutine set_FLINE_seed_fields(mesh, group, para_surf, & + & nod_fld, num_fline, fln_prm, fln_src, fln_tce) +! + use set_fields_for_fieldline + use const_field_lines + use collect_fline_data + use parallel_ucd_IO_select + use set_fline_seeds_from_list +! +! + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(paralell_surface_indices), intent(in) :: para_surf + type(phys_data), intent(in) :: nod_fld +! + integer(kind = kint), intent(in) :: num_fline + type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) + type(each_fieldline_source), intent(inout) :: fln_src(num_fline) + type(each_fieldline_trace), intent(inout) :: fln_tce(num_fline) +! + integer(kind = kint) :: i_fln +! + do i_fln = 1, num_fline + if(fln_prm(i_fln)%id_fline_seed_type & + & .eq. iflag_position_list) then + else if(fln_prm(i_fln)%id_fline_seed_type & + & .eq. iflag_position_list) then + call count_FLINE_seed_from_list & + & (fln_prm(i_fln), fln_src(i_fln), fln_tce(i_fln)) + call set_FLINE_seed_field_from_list & + & (mesh%node, mesh%ele, nod_fld, & + & fln_prm(i_fln), fln_src(i_fln), fln_tce(i_fln)) + else + call s_set_fields_for_fieldline & + & (mesh, group, para_surf, nod_fld, & + & fln_prm(i_fln), fln_src(i_fln), fln_tce(i_fln)) + end if + end do +! + end subroutine set_FLINE_seed_fields +! +! --------------------------------------------------------------------- +! + end module multi_tracer_fieldline diff --git a/src/Fortran_libraries/VIZ_src/fieldline/multi_tracer_file_IO.f90 b/src/Fortran_libraries/VIZ_src/fieldline/multi_tracer_file_IO.f90 new file mode 100644 index 00000000..c735a199 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/multi_tracer_file_IO.f90 @@ -0,0 +1,247 @@ +!>@file multi_tracer_file_IO.f90 +!!@brief module multi_tracer_file_IO +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Main routine for field line module +!! +!!@verbatim +!! subroutine output_tracer_restarts(time_d, finish_d, rst_step, & +!! & num_fline, fln_prm, fline_lc) +!! type(time_data), intent(in) :: time_d +!! type(finish_data), intent(in) :: finish_d +!! type(IO_step_param), intent(in) :: rst_step +!! integer(kind = kint), intent(in) :: num_fline +!! type(fieldline_paramter), intent(in) :: fln_prm(num_fline) +!! type(local_fieldline), intent(inout) :: fline_lc(num_fline) +!! subroutine input_tracer_restarts(init_d, rst_step, num_fline, & +!! & fln_prm, fline_lc) +!! type(time_data), intent(in) :: init_d +!! type(IO_step_param), intent(in) :: rst_step +!! integer(kind = kint), intent(in) :: num_fline +!! type(fieldline_paramter), intent(in) :: fln_prm(num_fline) +!! type(local_fieldline), intent(inout) :: fline_lc(num_fline) +!! subroutine sel_input_tracer_restarts(init_d, rst_step, & +!! & num_fline, fln_prm, fln_tce, fline_lc) +!! type(time_data), intent(in) :: init_d +!! type(IO_step_param), intent(in) :: rst_step +!! integer(kind = kint), intent(in) :: num_fline +!! type(fieldline_paramter), intent(in) :: fln_prm(num_fline) +!! type(each_fieldline_trace), intent(inout) :: fln_tce(num_fline) +!! type(local_fieldline), intent(inout) :: fline_lc(num_fline) +!! +!! subroutine output_tracer_viz_files(istep_file, time_d, & +!! & num_fline,fln_prm, fline_lc) +!! integer(kind = kint), intent(in) :: istep_file +!! type(time_data), intent(in) :: time_d +!! integer(kind = kint), intent(in) :: num_fline +!! type(fieldline_paramter), intent(in) :: fln_prm(num_fline) +!! type(local_fieldline), intent(in) :: fline_lc(num_fline) +!! subroutine output_field_lines(istep_file, time_d, & +!! & num_fline, fln_prm, fline_lc) +!! integer(kind = kint), intent(in) :: istep_file +!! type(time_data), intent(in) :: time_d +!! integer(kind = kint), intent(in) :: num_fline +!! type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) +!! type(local_fieldline), intent(inout) :: fline_lc(num_fline) +!!@endverbatim +! + module multi_tracer_file_IO +! + use m_precision +! + use m_machine_parameter + use m_geometry_constants + use t_time_data + use t_mesh_data + use t_phys_data + use t_parallel_surface_indices + use t_control_params_4_fline + use t_source_of_filed_line + use t_trace_data_send_recv + use t_broadcast_trace_data + use t_tracing_data + use t_local_fline + use t_IO_step_parameter + use t_ucd_data +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine output_tracer_restarts(time_d, finish_d, rst_step, & + & num_fline, fln_prm, fline_lc) +! + use tracer_restart_file_IO +! + type(time_data), intent(in) :: time_d + type(finish_data), intent(in) :: finish_d + type(IO_step_param), intent(in) :: rst_step +! + integer(kind = kint), intent(in) :: num_fline + type(fieldline_paramter), intent(in) :: fln_prm(num_fline) + type(local_fieldline), intent(inout) :: fline_lc(num_fline) +! + integer(kind = kint) :: i_fln, istep_rst +! + if(output_IO_flag(time_d%i_time_step, rst_step)) then + istep_rst = set_IO_step(time_d%i_time_step, rst_step) + do i_fln = 1, num_fline + call output_tracer_restart(fln_prm(i_fln)%fline_rst_IO, & + & istep_rst, time_d, fln_prm(i_fln)%fline_fields, & + & fline_lc(i_fln)) + end do + end if +! + if(finish_d%flag_terminate_by_elapsed) then + do i_fln = 1, num_fline + call output_tracer_restart(fln_prm(i_fln)%fline_rst_IO, & + & -1, time_d, fln_prm(i_fln)%fline_fields, & + & fline_lc(i_fln)) + end do + end if +! + end subroutine output_tracer_restarts +! +! --------------------------------------------------------------------- +! + subroutine input_tracer_restarts(init_d, rst_step, num_fline, & + & fln_prm, fline_lc) +! + use trace_particle + use tracer_restart_file_IO +! + type(time_data), intent(in) :: init_d + type(IO_step_param), intent(in) :: rst_step +! + integer(kind = kint), intent(in) :: num_fline + type(fieldline_paramter), intent(in) :: fln_prm(num_fline) + type(local_fieldline), intent(inout) :: fline_lc(num_fline) +! + integer(kind = kint) :: i_fln, istep_rst +! +! + istep_rst = set_IO_step(init_d%i_time_step, rst_step) + do i_fln = 1, num_fline + call input_tracer_restart(fln_prm(i_fln)%fline_rst_IO, & + & istep_rst, init_d, fln_prm(i_fln)%fline_fields, & + & fline_lc(i_fln)) + end do +! + end subroutine input_tracer_restarts +! +! --------------------------------------------------------------------- +! + subroutine sel_input_tracer_restarts(init_d, rst_step, & + & num_fline, fln_prm, fln_tce, fline_lc) +! + use trace_particle + use tracer_restart_file_IO +! + type(time_data), intent(in) :: init_d + type(IO_step_param), intent(in) :: rst_step +! + integer(kind = kint), intent(in) :: num_fline + type(fieldline_paramter), intent(in) :: fln_prm(num_fline) + type(each_fieldline_trace), intent(inout) :: fln_tce(num_fline) + type(local_fieldline), intent(inout) :: fline_lc(num_fline) +! + integer(kind = kint) :: i_fln, istep_rst, ntot_comp +! +! + istep_rst = set_IO_step(init_d%i_time_step, rst_step) + write(*,*) 'istep_rst', istep_rst, init_d%i_time_step + do i_fln = 1, num_fline + ntot_comp = fln_prm(i_fln)%fline_fields%ntot_color_comp +! + if(fln_prm(i_fln)%id_fline_seed_type & + & .eq. iflag_read_reastart) then + call input_tracer_restart(fln_prm(i_fln)%fline_rst_IO, & + & istep_rst, init_d, fln_prm(i_fln)%fline_fields, & + & fline_lc(i_fln)) + else + call local_tracer_from_seeds(fln_prm(i_fln), fln_tce(i_fln), & + & fline_lc(i_fln)) + call output_tracer_restart(fln_prm(i_fln)%fline_rst_IO, & + & istep_rst, init_d, fln_prm(i_fln)%fline_fields, & + & fline_lc(i_fln)) + end if + end do +! + end subroutine sel_input_tracer_restarts +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine output_tracer_viz_files(istep_file, time_d, & + & num_fline,fln_prm, fline_lc) +! + use t_mesh_SR + use collect_fline_data + use parallel_ucd_IO_select +! + integer(kind = kint), intent(in) :: istep_file + type(time_data), intent(in) :: time_d +! + integer(kind = kint), intent(in) :: num_fline + type(fieldline_paramter), intent(in) :: fln_prm(num_fline) + type(local_fieldline), intent(in) :: fline_lc(num_fline) +! + type(time_data) :: t_IO + type(ucd_data) :: fline_ucd + integer(kind = kint) :: i_fln +! +! + do i_fln = 1, num_fline + call copy_time_step_size_data(time_d, t_IO) + call copy_local_particles_to_IO & + & (fln_prm(i_fln)%fline_fields, fline_lc(i_fln), fline_ucd) + call sel_write_parallel_ucd_file & + & (istep_file, fln_prm(i_fln)%fline_file_IO, t_IO, fline_ucd) + call deallocate_parallel_ucd_mesh(fline_ucd) + end do +! + end subroutine output_tracer_viz_files +! +! --------------------------------------------------------------------- +! + subroutine output_field_lines(istep_file, time_d, & + & num_fline, fln_prm, fline_lc) +! + use set_fields_for_fieldline + use collect_fline_data + use parallel_ucd_IO_select + use set_fline_seeds_from_list + use parallel_ucd_IO_select +! + integer(kind = kint), intent(in) :: istep_file + type(time_data), intent(in) :: time_d + integer(kind = kint), intent(in) :: num_fline + type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) + type(local_fieldline), intent(inout) :: fline_lc(num_fline) +! + type(time_data) :: t_IO + type(ucd_data) :: fline_ucd + integer(kind = kint) :: i_fln +! +! + do i_fln = 1, num_fline + call copy_time_step_size_data(time_d, t_IO) + call copy_local_fieldline_to_IO(fln_prm(i_fln)%fline_fields, & + & fline_lc(i_fln), fline_ucd) + call sel_write_parallel_ucd_file & + & (istep_file, fln_prm(i_fln)%fline_file_IO, t_IO, fline_ucd) + call deallocate_parallel_ucd_mesh(fline_ucd) + call calypso_mpi_barrier + end do +! + end subroutine output_field_lines +! +! --------------------------------------------------------------------- +! + end module multi_tracer_file_IO diff --git a/src/Fortran_libraries/VIZ_src/fieldline/particle_MPI_IO_select.F90 b/src/Fortran_libraries/VIZ_src/fieldline/particle_MPI_IO_select.F90 new file mode 100644 index 00000000..9a151e26 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/particle_MPI_IO_select.F90 @@ -0,0 +1,146 @@ +!>@file particle_MPI_IO_select.f90 +!!@brief module particle_MPI_IO_select +!! +!!@author H.Matsui +!!@date Programmed by H.Matsui in Apr., 2006 +! +!>@brief Choose mesh file to read +!! +!!@verbatim +!! subroutine sel_mpi_read_particle_file(mesh_file, istep_file, & +!! & t_IO, particle_IO) +!! integer(kind = kint), intent(in) :: istep_file +!! type(field_IO_params), intent(in) :: mesh_file +!! type(time_data), intent(inout) :: t_IO +!! type(surf_edge_IO_file), intent(inout) :: particle_IO +!! +!! subroutine sel_mpi_write_particle_file(mesh_file, istep_file, & +!! & t_IO, particle_IO) +!! integer(kind = kint), intent(in) :: istep_file +!! type(field_IO_params), intent(in) :: mesh_file +!! type(time_data), intent(in) :: t_IO +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!!@endverbatim +! + module particle_MPI_IO_select +! + use m_precision + use calypso_mpi +! + use m_file_format_switch + use t_file_IO_parameter + use t_mesh_data + use t_time_data +! + use particle_file_IO_select +! + use MPI_particle_file_IO + use MPI_particle_file_IO_b + use mesh_file_name_by_param + use element_mesh_IO_select +! +#ifdef ZLIB_IO + use gz_MPI_particle_file_IO + use gz_MPI_particle_file_IO_b +#endif +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine sel_mpi_read_particle_file(mesh_file, istep_file, & + & t_IO, particle_IO) +! + use set_element_mesh_file_names +! + integer(kind = kint), intent(in) :: istep_file + type(field_IO_params), intent(in) :: mesh_file + type(time_data), intent(inout) :: t_IO + type(surf_edge_IO_file), intent(inout) :: particle_IO +! + character(len=kchara) :: file_name + integer(kind = kint) :: ierr = 0 +! +! + file_name = set_tracer_file_name(mesh_file%file_prefix, & + & mesh_file%iflag_format, & + & my_rank, istep_file) +! + if(mesh_file%iflag_format & + & .eq. iflag_single+id_binary_file_fmt) then + call mpi_read_particle_file_b & + & (nprocs, my_rank, file_name, t_IO, particle_IO) + else if(mesh_file%iflag_format .eq. iflag_single) then + call mpi_read_perticle_file & + & (nprocs, my_rank, file_name, t_IO, particle_IO) +! +#ifdef ZLIB_IO + else if(mesh_file%iflag_format & + & .eq. iflag_single+id_gzip_bin_file_fmt) then + call gz_mpi_read_particle_file_b(nprocs, my_rank, file_name, & + & t_IO, particle_IO) + else if(mesh_file%iflag_format & + & .eq. iflag_single+id_gzip_txt_file_fmt) then + call gz_mpi_read_particle_file(nprocs, my_rank, & + & file_name, t_IO, particle_IO) +#endif +! + else + call sel_read_particle_file(mesh_file, my_rank, istep_file, & + & t_IO, particle_IO, ierr) + end if +! + if(ierr .gt. 0) then + call calypso_mpi_abort(ierr, 'Tracer data is wrong!!') + end if +! + end subroutine sel_mpi_read_particle_file +! +!------------------------------------------------------------------ +! + subroutine sel_mpi_write_particle_file(mesh_file, istep_file, & + & t_IO, particle_IO) +! + use set_element_mesh_file_names +! + integer(kind = kint), intent(in) :: istep_file + type(field_IO_params), intent(in) :: mesh_file + type(time_data), intent(in) :: t_IO + type(surf_edge_IO_file), intent(in) :: particle_IO +! + character(len=kchara) :: file_name +! + file_name = set_tracer_file_name(mesh_file%file_prefix, & + & mesh_file%iflag_format, & + & my_rank, istep_file) +! + if(mesh_file%iflag_format & + & .eq. iflag_single+id_binary_file_fmt) then + call mpi_write_particle_file_b(file_name, t_IO, particle_IO) + else if(mesh_file%iflag_format .eq. iflag_single) then + call mpi_write_perticle_file(file_name, t_IO, particle_IO) +! +#ifdef ZLIB_IO + else if(mesh_file%iflag_format & + & .eq. iflag_single+id_gzip_bin_file_fmt) then + call gz_mpi_write_particle_file_b(file_name, t_IO, particle_IO) + else if(mesh_file%iflag_format & + & .eq. iflag_single+id_gzip_txt_file_fmt) then + call gz_mpi_write_particle_file(file_name, t_IO, particle_IO) +#endif +! + else + call sel_write_particle_file(mesh_file, my_rank, istep_file, & + & t_IO, particle_IO) + end if +! + end subroutine sel_mpi_write_particle_file +! +! --------------------------------------------------------------------- +! + end module particle_MPI_IO_select diff --git a/src/Fortran_libraries/VIZ_src/fieldline/particle_file_IO.f90 b/src/Fortran_libraries/VIZ_src/fieldline/particle_file_IO.f90 new file mode 100644 index 00000000..b16ac84c --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/particle_file_IO.f90 @@ -0,0 +1,141 @@ +!>@file particle_file_IO.f90 +!! module particle_file_IO +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2006 +! +!>@brief File IO for element communication table +!! +!!@verbatim +!! subroutine read_particle_file & +!! & (id_rank, file_name, t_IO, particle_IO, ierr) +!! integer, intent(in) :: id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(inout) :: t_IO +!! type(surf_edge_IO_file), intent(inout) :: particle_IO +!! integer(kind = kint), intent(inout) :: ierr +!! subroutine write_particle_file & +!! & (id_rank, file_name, t_IO, particle_IO) +!! integer, intent(in) :: id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(in) :: t_IO +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!!@endverbatim +!! +!!@param id_rank MPI rank +! + module particle_file_IO +! + use m_precision + use m_machine_parameter +! + use m_file_format_switch + use t_read_mesh_data + use set_mesh_file_names + use t_time_data +! + implicit none +! +! mesh file code + integer(kind = kint), parameter :: input_file_code = 14 + private :: input_file_code +! +!------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------ +! + subroutine read_particle_file & + & (id_rank, file_name, t_IO, particle_IO, ierr) +! + use m_fem_mesh_labels + use mesh_data_IO + use time_data_IO + use local_fline_restart_IO +! + integer, intent(in) :: id_rank + character(len=kchara), intent(in) :: file_name + type(time_data), intent(inout) :: t_IO + type(surf_edge_IO_file), intent(inout) :: particle_IO +! + integer(kind = kint), intent(inout) :: ierr +! +! + if(id_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Read ascii particle file: ', trim(file_name) +! + open(input_file_code, file = file_name, form = 'formatted') +! + call read_domain_info(input_file_code, id_rank, & + & particle_IO%comm, ierr) + if(ierr .ne. 0) go to 99 +! + call read_geometry_info(input_file_code, particle_IO%node, ierr) + if(ierr .ne. 0) go to 99 +! + call read_element_info(input_file_code, particle_IO%ele, ierr) + if(ierr .ne. 0) go to 99 +! + call read_vector_in_element(input_file_code, particle_IO%node, & + & particle_IO%sfed, ierr) + if(ierr .ne. 0) go to 99 +! + call read_scalar_in_element(input_file_code, particle_IO%node, & + & particle_IO%sfed, ierr) + if(ierr .ne. 0) go to 99 +! + call read_step_data(input_file_code, t_IO, ierr) + + 99 continue + close(input_file_code) +! + end subroutine read_particle_file +! +! --------------------------------------------------------------------- +! + subroutine write_particle_file & + & (id_rank, file_name, t_IO, particle_IO) +! + use m_fem_mesh_labels + use mesh_data_IO + use time_data_IO + use local_fline_restart_IO +! + integer, intent(in) :: id_rank + character(len=kchara), intent(in) :: file_name + type(time_data), intent(in) :: t_IO + type(surf_edge_IO_file), intent(in) :: particle_IO +! +! + if(id_rank.eq.0 .or. i_debug .gt. 0) write(*,*) & + & 'Write ascii particle file: ', trim(file_name) +! + open(input_file_code, file = file_name, form = 'formatted') +! + write(input_file_code,'(a)', advance='NO') hd_fem_para() + call write_domain_info(input_file_code, id_rank, particle_IO%comm) +! + write(input_file_code,'(a)', advance='NO') hd_fem_node() + call write_geometry_info(input_file_code, particle_IO%node) +! + write(input_file_code,'(a)', advance='NO') hd_particle_connect() + call write_element_info(input_file_code, particle_IO%ele) +! + write(input_file_code,'(a)', advance='NO') hd_particle_velocity() + call write_vector_in_element(input_file_code, particle_IO%node, & + & particle_IO%sfed) +! + write(input_file_code,'(a)', advance='NO') hd_particle_marker() + call write_scalar_in_element(input_file_code, particle_IO%node, & + & particle_IO%sfed) +! + call write_step_data(input_file_code, id_rank, t_IO) +! + close(input_file_code) +! + end subroutine write_particle_file +! +! --------------------------------------------------------------------- +! + end module particle_file_IO diff --git a/src/Fortran_libraries/VIZ_src/fieldline/particle_file_IO_b.f90 b/src/Fortran_libraries/VIZ_src/fieldline/particle_file_IO_b.f90 new file mode 100644 index 00000000..c47de9f1 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/particle_file_IO_b.f90 @@ -0,0 +1,144 @@ +!>@file particle_file_IO_b.f90 +!! module particle_file_IO_b +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2006 +! +!>@brief File IO for element communication table +!! +!!@verbatim +!! subroutine read_particle_file_b(id_rank, file_name, & +!! & t_IO, particle_IO, ierr) +!! integer, intent(in) :: id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(inout) :: t_IO +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!! integer(kind = kint), intent(inout) :: ierr +!! subroutine write_particle_file_b & +!! & (id_rank, file_name, t_IO, particle_IO, ierr) +!! integer, intent(in) :: id_rank +!! character(len=kchara), intent(in) :: file_name +!! type(time_data), intent(in) :: t_IO +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!! integer(kind = kint), intent(inout) :: ierr +!!@endverbatim +!! +!!@param id_rank MPI rank +! + module particle_file_IO_b +! + use m_precision + use m_machine_parameter +! + use m_file_format_switch + use t_read_mesh_data + use t_binary_IO_buffer + use t_time_data + use set_mesh_file_names + use binary_IO +! + implicit none +! + integer(kind = kint), parameter :: id_read_mesh = 21 + type(binary_IO_buffer) :: bbuf_p + private :: id_read_mesh, bbuf_p +! +!------------------------------------------------------------------ +! + contains +! +!------------------------------------------------------------------ +! + subroutine read_particle_file_b(id_rank, file_name, & + & t_IO, particle_IO, ierr) +! + use domain_data_IO_b + use node_geometry_IO_b + use element_connect_IO_b + use field_data_IO_b +! + integer, intent(in) :: id_rank + character(len=kchara), intent(in) :: file_name +! + type(time_data), intent(inout) :: t_IO + type(surf_edge_IO_file), intent(inout) :: particle_IO + integer(kind = kint), intent(inout) :: ierr +! +! + bbuf_p%id_binary = id_read_mesh + call open_read_binary_file(file_name, id_rank, bbuf_p) + if(bbuf_p%ierr_bin .ne. 0) go to 99 +! + call read_domain_info_b(id_rank, bbuf_p, particle_IO%comm) + if(bbuf_p%ierr_bin .ne. 0) go to 99 +! + call read_geometry_info_b(bbuf_p, particle_IO%node) + if(bbuf_p%ierr_bin .ne. 0) go to 99 +! + call read_element_info_b(bbuf_p, particle_IO%ele) + if(bbuf_p%ierr_bin .ne. 0) go to 99 +! + call read_vector_in_element_b(bbuf_p, particle_IO%node, & + & particle_IO%sfed) + if(bbuf_p%ierr_bin .ne. 0) go to 99 + call read_scalar_in_element_b(bbuf_p, particle_IO%node, & + & particle_IO%sfed) + if(bbuf_p%ierr_bin .ne. 0) go to 99 +! + call read_step_data_b(bbuf_p, t_IO) +! + 99 continue + call close_binary_file(bbuf_p) + ierr = bbuf_p%ierr_bin +! + end subroutine read_particle_file_b +! +!------------------------------------------------------------------ +! + subroutine write_particle_file_b & + & (id_rank, file_name, t_IO, particle_IO, ierr) +! + use domain_data_IO_b + use field_data_IO_b + use node_geometry_IO_b + use element_connect_IO_b +! + integer, intent(in) :: id_rank + character(len=kchara), intent(in) :: file_name +! + type(time_data), intent(in) :: t_IO + type(surf_edge_IO_file), intent(in) :: particle_IO + integer(kind = kint), intent(inout) :: ierr +! +! + bbuf_p%id_binary = id_read_mesh + call open_write_binary_file(file_name, bbuf_p) + if(bbuf_p%ierr_bin .ne. 0) go to 99 +! + call write_domain_info_b(id_rank, particle_IO%comm, bbuf_p) + if(bbuf_p%ierr_bin .ne. 0) go to 99 +! + call write_geometry_info_b(particle_IO%node, bbuf_p) + if(bbuf_p%ierr_bin .ne. 0) go to 99 +! + call write_element_info_b(particle_IO%ele, bbuf_p) + if(bbuf_p%ierr_bin .ne. 0) go to 99 +! + call write_vector_in_element_b(particle_IO%node, & + & particle_IO%sfed, bbuf_p) + if(bbuf_p%ierr_bin .ne. 0) go to 99 + call write_scalar_in_element_b(particle_IO%node, & + & particle_IO%sfed, bbuf_p) + if(bbuf_p%ierr_bin .ne. 0) go to 99 +! + call write_step_data_b(id_rank, t_IO, bbuf_p) +! + 99 continue + call close_binary_file(bbuf_p) + ierr = bbuf_p%ierr_bin +! + end subroutine write_particle_file_b +! +!------------------------------------------------------------------ +! + end module particle_file_IO_b diff --git a/src/Fortran_libraries/VIZ_src/fieldline/particle_file_IO_select.F90 b/src/Fortran_libraries/VIZ_src/fieldline/particle_file_IO_select.F90 new file mode 100644 index 00000000..78ff923c --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/particle_file_IO_select.F90 @@ -0,0 +1,201 @@ +!>@file particle_file_IO_select.f90 +!!@brief module particle_file_IO_select +!! +!!@author H.Matsui +!!@date Programmed by H.Matsui in Apr., 2006 +! +!>@brief Choose mesh file to read +!! +!!@verbatim +!! subroutine sel_read_particle_file & +!! & (file_prm, id_rank, t_IO, particle_IO, ierr) +!! integer, intent(in) :: id_rank +!! type(field_IO_params), intent(in) :: file_prm +!! type(time_data), intent(inout) :: t_IO +!! type(surf_edge_IO_file), intent(inout) :: particle_IO +!! integer(kind = kint), intent(inout) :: ierr +!! subroutine sel_write_particle_file & +!! & (file_prm, id_rank, t_IO, particle_IO) +!! integer, intent(in) :: id_rank +!! type(time_data), intent(in) :: t_IO +!! type(surf_edge_IO_file), intent(in) :: particle_IO +!!@endverbatim +! + module particle_file_IO_select +! + use m_precision +! + use t_file_IO_parameter + use t_mesh_data + use m_file_format_switch +! + use mesh_file_name_by_param + use particle_file_IO + use particle_file_IO_b +#ifdef ZLIB_IO + use gz_particle_file_IO + use gz_particle_file_IO_b +#endif +! + implicit none +! + character(len=3), parameter, private :: pcl_ext = "pcl" + character(len=3), parameter, private :: pcb_ext = "pcb" +! + private :: add_pcl_extension, add_pcb_extension +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + character(len=kchara) function add_pcl_extension(file_head) + use set_parallel_file_name +! + character(len=kchara), intent(in) :: file_head +! + add_pcl_extension = add_3chara_extension(file_head, pcl_ext) +! + end function add_pcl_extension +! +!----------------------------------------------------------------------- +! + character(len=kchara) function add_pcb_extension(file_head) + use set_parallel_file_name +! + character(len=kchara), intent(in) :: file_head +! + add_pcb_extension = add_3chara_extension(file_head, pcb_ext) +! + end function add_pcb_extension +! +!----------------------------------------------------------------------- +! + character(len=kchara) function set_tracer_file_name & + & (file_prefix, itype_file, id_rank, istep_fld) +! + use set_parallel_file_name + use set_sph_extensions + use m_file_format_switch +! + integer, intent(in) :: id_rank + integer(kind=kint), intent(in) :: itype_file, istep_fld + character(len=kchara), intent(in) :: file_prefix + character(len=kchara) :: fname_tmp, file_name +! +! + if(istep_fld .eq. iminus) then + fname_tmp = add_elaps_postfix(file_prefix) + else + fname_tmp = add_int_suffix(istep_fld, file_prefix) + end if +! + if((itype_file/iflag_single) .eq. 0) then + file_name = add_process_id(id_rank, fname_tmp) + else + file_name = fname_tmp + end if +! + if (mod(itype_file,iten) .eq. id_gzip_bin_file_fmt) then + fname_tmp = add_pcb_extension(file_name) + file_name = add_gzip_extension(fname_tmp) + else if(mod(itype_file,iten) .eq. id_gzip_txt_file_fmt) then + fname_tmp = add_pcl_extension(file_name) + file_name = add_gzip_extension(fname_tmp) + else if(mod(itype_file,iten) .eq. id_binary_file_fmt) then + fname_tmp = add_pcb_extension(file_name) + file_name = fname_tmp + else + fname_tmp = add_pcl_extension(file_name) + file_name = fname_tmp + end if + set_tracer_file_name = file_name +! + end function set_tracer_file_name +! +! --------------------------------------------------------------------- +! + subroutine sel_read_particle_file(file_prm, id_rank, istep_file, & + & t_IO, particle_IO, ierr) +! + use set_element_mesh_file_names +! + integer, intent(in) :: id_rank + integer(kind = kint), intent(in) :: istep_file + type(field_IO_params), intent(in) :: file_prm +! + type(time_data), intent(inout) :: t_IO + type(surf_edge_IO_file), intent(inout) :: particle_IO + integer(kind = kint), intent(inout) :: ierr +! + character(len=kchara) :: file_name +! + file_name = set_tracer_file_name(file_prm%file_prefix, & + & file_prm%iflag_format, & + & id_rank, istep_file) +! + if (file_prm%iflag_format .eq. id_binary_file_fmt) then + call read_particle_file_b(id_rank, file_name, & + & t_IO, particle_IO, ierr) +! +#ifdef ZLIB_IO + else if(file_prm%iflag_format .eq. id_gzip_bin_file_fmt) then + call gz_read_particle_file_b(id_rank, file_name, & + & t_IO, particle_IO, ierr) + else if(file_prm%iflag_format .eq. id_gzip_txt_file_fmt) then + call gz_read_particle_file(id_rank, file_name, & + & t_IO, particle_IO, ierr) +#endif +! + else + call read_particle_file(id_rank, file_name, & + & t_IO, particle_IO, ierr) + end if +! + end subroutine sel_read_particle_file +! +!------------------------------------------------------------------ +!------------------------------------------------------------------ +! + subroutine sel_write_particle_file & + & (file_prm, id_rank, istep_file, t_IO, particle_IO) +! + use set_element_mesh_file_names +! + integer, intent(in) :: id_rank + integer(kind = kint), intent(in) :: istep_file + type(field_IO_params), intent(in) :: file_prm +! + type(time_data), intent(in) :: t_IO + type(surf_edge_IO_file), intent(in) :: particle_IO + integer(kind = kint) :: ierr = 0 +! + character(len=kchara) :: file_name +! + file_name = set_tracer_file_name(file_prm%file_prefix, & + & file_prm%iflag_format, & + & id_rank, istep_file) +! + if (file_prm%iflag_format .eq. id_binary_file_fmt) then + call write_particle_file_b(id_rank, file_name, & + & t_IO, particle_IO, ierr) +! +#ifdef ZLIB_IO + else if(file_prm%iflag_format .eq. id_gzip_bin_file_fmt) then + call gz_write_particle_file_b(id_rank, file_name, & + & t_IO, particle_IO) + else if(file_prm%iflag_format .eq. id_gzip_txt_file_fmt) then + call gz_write_particle_file(id_rank, file_name, & + & t_IO, particle_IO) +#endif +! + else + call write_particle_file(id_rank, file_name, t_IO, particle_IO) + end if +! + end subroutine sel_write_particle_file +! +! --------------------------------------------------------------------- +! + end module particle_file_IO_select diff --git a/src/Fortran_libraries/VIZ_src/fieldline/set_control_each_fline.f90 b/src/Fortran_libraries/VIZ_src/fieldline/set_control_each_fline.f90 new file mode 100644 index 00000000..20354e7a --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/set_control_each_fline.f90 @@ -0,0 +1,286 @@ +!>@file set_control_each_fline.f90 +!!@brief module set_control_each_fline +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Set seed points from tracers +!! +!!@verbatim +!! subroutine count_control_4_fline(fln, ele_grp, sf_grp, fln_prm) +!! subroutine set_control_4_fline(fln, ele_grp, nod_fld, fln_prm) +!! type(group_data), intent(in) :: ele_grp +!! type(surface_group_data), intent(in) :: sf_grp +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fline_ctl), intent(inout) :: fln +!! type(fieldline_paramter), intent(inout) :: fln_prm +!! integer(kind = kint), intent(inout) :: ierr +!! subroutine set_fline_ctl_4_tracer_seed(num_tracer, tracer_prm, & +!! & fln, fln_prm) +!! integer(kind = kint), intent(in) :: num_tracer +!! type(fieldline_paramter), intent(in) :: tracer_prm(num_tracer) +!! type(fline_ctl), intent(in) :: fln +!! type(fieldline_paramter), intent(inout) :: fln_prm +!!@endverbatim +! + module set_control_each_fline +! + use m_precision +! + use calypso_mpi + use m_constants + use m_error_IDs + use m_machine_parameter + use t_control_params_4_fline + use t_ctl_data_field_line + use t_geometry_data + use t_group_data +! + use set_area_4_viz + use set_field_comp_for_viz + use set_fields_for_fieldline +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine count_control_4_fline(fln, ele_grp, sf_grp, & + & fln_prm, ierr) +! + use m_field_file_format + use m_control_fline_flags +! + use t_source_of_filed_line + use set_control_platform_data + use set_isosurface_file_ctl + use set_area_4_viz + use skip_comment_f + use delete_data_files +! + type(group_data), intent(in) :: ele_grp + type(surface_group_data), intent(in) :: sf_grp +! + type(fline_ctl), intent(in) :: fln +! + type(fieldline_paramter), intent(inout) :: fln_prm + integer(kind = kint), intent(inout) :: ierr +! + character(len=kchara) :: character_256 +! +! + ierr = 0 + if(fln%fline_file_head_ctl%iflag .gt. 0) then + fln_prm%fline_file_IO%file_prefix & + & = fln%fline_file_head_ctl%charavalue + else + fln_prm%fline_file_IO%file_prefix = 'field_line' + end if +! + call calypso_mpi_barrier + if(check_file_writable(my_rank, & + & fln_prm%fline_file_IO%file_prefix) & + & .eqv. .FALSE.) then + ierr = ierr_VIZ + return + end if +! + if(fln%fline_output_type_ctl%iflag .eq. 0) then + fln_prm%fline_file_IO%iflag_format = iflag_sgl_vtk + else + fln_prm%fline_file_IO%iflag_format & + & = sel_iso_file_format(fln%fline_output_type_ctl%charavalue) + end if +! + call set_ctl_parallel_file_w_def(default_tracer_prefix, & + & fln%fline_rst_prefix_ctl, fln%fline_rst_format_ctl, & + & fln_prm%fline_rst_IO) +! +! + call count_area_4_viz(ele_grp%num_grp, ele_grp%grp_name, & + & fln%fline_area_grp_ctl%num, fln%fline_area_grp_ctl%c_tbl, & + & fln_prm%nele_grp_area_fline) +! + if(fln_prm%nele_grp_area_fline .eq. 0) & + & call calypso_MPI_abort(ierr_mesh, 'set correct element group') +! +! + fln_prm%flag_use_broadcast = .TRUE. + character_256 = fln%fline_comm_mode_ctl%charavalue + if (cmp_no_case(character_256, cflag_send_recv)) then + fln_prm%flag_use_broadcast = .FALSE. + end if +! + character_256 = fln%starting_type_ctl%charavalue + if (cmp_no_case(character_256, cflag_surface_group)) then + fln_prm%id_fline_seed_type = iflag_surface_group + else if(cmp_no_case(character_256, cflag_surface_list)) then + fln_prm%id_fline_seed_type = iflag_surface_list + else if(cmp_no_case(character_256, cflag_position_list)) then + fln_prm%id_fline_seed_type = iflag_position_list + else if(cmp_no_case(character_256, cflag_spray_in_domain)) then + fln_prm%id_fline_seed_type = iflag_spray_in_domain + else if(cmp_no_case(character_256, cflag_seed_from_tracer)) then + fln_prm%id_fline_seed_type = iflag_tracer_seeds + end if +! +! + character_256 = fln%line_direction_ctl%charavalue + if (cmp_no_case(character_256, cflag_forward_trace)) then + fln_prm%id_fline_direction = iflag_forward_trace + else if(cmp_no_case(character_256, cflag_backward_trace)) then + fln_prm%id_fline_direction = iflag_backward_trace + else if(cmp_no_case(character_256, cflag_both_trace)) then + fln_prm%id_fline_direction = iflag_both_trace + end if +! +! + if (fln_prm%id_fline_seed_type .eq. iflag_surface_group & + & .or. fln_prm%id_fline_seed_type .eq. iflag_spray_in_domain) & + & then + fln_prm%id_seed_distribution = iflag_random_by_amp + character_256 = fln%selection_type_ctl%charavalue + if (cmp_no_case(character_256, cflag_random_by_amp)) then + fln_prm%id_seed_distribution = iflag_random_by_amp + else if(cmp_no_case(character_256, cflag_random_by_area)) then + fln_prm%id_seed_distribution = iflag_random_by_area + else if(cmp_no_case(character_256, cflag_no_random)) then + fln_prm%id_seed_distribution = iflag_no_random + end if + end if +! + fln_prm%max_line_stepping = -1 + if(fln%max_line_stepping_ctl%iflag .gt. 0) then + fln_prm%max_line_stepping & + & = fln%max_line_stepping_ctl%intvalue + end if +! + fln_prm%max_trace_length = -1.0 + if(fln%max_trace_length_ctl%iflag .gt. 0) then + fln_prm%max_trace_length & + & = fln%max_trace_length_ctl%realvalue + end if +! + if( fln_prm%id_fline_seed_type .eq. iflag_surface_group & + & .or. fln_prm%id_fline_seed_type .eq. iflag_spray_in_domain) & + & then + if(fln%num_fieldline_ctl%iflag .gt. 0) then + fln_prm%num_each_field_line = fln%num_fieldline_ctl%intvalue + else + fln_prm%num_each_field_line = 8 + end if +! + if(fln%seed_surf_grp_ctl%iflag .gt. 0) then + fln_prm%igrp_start_fline_surf_grp & + & = set_surf_grp_id_4_viz(sf_grp%num_grp, sf_grp%grp_name, & + & fln%seed_surf_grp_ctl%charavalue) + end if +! + if(fln%seed_ele_grp_ctl%iflag .gt. 0) then + fln_prm%igrp_start_fline_ele_grp & + & = set_surf_grp_id_4_viz(ele_grp%num_grp, ele_grp%grp_name, & + & fln%seed_ele_grp_ctl%charavalue) + end if + end if +! + end subroutine count_control_4_fline +! +! --------------------------------------------------------------------- +! + subroutine set_control_4_fline(fln, ele_grp, nod_fld, fln_prm) +! + use t_source_of_filed_line + use set_components_flags + use set_area_4_viz + use coordinate_converter +! + type(group_data), intent(in) :: ele_grp + type(phys_data), intent(in) :: nod_fld +! + type(fline_ctl), intent(inout) :: fln +! + type(fieldline_paramter), intent(inout) :: fln_prm +! + integer(kind = kint) :: ncomp(1), ncomp_org(1) + integer(kind = kint) :: ifield_tmp(1), icomp_tmp(1) + character(len=kchara) :: tmpfield(1) + character(len=kchara) :: tmpcomp(1) + character(len=kchara) :: tmpchara(1) +! +! + tmpfield(1) = fln%fline_field_ctl%charavalue + tmpcomp(1) = 'vector' + call set_components_4_viz & + & (nod_fld%num_phys, nod_fld%phys_name, ione, tmpfield, tmpcomp, & + & ione, ifield_tmp, icomp_tmp, ncomp, ncomp_org, tmpchara) +! + if(icomp_tmp(1) .ne. icomp_VECTOR) then + call calypso_MPI_abort(ierr_fld, & + & 'Choose vector field for field line') + end if + fln_prm%iphys_4_fline & + & = nod_fld%istack_component(ifield_tmp(1)-1) + 1 +! +! + tmpfield(1) = fln%seed_ref_field_ctl%charavalue + tmpcomp(1) = fln%seed_ref_comp_ctl%charavalue + call set_components_4_viz & + & (nod_fld%num_phys, nod_fld%phys_name, ione, tmpfield, tmpcomp, & + & ione, ifield_tmp, icomp_tmp, ncomp, ncomp_org, tmpchara) + fln_prm%ifield_4_density = ifield_tmp(1) + fln_prm%icomp_4_density = icomp_tmp(1) +! + call set_ctl_params_viz_fields(fln%fline_field_output_ctl, & + & nod_fld, fln_prm%fline_fields) +! + call s_set_area_4_viz(ele_grp%num_grp, ele_grp%grp_name, & + & fln%fline_area_grp_ctl%num, fln%fline_area_grp_ctl%c_tbl, & + & fln_prm%nele_grp_area_fline, fln_prm%id_ele_grp_area_fline) +! + end subroutine set_control_4_fline +! +! --------------------------------------------------------------------- +! + subroutine set_fline_ctl_4_tracer_seed(num_tracer, tracer_prm, & + & fln, fln_prm) +! + use m_control_fline_flags + use skip_comment_f +! + integer(kind = kint), intent(in) :: num_tracer + type(fieldline_paramter), intent(in) :: tracer_prm(num_tracer) + type(fline_ctl), intent(in) :: fln +! + type(fieldline_paramter), intent(inout) :: fln_prm +! + integer(kind = kint) :: i + character(len=kchara) :: tracer_prefix, character_256 +! +! + fln_prm%id_tracer_for_seed = 0 + if(fln%seed_file_prefix_ctl%iflag .gt. 0) then + tracer_prefix = fln%seed_file_prefix_ctl%charavalue + do i = 1, num_tracer + character_256 = tracer_prm(i)%fline_file_IO%file_prefix + if(cmp_no_case(tracer_prefix, character_256)) then + fln_prm%id_tracer_for_seed = i + exit + end if + end do + end if +! + if(fln_prm%id_fline_seed_type .eq. iflag_tracer_seeds & + & .and. fln_prm%id_tracer_for_seed .le. 0) then + call calypso_MPI_abort(ierr_mesh, & + & 'set correct tracer file prefix for seeds') + end if +! + end subroutine set_fline_ctl_4_tracer_seed +! +! --------------------------------------------------------------------- +! + end module set_control_each_fline diff --git a/src/Fortran_libraries/VIZ_src/fieldline/set_control_fline_seeds.f90 b/src/Fortran_libraries/VIZ_src/fieldline/set_control_fline_seeds.f90 new file mode 100644 index 00000000..b07a8fe4 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/set_control_fline_seeds.f90 @@ -0,0 +1,137 @@ +!>@file set_control_fline_seeds.f90 +!!@brief module set_control_fline_seeds +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Set seed points from tracers +!! +!!@verbatim +!! subroutine count_control_fline_seeds(seeds_ctl, fln_prm) +!! subroutine s_set_control_fline_seeds(seeds_ctl, fln_prm) +!! type(fline_seeds_list_ctl), intent(in) :: seeds_ctl +!! type(fieldline_paramter), intent(inout) :: fln_prm +!!@endverbatim +! + module set_control_fline_seeds +! + use m_precision +! + use calypso_mpi + use m_constants + use m_error_IDs + use m_machine_parameter + use t_control_params_4_fline + use t_fline_seeds_list_ctl +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine count_control_fline_seeds(seeds_ctl, fln_prm) +! + type(fline_seeds_list_ctl), intent(in) :: seeds_ctl +! + type(fieldline_paramter), intent(inout) :: fln_prm +! +! + if(fln_prm%id_fline_seed_type .eq. iflag_surface_list) then + if(seeds_ctl%seed_surface_ctl%num .gt. 0) then + fln_prm%num_each_field_line = seeds_ctl%seed_surface_ctl%num + end if + else if(fln_prm%id_fline_seed_type .eq. iflag_position_list) then + if(seeds_ctl%seed_point_ctl%num .gt. 0) then + fln_prm%num_each_field_line = seeds_ctl%seed_point_ctl%num + end if + if(seeds_ctl%seed_geological_ctl%num .gt. 0) then + fln_prm%num_each_field_line = fln_prm%num_each_field_line & + & + seeds_ctl%seed_geological_ctl%num + end if + if(seeds_ctl%seed_spherical_ctl%num .gt. 0) then + fln_prm%num_each_field_line = fln_prm%num_each_field_line & + & + seeds_ctl%seed_spherical_ctl%num + end if + end if +! + end subroutine count_control_fline_seeds +! +! --------------------------------------------------------------------- +! + subroutine s_set_control_fline_seeds(seeds_ctl, fln_prm) +! + use coordinate_converter +! + type(fline_seeds_list_ctl), intent(in) :: seeds_ctl +! + type(fieldline_paramter), intent(inout) :: fln_prm +! + real(kind = kreal) :: rr(1), theta(1), phi(1) + integer(kind = kint) :: i, icou +! + real(kind = kreal) :: pi +! + pi = four * atan(one) +! +! + if(fln_prm%id_fline_seed_type .eq. iflag_surface_list) then + do i = 1, fln_prm%num_each_field_line + fln_prm%id_gl_surf_start_fline(1,i) & + & = seeds_ctl%seed_surface_ctl%int1(i) + fln_prm%id_gl_surf_start_fline(2,i) & + & = seeds_ctl%seed_surface_ctl%int2(i) + end do + else if(fln_prm%id_fline_seed_type .eq. iflag_position_list) then + do i = 1, seeds_ctl%seed_point_ctl%num + fln_prm%xx_surf_start_fline(1,i) & + & = seeds_ctl%seed_point_ctl%vec1(i) + fln_prm%xx_surf_start_fline(2,i) & + & = seeds_ctl%seed_point_ctl%vec2(i) + fln_prm%xx_surf_start_fline(3,i) & + & = seeds_ctl%seed_point_ctl%vec3(i) + end do + do i = 1, seeds_ctl%seed_geological_ctl%num + icou = i + seeds_ctl%seed_point_ctl%num + rr(1) = seeds_ctl%seed_geological_ctl%vec1(i) + theta(1) = (90.0d0 - seeds_ctl%seed_geological_ctl%vec2(i)) & + & * pi / 180.0d0 + phi(1) = seeds_ctl%seed_geological_ctl%vec3(i) * pi / 180.0d0 + call position_2_xyz(IONE, rr(1), theta(1), phi(1), & + & fln_prm%xx_surf_start_fline(1,icou), & + & fln_prm%xx_surf_start_fline(2,icou), & + & fln_prm%xx_surf_start_fline(3,icou)) + end do + do i = 1, seeds_ctl%seed_spherical_ctl%num + icou = i + seeds_ctl%seed_point_ctl%num & + & + seeds_ctl%seed_geological_ctl%num + rr(1) = seeds_ctl%seed_spherical_ctl%vec1(i) + theta(1) = seeds_ctl%seed_spherical_ctl%vec2(i) + phi(1) = seeds_ctl%seed_spherical_ctl%vec3(i) +! write(*,*) my_rank, i, 'seed_spherical_ctl', & +! & seeds_ctl%seed_spherical_ctl%vec1(i), & +! & seeds_ctl%seed_spherical_ctl%vec2(i), & +! & seeds_ctl%seed_spherical_ctl%vec3(i) +! write(*,*) my_rank, i, 'seed_spherical_ctl', & +! & rr(1), theta(1), phi(1) + call position_2_xyz(IONE, rr(1), theta(1), phi(1), & + & fln_prm%xx_surf_start_fline(1,icou), & + & fln_prm%xx_surf_start_fline(2,icou), & + & fln_prm%xx_surf_start_fline(3,icou)) +! write(*,*) my_rank, i, icou, 'xx_surf_start_fline', & +! & fln_prm%xx_surf_start_fline(:,icou) + end do +! +! do i = 1, fln_prm%num_each_field_line +! write(*,*) i, 'fln_prm%xx_surf_start_fline', & +! & fln_prm%xx_surf_start_fline(:,i) +! end do + end if +! + end subroutine s_set_control_fline_seeds +! +! --------------------------------------------------------------------- +! + end module set_control_fline_seeds diff --git a/src/Fortran_libraries/VIZ_src/fieldline/set_fields_after_tracing.f90 b/src/Fortran_libraries/VIZ_src/fieldline/set_fields_after_tracing.f90 new file mode 100644 index 00000000..569f437c --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/set_fields_after_tracing.f90 @@ -0,0 +1,200 @@ +!>@file set_fields_after_tracing.f90 +!! module set_fields_after_tracing +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief extend field line in each domain +!! +!!@verbatim +!! subroutine fline_vector_at_one_element(iele, node, ele, v_trace,& +!! & v4_ele) +!! integer(kind = kint), intent(in) :: iele +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! real(kind = kreal), intent(in) :: v_trace(node%numnod,3) +!! real(kind = kreal), intent(inout) :: v4_ele(4,ele%nnod_4_ele) +!! subroutine fline_colors_at_one_element(iele, ele, nod_fld, & +!! & viz_fields, c_ele) +!! integer(kind = kint), intent(in) :: iele +!! type(element_data), intent(in) :: ele +!! type(phys_data), intent(in) :: nod_fld +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! real(kind = kreal), intent(inout) & +!! & :: c_ele(viz_fields%ntot_org_comp, ele%nnod_4_ele) +!! +!! subroutine fields_on_surf_from_one_ele & +!! & (isf_tgt, xi_surf, ele, surf, viz_fields, & +!! & v4_ele, c_ele, x4_tgt, v4_tgt, c_tgt) +!! integer(kind = kint), intent(in) :: isf_tgt +!! real(kind = kreal), intent(in) :: xi_surf(2) +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! real(kind = kreal), intent(in) :: v4_ele(4,ele%nnod_4_ele) +!! real(kind = kreal), intent(in) & +!! & :: c_ele(viz_fields%ntot_org_comp, ele%nnod_4_ele) +!! real(kind = kreal), intent(in) :: x4_tgt(4) +!! real(kind = kreal), intent(inout) :: v4_tgt(4) +!! real(kind = kreal), intent(inout) & +!! & :: c_tgt(viz_fields%ntot_color_comp) +!!@endverbatim +! + module set_fields_after_tracing +! + use m_precision +! + use m_constants + use m_geometry_constants + use calypso_mpi +! + use t_geometry_data + use t_surface_data + use t_phys_data + use t_ctl_params_viz_fields +! + implicit none +! + private :: field_on_surf_of_one_ele +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine fline_vector_at_one_element(iele, node, ele, v_trace, & + & v4_ele) +! + integer(kind = kint), intent(in) :: iele + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + real(kind = kreal), intent(in) :: v_trace(node%numnod,3) +! + real(kind = kreal), intent(inout) :: v4_ele(4,ele%nnod_4_ele) +! + integer(kind = kint) :: k1, inod +! + do k1 = 1, ele%nnod_4_ele + inod = ele%ie(iele,k1) + v4_ele(1:3,k1) = v_trace(inod,1:3) + v4_ele(4,k1) = one + end do +! + end subroutine fline_vector_at_one_element +! +! --------------------------------------------------------------------- +! + subroutine fline_colors_at_one_element(iele, ele, nod_fld, & + & viz_fields, c_ele) +! + use tracer_field_interpolate +! + integer(kind = kint), intent(in) :: iele + type(element_data), intent(in) :: ele + type(phys_data), intent(in) :: nod_fld +! + type(ctl_params_viz_fields), intent(in) :: viz_fields +! + real(kind = kreal), intent(inout) & + & :: c_ele(viz_fields%ntot_org_comp, ele%nnod_4_ele) +! + integer(kind = kint) :: k1, inod +! + do k1 = 1, ele%nnod_4_ele + inod = ele%ie(iele,k1) + call cal_xyz_fields_at_node(inod, nod_fld, viz_fields, & + & c_ele(1,k1)) + end do +! + end subroutine fline_colors_at_one_element +! +! --------------------------------------------------------------------- +! + subroutine fields_on_surf_from_one_ele & + & (isf_tgt, xi_surf, ele, surf, viz_fields, & + & v4_ele, c_ele, x4_tgt, v4_tgt, c_tgt) +! + use coordinate_converter + use convert_components_4_viz + use cal_field_on_surf_viz +! + integer(kind = kint), intent(in) :: isf_tgt + real(kind = kreal), intent(in) :: xi_surf(2) + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(ctl_params_viz_fields), intent(in) :: viz_fields +! + real(kind = kreal), intent(in) :: v4_ele(4,ele%nnod_4_ele) + real(kind = kreal), intent(in) & + & :: c_ele(viz_fields%ntot_org_comp, ele%nnod_4_ele) +! + real(kind = kreal), intent(in) :: x4_tgt(4) + real(kind = kreal), intent(inout) :: v4_tgt(4) + real(kind = kreal), intent(inout) & + & :: c_tgt(viz_fields%ntot_color_comp) +! + real(kind = kreal) :: c_xyz(viz_fields%ntot_org_comp) + real(kind = kreal) :: v_work(4*surf%nnod_4_surf) + real(kind = kreal) & + & :: c_work(viz_fields%ntot_org_comp*surf%nnod_4_surf) + real(kind = kreal) :: r(1), theta(1), phi(1) + real(kind = kreal) :: a_r(1), rs(1), a_rs(1) + integer(kind = kint) :: istack_single(0:1) = (/0, 1/) + integer(kind = kint) :: inum, ist, jst +! +! + call field_on_surf_of_one_ele(isf_tgt, ele, surf, xi_surf, & + & ifour, v4_ele(1,1), v4_tgt(1), v_work(1)) + call field_on_surf_of_one_ele(isf_tgt, ele, surf, xi_surf, & + & viz_fields%ntot_org_comp, c_ele(1,1), c_xyz(1), c_work(1)) +! + call position_2_sph(ione, x4_tgt(1), r, theta, phi, & + & a_r, rs, a_rs) + do inum = 1, viz_fields%num_color_fields + ist = viz_fields%istack_org_ncomp(inum-1) + jst = viz_fields%istack_color_field(inum-1) + call convert_comps_4_viz & + & (ione, istack_single, x4_tgt(1), r, a_r, rs, a_rs, & + & viz_fields%ncomp_color_field(inum), & + & viz_fields%ncomp_org_color_field(inum), & + & viz_fields%icomp_color_field(inum), & + & c_xyz(ist+1), c_tgt(jst+1)) + end do +! + end subroutine fields_on_surf_from_one_ele +! +! --------------------------------------------------------------------- +! + subroutine field_on_surf_of_one_ele(isf_in_ele, ele, surf, xi, & + & ncomp, v_ele, v_tgt, v_work) +! + use cal_field_on_surf_viz +! + integer(kind = kint), intent(in) :: isf_in_ele + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + real(kind = kreal), intent(in) :: xi(2) + integer(kind = kint), intent(in) :: ncomp + real(kind = kreal), intent(in) :: v_ele(ncomp,ele%nnod_4_ele) +! + real(kind = kreal), intent(inout) :: v_tgt(ncomp) + real(kind = kreal), intent(inout) & + & :: v_work(ncomp,surf%nnod_4_surf) +! + integer(kind = kint) :: k1, inod_lc +! +! + do k1 = 1, 4 + inod_lc = surf%node_on_sf(k1,isf_in_ele) + v_work(1:ncomp,k1) = v_ele(1:ncomp,inod_lc) + end do +! + call cal_surf_field_value_2d(ncomp, xi, v_work, v_tgt) +! + end subroutine field_on_surf_of_one_ele +! +! --------------------------------------------------------------------- +! + end module set_fields_after_tracing + diff --git a/src/Fortran_libraries/VIZ_src/fieldline/set_fields_for_fieldline.f90 b/src/Fortran_libraries/VIZ_src/fieldline/set_fields_for_fieldline.f90 new file mode 100644 index 00000000..adbe1e9d --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/set_fields_for_fieldline.f90 @@ -0,0 +1,95 @@ +!>@file set_fields_for_fieldline.f90 +!!@brief module set_fields_for_fieldline +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Main routine for field line module +!! +!!@verbatim +!! subroutine s_set_fields_for_fieldline(mesh, group, para_surf, & +!! & nod_fld, fln_prm, fln_src, fln_tce) +!! type(mesh_geometry), intent(in) :: mesh +!! type(mesh_groups), intent(in) :: group +!! type(paralell_surface_indices), intent(in) :: para_surf +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_paramter), intent(inout) :: fln_prm +!! type(surface_group_data), intent(in) :: sf_grp +!! type(each_fieldline_source), intent(inout) :: fln_src +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!!@endverbatim +! + module set_fields_for_fieldline +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter + use m_geometry_constants +! + use t_phys_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_parallel_surface_indices + use t_control_params_4_fline + use t_source_of_filed_line + use t_tracing_data +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_set_fields_for_fieldline(mesh, group, para_surf, & + & nod_fld, fln_prm, fln_src, fln_tce) +! + use t_mesh_data + use t_phys_data + use start_surface_by_gl_table + use start_surface_by_flux + use start_surface_by_volume + use start_surface_4_fline +! + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(phys_data), intent(in) :: nod_fld + type(paralell_surface_indices), intent(in) :: para_surf +! + type(fieldline_paramter), intent(inout) :: fln_prm + type(each_fieldline_source), intent(inout) :: fln_src + type(each_fieldline_trace), intent(inout) :: fln_tce +! +! + if(fln_prm%id_fline_seed_type .eq. iflag_surface_group) then + if(iflag_debug .gt. 0) write(*,*) 's_start_surface_by_flux' + call s_start_surface_by_flux & + & (mesh%ele, mesh%surf, group%surf_grp, nod_fld, & + & fln_prm, fln_src, fln_tce) + else if(fln_prm%id_fline_seed_type & + & .eq. iflag_spray_in_domain) then + if(iflag_debug .gt. 0) write(*,*) 's_start_surface_by_volume' + call s_start_surface_by_volume & + & (mesh%node, mesh%ele, group%ele_grp, nod_fld, & + & fln_prm, fln_src, fln_tce) + else if(fln_prm%id_fline_seed_type .eq. iflag_surface_list) then + if(iflag_debug .gt. 0) write(*,*) 's_start_surface_by_gl_table' + call s_start_surface_by_gl_table & + & (mesh%ele, group%ele_grp, fln_prm, fln_src) + end if +! + if(iflag_debug .gt. 0) write(*,*) 's_start_surface_4_fline' + call s_start_surface_4_fline & + & (mesh%node, mesh%ele, mesh%surf, nod_fld, & + & para_surf%isf_4_ele_dbl, fln_prm, fln_src, fln_tce) + if(iflag_debug .gt. 0) write(*,*) 's_start_surface_4_fline end' +! + end subroutine s_set_fields_for_fieldline +! +! --------------------------------------------------------------------- +! + end module set_fields_for_fieldline diff --git a/src/Fortran_libraries/VIZ_src/fieldline/set_fline_control.f90 b/src/Fortran_libraries/VIZ_src/fieldline/set_fline_control.f90 new file mode 100644 index 00000000..3b652c39 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/set_fline_control.f90 @@ -0,0 +1,157 @@ +!>@file set_fline_control.f90 +!!@brief module set_fline_control +!! +!!@date Programmed by H.Matsui in May, 2006 +! +!>@brief control data for field lines +!! +!!@verbatim +!! subroutine s_set_fline_control & +!! & (mesh, group, nod_fld, num_tracer, tracer_prm, & +!! & fline_ctl_struct, fln_prm) +!! type(mesh_geometry), intent(in) :: mesh +!! type(mesh_groups), intent(in) :: group +!! type(phys_data), intent(in) :: nod_fld +!! integer(kind = kint), intent(in) :: num_tracer +!! type(fieldline_paramter), intent(in) :: tracer_prm(num_tracer) +!! type(fieldline_controls), intent(inout) :: fline_ctls +!! type(fline_ctl), intent(inout) :: fline_ctl_struct +!! type(fieldline_paramter), intent(inout) :: fln_prm +!! subroutine s_set_tracer_control(mesh, group, nod_fld, & +!! & fline_ctl_struct, fln_prm) +!! type(mesh_geometry), intent(in) :: mesh +!! type(mesh_groups), intent(in) :: group +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fline_ctl), intent(inout) :: fline_ctl_struct +!! type(fieldline_paramter), intent(inout) :: fln_prm +!!@endverbatim +! + module set_fline_control +! + use m_precision +! + use m_machine_parameter +! + use t_mesh_data + use t_geometry_data + use t_group_data + use t_phys_data + use t_control_params_4_fline +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_set_fline_control & + & (mesh, group, nod_fld, num_tracer, tracer_prm, & + & fline_ctl_struct, fln_prm) +! + use t_control_data_flines + use set_control_each_fline + use set_iflag_for_used_ele + use set_control_fline_seeds +! + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(phys_data), intent(in) :: nod_fld + integer(kind = kint), intent(in) :: num_tracer + type(fieldline_paramter), intent(in) :: tracer_prm(num_tracer) +! + type(fline_ctl), intent(inout) :: fline_ctl_struct + type(fieldline_paramter), intent(inout) :: fln_prm +! + integer(kind = kint) :: i, ierr +! +! + call count_control_4_fline(fline_ctl_struct, & + & group%ele_grp, group%surf_grp, fln_prm, ierr) + call count_control_fline_seeds(fline_ctl_struct%seeds_ctl, & + & fln_prm) + if(ierr .gt. 0) then + call calypso_mpi_abort(ierr, & + & 'Check Directory for Fieldline output') + end if +! + call alloc_iflag_fline_used_ele(mesh%ele, fln_prm) + call alloc_fline_starts_ctl(fln_prm) +! + call set_control_4_fline(fline_ctl_struct, & + & group%ele_grp, nod_fld, fln_prm) + call s_set_control_fline_seeds(fline_ctl_struct%seeds_ctl, & + & fln_prm) + call set_fline_ctl_4_tracer_seed(num_tracer, tracer_prm, & + & fline_ctl_struct, fln_prm) +! call s_set_iflag_for_used_ele(mesh%ele, group%ele_grp, & +! & fln_prm%nele_grp_area_fline, fln_prm%id_ele_grp_area_fline, & +! & fln_prm%iflag_fline_used_ele) + call set_iflag_used_ele_w_overlap(mesh%ele, group%ele_grp, & + & fln_prm%nele_grp_area_fline, fln_prm%id_ele_grp_area_fline, & + & fln_prm%iflag_fline_used_ele) + call deallocate_cont_dat_fline(fline_ctl_struct) +! + if(iflag_debug .gt. 0) then + write(*,*) 'field line parameters for No.', i + call check_control_params_fline(fln_prm) + end if +! + end subroutine s_set_fline_control +! +! -------------------------------------------------------------------- +! + subroutine s_set_tracer_control(mesh, group, nod_fld, & + & fline_ctl_struct, fln_prm) +! + use t_control_data_flines + use set_control_each_fline + use set_iflag_for_used_ele + use set_control_fline_seeds +! + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(phys_data), intent(in) :: nod_fld +! + type(fline_ctl), intent(inout) :: fline_ctl_struct + type(fieldline_paramter), intent(inout) :: fln_prm +! + integer(kind = kint) :: i, ierr +! +! + call count_control_4_fline(fline_ctl_struct, & + & group%ele_grp, group%surf_grp, fln_prm, ierr) + call count_control_fline_seeds(fline_ctl_struct%seeds_ctl, & + & fln_prm) + if(ierr .gt. 0) then + call calypso_mpi_abort(ierr, & + & 'Check Directory for tracer output') + end if +! + call alloc_iflag_fline_used_ele(mesh%ele, fln_prm) + call alloc_fline_starts_ctl(fln_prm) +! + call set_control_4_fline(fline_ctl_struct, & + & group%ele_grp, nod_fld, fln_prm) + call s_set_control_fline_seeds(fline_ctl_struct%seeds_ctl, & + & fln_prm) +! call s_set_iflag_for_used_ele(mesh%ele, group%ele_grp, & +! & fln_prm%nele_grp_area_fline, fln_prm%id_ele_grp_area_fline, & +! & fln_prm%iflag_fline_used_ele) + call set_iflag_used_ele_w_overlap(mesh%ele, group%ele_grp, & + & fln_prm%nele_grp_area_fline, fln_prm%id_ele_grp_area_fline, & + & fln_prm%iflag_fline_used_ele) + call deallocate_cont_dat_fline(fline_ctl_struct) +! + if(iflag_debug .gt. 0) then + write(*,*) 'field line parameters for No.', i + call check_control_params_fline(fln_prm) + end if +! + end subroutine s_set_tracer_control +! +! -------------------------------------------------------------------- +! + end module set_fline_control diff --git a/src/Fortran_libraries/VIZ_src/fieldline/set_fline_seed_from_tracer.f90 b/src/Fortran_libraries/VIZ_src/fieldline/set_fline_seed_from_tracer.f90 new file mode 100644 index 00000000..03ffb156 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/set_fline_seed_from_tracer.f90 @@ -0,0 +1,139 @@ +!>@file set_fline_seed_from_tracer.f90 +!!@brief module set_fline_seed_from_tracer +!! +!!@date Programmed by H.Matsui in Aug. 2011 +! +!>@brief control parameters for each field line +!! +!!@verbatim +!! subroutine const_fline_seed_from_tracer(node, ele, nod_fld, & +!! & num_tracer, tracer_tce, fln_prm, fln_tce) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_paramter), intent(in) :: fln_prm +!! integer(kind = kint), intent(in) :: num_tracer +!! type(each_fieldline_trace), intent(in) & +!! & :: tracer_tce(num_tracer) +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!!@endverbatim +! + module set_fline_seed_from_tracer +! + use m_precision + use m_geometry_constants + use t_geometry_data + use t_phys_data + use t_file_IO_parameter + use t_control_params_4_fline + use t_tracing_data + use t_ctl_params_viz_fields +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine const_fline_seed_from_tracer(node, ele, nod_fld, & + & num_tracer, tracer_tce, fln_prm, fln_tce) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(phys_data), intent(in) :: nod_fld + type(fieldline_paramter), intent(in) :: fln_prm + integer(kind = kint), intent(in) :: num_tracer + type(each_fieldline_trace), intent(in) & + & :: tracer_tce(num_tracer) +! + type(each_fieldline_trace), intent(inout) :: fln_tce +! +! + fln_tce%num_current_fline = count_fline_seed_from_tracer & + & (tracer_tce(fln_prm%id_tracer_for_seed), fln_prm) + call resize_line_start_fline(fln_tce%num_current_fline, & + & fln_prm%fline_fields, fln_tce) + call s_set_fline_seed_from_tracer(node, ele, nod_fld, & + & tracer_tce(fln_prm%id_tracer_for_seed), fln_prm, fln_tce) +! + end subroutine const_fline_seed_from_tracer +! +! --------------------------------------------------------------------- +! + integer(kind = kint) function count_fline_seed_from_tracer & + & (org_fln_tce, fln_prm) +! + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_trace), intent(in) :: org_fln_tce +! + integer(kind = kint) :: num +! +! + num = org_fln_tce%num_current_fline + if(fln_prm%id_fline_direction .eq. iflag_both_trace) then + num = 2 * num + end if + count_fline_seed_from_tracer = num +! + end function count_fline_seed_from_tracer +! +! --------------------------------------------------------------------- +! + subroutine s_set_fline_seed_from_tracer(node, ele, nod_fld, & + & org_fln_tce, fln_prm, fln_tce) +! + use set_fline_seeds_from_list +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(phys_data), intent(in) :: nod_fld + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_trace), intent(in) :: org_fln_tce +! + type(each_fieldline_trace), intent(inout) :: fln_tce +! + integer(kind= kint) :: inum, icou +! +! + icou = 0 + do inum = 1, fln_tce%num_current_fline + icou = icou + 1 + fln_tce%iflag_direction(icou) = fln_prm%id_fline_direction + fln_tce%iline_original(icou) & + & = org_fln_tce%iline_original(inum) + fln_tce%isf_dbl_start(1:3,icou) & + & = org_fln_tce%isf_dbl_start(1:3,inum) + fln_tce%xx_fline_start(1:4,icou) & + & = org_fln_tce%xx_fline_start(1:4,icou) + call set_field_at_each_seed_point(node, ele, nod_fld, & + & fln_prm%fline_fields, fln_prm%iphys_4_fline, & + & fln_tce%isf_dbl_start(2,inum), & + & fln_tce%xx_fline_start(1,inum), & + & fln_tce%v_fline_start(1,inum), & + & fln_tce%c_fline_start(1,inum)) +! + fln_tce%trace_length(icou) = 0.0d0 + fln_tce%icount_fline(icou) = 0 +! + if(fln_prm%id_fline_direction .eq. iflag_both_trace) then + fln_tce%iflag_direction(icou) = fln_prm%id_fline_direction +! + icou = icou + 1 + fln_tce%iline_original(icou) = fln_tce%iline_original(icou-1) + fln_tce%isf_dbl_start(1:3,icou) & + & = org_fln_tce%isf_dbl_start(1:3,icou-1) + call copy_global_start_fline(icou, (icou-1), & + & fln_prm%fline_fields, fln_tce) +! + fln_tce%trace_length(icou) = 0.0d0 + fln_tce%icount_fline(icou) = 0 + end if + end do +! + end subroutine s_set_fline_seed_from_tracer +! +! --------------------------------------------------------------------- +! + end module set_fline_seed_from_tracer diff --git a/src/Fortran_libraries/VIZ_src/fieldline/set_fline_seeds_from_list.f90 b/src/Fortran_libraries/VIZ_src/fieldline/set_fline_seeds_from_list.f90 new file mode 100644 index 00000000..11cb017a --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/set_fline_seeds_from_list.f90 @@ -0,0 +1,469 @@ +!>@file set_fline_seeds_from_list.f90 +!!@brief module set_fline_seeds_from_list +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Main routine for field line module +!! +!!@verbatim +!! subroutine alloc_FLINE_element_size(ele, fln_dist) +!! subroutine dealloc_FLINE_element_size(fln_dist) +!! type(element_data), intent(in) :: ele +!! type(FLINE_element_size), intent(inout) :: fln_dist +!! type(FLINE_element_size), intent(inout) :: fln_dist +!! +!! subroutine cal_FLINE_element_size(node, ele, fln_dist) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(FLINE_element_size), intent(inout) :: fln_dist +!! subroutine init_FLINE_seed_from_list(node, ele, & +!! & fln_prm, fln_src, fln_dist) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(fieldline_paramter), intent(inout) :: fln_prm +!! type(each_fieldline_source), intent(inout) :: fln_src +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!! type(FLINE_element_size), intent(inout) :: fln_dist +!! subroutine set_FLINE_seed_field_from_list & +!! & (node, ele, nod_fld, fln_prm, fln_src, fln_tce) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_paramter), intent(in) :: fln_prm +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!! +!! subroutine count_FLINE_seed_from_list(fln_prm, fln_src, fln_tce) +!! type(fieldline_paramter), intent(in) :: fln_prm +!! type(each_fieldline_source), intent(in) :: fln_src +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!! +!! subroutine set_field_at_each_seed_point(node, ele, nod_fld, & +!! & fline_fields, iphys_4_fline, iele_seed, x4_seed, & +!! & v_fline_start, c_fline_start) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(phys_data), intent(in) :: nod_fld +!! type(ctl_params_viz_fields), intent(in) :: fline_fields +!! integer(kind = kint), intent(in) :: iphys_4_fline +!! integer(kind = kint), intent(in) :: iele_seed(1) +!! real(kind = kreal), intent(in) :: x4_seed(4) +!! real(kind = kreal), intent(inout) :: v_fline_start(4) +!! real(kind = kreal), intent(inout) & +!! & :: c_fline_start(fline_fields%ntot_color_comp) +!!@endverbatim +! + module set_fline_seeds_from_list +! + use m_precision + use calypso_mpi +! + use m_machine_parameter + use m_geometry_constants + use t_geometry_data + use t_phys_data + use t_control_params_4_fline + use t_source_of_filed_line + use t_tracing_data +! + implicit none +! + integer(kind = kint), parameter, private :: maxitr = 20 + real(kind = kreal), parameter, private :: eps_iter = 1.0d-9 + integer(kind = kint), parameter, private :: iflag_nomessage = 0 + real(kind = kreal), parameter, private :: error_level = 1.0d-9 +! + type FLINE_element_size + real(kind = kreal), allocatable :: ele_size(:) + real(kind = kreal), allocatable :: distance(:) + integer(kind = kint), allocatable :: index(:) + end type FLINE_element_size +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_FLINE_element_size(ele, fln_dist) + type(element_data), intent(in) :: ele + type(FLINE_element_size), intent(inout) :: fln_dist +! + allocate(fln_dist%ele_size(ele%numele)) + allocate(fln_dist%distance(ele%numele)) + allocate(fln_dist%index(ele%numele)) +! + if(ele%numele .le. 0) return +!$omp parallel workshare + fln_dist%ele_size(1:ele%numele) = 0.0d0 + fln_dist%distance(1:ele%numele) = 0.0d0 + fln_dist%index(1:ele%numele) = 0 +!$omp end parallel workshare +! + end subroutine alloc_FLINE_element_size +! +! --------------------------------------------------------------------- +! + subroutine dealloc_FLINE_element_size(fln_dist) + type(FLINE_element_size), intent(inout) :: fln_dist +! + if(allocated(fln_dist%ele_size) .eqv. .FALSE.) return + deallocate(fln_dist%ele_size) + deallocate(fln_dist%distance, fln_dist%index) +! + end subroutine dealloc_FLINE_element_size +! +! --------------------------------------------------------------------- +! + subroutine cal_FLINE_element_size(node, ele, fln_dist) +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(FLINE_element_size), intent(inout) :: fln_dist +! + real(kind = kreal) :: x(ele%nnod_4_ele) + real(kind = kreal) :: y(ele%nnod_4_ele) + real(kind = kreal) :: z(ele%nnod_4_ele) + real(kind = kreal) :: size_max(3) + integer(kind = kint) :: inod, iele, k1 +! +!$omp parallel do private(iele,k1,inod,x,y,z) + do iele = 1, ele%numele + do k1 = 1, ele%nnod_4_ele + inod = ele%ie(iele,k1) + x(k1) = node%xx(inod,1) + y(k1) = node%xx(inod,2) + z(k1) = node%xx(inod,3) + end do + size_max(1) = maxval(x) - minval(x) + size_max(2) = maxval(y) - minval(y) + size_max(3) = maxval(z) - minval(z) + fln_dist%ele_size(iele) = sqrt(size_max(1)*size_max(1) & + & + size_max(2)*size_max(2) & + & + size_max(3)*size_max(3)) + end do +!$omp end parallel do +! + end subroutine cal_FLINE_element_size +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine init_FLINE_seed_from_list(node, ele, & + & fln_prm, fln_src, fln_dist) +! + use calypso_mpi_int + use t_control_data_flines + use t_find_interpolate_in_ele + use set_fline_control + use quicksort +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(fieldline_paramter), intent(inout) :: fln_prm + type(each_fieldline_source), intent(inout) :: fln_src + type(FLINE_element_size), intent(inout) :: fln_dist +! + type(cal_interpolate_coefs_work), save :: itp_ele_work_f + integer(kind = kint) :: ierr_inter +! + real(kind = kreal) :: x, y, z + real(kind = kreal) :: dist_tmp + real(kind = kreal) :: xi(3) + integer(kind = kint) :: i, iele, inum + integer(kind = kint) :: num_search +! integer(kind = kint) :: ip, i_fln + +! + call alloc_work_4_interpolate(ele%nnod_4_ele, itp_ele_work_f) +! + do i = 1, fln_prm%num_each_field_line + x = fln_prm%xx_surf_start_fline(1,i) + y = fln_prm%xx_surf_start_fline(2,i) + z = fln_prm%xx_surf_start_fline(3,i) + num_search = 0 + do iele = 1, ele%numele + dist_tmp = sqrt ((x - ele%x_ele(iele,1))**2 & + & + (y - ele%x_ele(iele,2))**2 & + & + (z - ele%x_ele(iele,3))**2) + if(dist_tmp .le. fln_dist%ele_size(iele)) then + num_search = num_search + 1 + fln_dist%index(num_search) = iele + fln_dist%distance(num_search) = dist_tmp + end if + end do + + if(num_search .gt. 1) then + call quicksort_real_w_index(ele%numele, & + & fln_dist%distance(1), ione, num_search, fln_dist%index(1)) + end if +! + fln_src%ip_surf_start_fline(i) = -1 + fln_src%iele_surf_start_fline(i) = 0 + fln_src%xi_surf_start_fline(1:3,i) = -2.0 + do inum = 1, num_search + iele = fln_dist%index(inum) + if(ele%interior_ele(iele) .le. 0) cycle + ierr_inter = 0 + xi(1:3) = -2.0 + call find_interpolate_in_ele & + & (fln_prm%xx_surf_start_fline(1,i), maxitr, eps_iter, & + & my_rank, iflag_nomessage, error_level, & + & node, ele, iele, itp_ele_work_f, xi, ierr_inter) + if(ierr_inter.gt.1 .and. ierr_inter.le.maxitr) then + fln_src%ip_surf_start_fline(i) = my_rank + fln_src%iele_surf_start_fline(i) = iele + fln_src%xi_surf_start_fline(1:3,i) = xi(1:3) + exit + end if + end do + end do + call dealloc_work_4_interpolate(itp_ele_work_f) + +! do ip = 1, nprocs +! call calypso_mpi_barrier +! if(my_rank .ne. ip-1) cycle +! do i = 1, fln_prm%num_each_field_line +! if(fln_src%ip_surf_start_fline(i) .ge. 0) then +! write(*,*) my_rank, i_fln, i, 'fln_prm', & +! & fln_src%ip_surf_start_fline(i), & +! & fln_src%iele_surf_start_fline(i), & +! & fln_src%xi_surf_start_fline(1:3,i), & +! & ele%numele, ierr_inter +! end if +! end do +! end do +! +! call calypso_mpi_barrier + fln_src%num_line_local = 0 + do i = 1, fln_prm%num_each_field_line + if(fln_src%ip_surf_start_fline(i) .eq. my_rank) & + fln_src%num_line_local = fln_src%num_line_local + 1 + end do +! call calypso_mpi_barrier +! write(*,*) my_rank, 'fln_src%num_line_local', & +! & fln_src%num_line_local +! + end subroutine init_FLINE_seed_from_list +! +! --------------------------------------------------------------------- +! + subroutine count_FLINE_seed_from_list(fln_prm, fln_src, fln_tce) +! + use calypso_mpi_int +! + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_source), intent(in) :: fln_src + type(each_fieldline_trace), intent(inout) :: fln_tce +! + integer(kind = kint) :: i +! +! + fln_tce%num_current_fline = fln_src%num_line_local + if(fln_prm%id_fline_direction .eq. iflag_both_trace) then + fln_tce%num_current_fline = 2 * fln_tce%num_current_fline + end if + call resize_line_start_fline(fln_tce%num_current_fline, & + & fln_prm%fline_fields, fln_tce) +! + fln_tce%istack_current_fline(0) = 0 + call calypso_mpi_allgather_one_int(fln_tce%num_current_fline, & + & fln_tce%istack_current_fline(1)) + do i = 1, nprocs + fln_tce%istack_current_fline(i) & + & = fln_tce%istack_current_fline(i-1) & + & + fln_tce%istack_current_fline(i) + end do +! + end subroutine count_FLINE_seed_from_list +! +! --------------------------------------------------------------------- +! + subroutine set_FLINE_seed_field_from_list & + & (node, ele, nod_fld, fln_prm, fln_src, fln_tce) +! + use sel_interpolate_scalar + use extend_field_line + use trace_in_element + use tracer_field_interpolate +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(phys_data), intent(in) :: nod_fld +! + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_source), intent(in) :: fln_src + type(each_fieldline_trace), intent(inout) :: fln_tce +! + integer(kind = kint) :: icou, inum +! + icou = 0 + do inum = 1, fln_prm%num_each_field_line + if(fln_src%ip_surf_start_fline(inum) .ne. my_rank) cycle + icou = icou + 1 +! + call cal_each_seed_field_in_ele(node, ele, nod_fld, & + & fln_prm%fline_fields, fln_prm%iphys_4_fline, & + & fln_src%iele_surf_start_fline(inum), & + & fln_src%xi_surf_start_fline(1,inum), & + & fln_prm%xx_surf_start_fline(1,inum), & + & fln_tce%v_fline_start(1,icou), & + & fln_tce%c_fline_start(1,icou)) +! +! + fln_tce%isf_dbl_start(1,icou) = my_rank + fln_tce%isf_dbl_start(2,icou) & + & = fln_src%iele_surf_start_fline(inum) + + fln_tce%isf_dbl_start(3,icou) = 0 + if(abs(fln_src%xi_surf_start_fline(1,inum)+one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 1 + if(abs(fln_src%xi_surf_start_fline(1,inum)-one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 2 + if(abs(fln_src%xi_surf_start_fline(2,inum)+one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 3 + if(abs(fln_src%xi_surf_start_fline(2,inum)-one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 4 + if(abs(fln_src%xi_surf_start_fline(3,inum)+one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 5 + if(abs(fln_src%xi_surf_start_fline(3,inum)-one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 6 + + fln_tce%iline_original(icou) = inum + fln_tce%xx_fline_start(1:3,icou) & + & = fln_prm%xx_surf_start_fline(1:3,inum) + fln_tce%xx_fline_start(4,icou) = one + fln_tce%trace_length(icou) = 0.0d0 + fln_tce%icount_fline(icou) = 0 + + if (fln_prm%id_fline_direction & + & .eq. iflag_forward_trace) then + fln_tce%iflag_direction(icou) = 1 + else if(fln_prm%id_fline_direction & + & .eq. iflag_backward_trace) then + + fln_tce%iflag_direction(icou) = -1 + else + fln_tce%iflag_direction(icou) = 1 +! + icou = icou + 1 + fln_tce%iflag_direction(icou) = -1 + fln_tce%isf_dbl_start(1,icou) = my_rank + fln_tce%isf_dbl_start(2,icou) & + & = fln_src%iele_surf_start_fline(inum) +! + fln_tce%isf_dbl_start(3,icou) = 0 + if(abs(fln_src%xi_surf_start_fline(1,inum)+one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 1 + if(abs(fln_src%xi_surf_start_fline(1,inum)-one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 2 + if(abs(fln_src%xi_surf_start_fline(2,inum)+one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 3 + if(abs(fln_src%xi_surf_start_fline(2,inum)-one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 4 + if(abs(fln_src%xi_surf_start_fline(3,inum)+one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 5 + if(abs(fln_src%xi_surf_start_fline(3,inum)-one) & + & .lt. error_level) fln_tce%isf_dbl_start(3,icou) = 6 +! + fln_tce%trace_length(icou) = 0.0d0 + fln_tce%icount_fline(icou) = 0 + call copy_global_start_fline(icou, (icou-1), & + & fln_prm%fline_fields, fln_tce) + + end if + end do +! + end subroutine set_FLINE_seed_field_from_list +! +! --------------------------------------------------------------------- +! + subroutine cal_each_seed_field_in_ele & + & (node, ele, nod_fld, fline_fields, iphys_4_fline, & + & iele_surf_start_fline, xi_surf_start_fline, & + & xx_surf_start_fline, v_fline_start, c_fline_start) +! + use sel_interpolate_scalar + use extend_field_line + use trace_in_element + use tracer_field_interpolate +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(phys_data), intent(in) :: nod_fld +! + type(ctl_params_viz_fields), intent(in) :: fline_fields + integer(kind = kint), intent(in) :: iphys_4_fline +! + integer(kind = kint), intent(in) :: iele_surf_start_fline(1) + real(kind = kreal), intent(in) :: xi_surf_start_fline(3) + real(kind = kreal), intent(in) :: xx_surf_start_fline(3) +! + real(kind = kreal), intent(inout) :: v_fline_start(4) + real(kind = kreal), intent(inout) & + & :: c_fline_start(fline_fields%ntot_color_comp) +! +! real(kind = kreal) :: position_check(3) +! + call sel_sgl_interpolate_scalar_ele & + & (node%numnod, ele%numele, ele%nnod_4_ele, ele%ie, & + & nod_fld%d_fld(1,iphys_4_fline), iele_surf_start_fline(1), & + & xi_surf_start_fline, v_fline_start(1)) + call sel_sgl_interpolate_scalar_ele & + & (node%numnod, ele%numele, ele%nnod_4_ele, ele%ie, & + & nod_fld%d_fld(1,iphys_4_fline+1), iele_surf_start_fline(1), & + & xi_surf_start_fline, v_fline_start(2)) + call sel_sgl_interpolate_scalar_ele & + & (node%numnod, ele%numele, ele%nnod_4_ele, ele%ie, & + & nod_fld%d_fld(1,iphys_4_fline+2), iele_surf_start_fline(1), & + & xi_surf_start_fline, v_fline_start(3)) + v_fline_start(4) = one +! + call cal_fields_in_element(iele_surf_start_fline, & + & xi_surf_start_fline, xx_surf_start_fline, & + & ele, nod_fld, fline_fields, c_fline_start(1)) +! + end subroutine cal_each_seed_field_in_ele +! +! --------------------------------------------------------------------- +! + subroutine set_field_at_each_seed_point(node, ele, nod_fld, & + & fline_fields, iphys_4_fline, iele_seed, x4_seed, & + & v_fline_start, c_fline_start) +! + use t_find_interpolate_in_ele +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(phys_data), intent(in) :: nod_fld +! + type(ctl_params_viz_fields), intent(in) :: fline_fields + integer(kind = kint), intent(in) :: iphys_4_fline +! + integer(kind = kint), intent(in) :: iele_seed(1) + real(kind = kreal), intent(in) :: x4_seed(4) +! + real(kind = kreal), intent(inout) :: v_fline_start(4) + real(kind = kreal), intent(inout) & + & :: c_fline_start(fline_fields%ntot_color_comp) +! + type(cal_interpolate_coefs_work), save :: itp_ele_work_f + integer(kind = kint) :: ierr_inter + real(kind = kreal) :: xi_in_ele(3) +! + call alloc_work_4_interpolate(ele%nnod_4_ele, itp_ele_work_f) + xi_in_ele(1:3) = -2.0 + call find_interpolate_in_ele(x4_seed, maxitr, eps_iter, & + & my_rank, iflag_nomessage, error_level, node, ele, & + & iele_seed(1), itp_ele_work_f, xi_in_ele, ierr_inter) + call dealloc_work_4_interpolate(itp_ele_work_f) +! + call cal_each_seed_field_in_ele & + & (node, ele, nod_fld, fline_fields, iphys_4_fline, & + & iele_seed, xi_in_ele, x4_seed, v_fline_start, c_fline_start) +! + end subroutine set_field_at_each_seed_point +! +! --------------------------------------------------------------------- +! + end module set_fline_seeds_from_list diff --git a/src/Fortran_libraries/VIZ_src/fieldline/set_fline_start_surface.f90 b/src/Fortran_libraries/VIZ_src/fieldline/set_fline_start_surface.f90 new file mode 100644 index 00000000..bca7da36 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/set_fline_start_surface.f90 @@ -0,0 +1,292 @@ +!>@file set_control_each_fline.f90 +!!@brief module set_control_each_fline +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Set seed points on surface +!! +!!@verbatim +!! integer(kind = kint) function count_fline_start_surf & +!! & (node, ele, surf, isf_4_ele_dbl, & +!! & nod_fld, fln_prm, fln_src) +!! subroutine set_fline_start_surf(node, ele, surf, isf_4_ele_dbl, & +!! & nod_fld, fln_prm, fln_src, fln_tce) +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(phys_data), intent(in) :: nod_fld +!! integer(kind = kint), intent(in) & +!! & :: isf_4_ele_dbl(ele%numele,nsurf_4_ele,2) +!! type(fieldline_paramter), intent(in) :: fln_prm +!! type(each_fieldline_source), intent(in) :: fln_src +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!!@endverbatim +! + module set_fline_start_surface +! + use m_precision + use m_geometry_constants + use t_geometry_data + use t_surface_data + use t_tracing_data + use calypso_mpi +! + implicit none +! + private :: check_fline_start_surf, choose_fline_start_surf +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + integer(kind = kint) function count_fline_start_surf & + & (node, ele, surf, isf_4_ele_dbl, & + & nod_fld, fln_prm, fln_src) +! + use m_constants + use m_geometry_constants + use t_phys_data + use t_control_params_4_fline + use t_source_of_filed_line + use cal_field_on_surf_viz +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + integer(kind = kint), intent(in) & + & :: isf_4_ele_dbl(ele%numele,nsurf_4_ele,2) + type(phys_data), intent(in) :: nod_fld + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_source), intent(inout) :: fln_src +! + integer(kind = kint) :: icou + integer(kind = kint) :: i, iele, isf_1ele, isurf + real(kind = kreal), parameter :: xi(2) = (/zero, zero/) + real(kind = kreal) :: vec_surf(3), flux +! +! + icou = 0 + do i = 1, fln_src%num_line_local + iele = fln_prm%id_surf_start_fline(1,i) + isf_1ele = fln_prm%id_surf_start_fline(2,i) + isurf = abs(surf%isf_4_ele(iele,isf_1ele)) + fln_src%xx4_initial_fline(1:3,i) = surf%x_surf(isurf,1:3) + fln_src%xx4_initial_fline(4,i) = 1.0d0 +! + call cal_field_on_surf_vector & + & (node%numnod, surf%numsurf, surf%nnod_4_surf, surf%ie_surf, & + & isurf, xi, nod_fld%d_fld(1,fln_prm%iphys_4_fline), & + & vec_surf) +! + flux = (vec_surf(1) * surf%vnorm_surf(isurf,1) & + & + vec_surf(2) * surf%vnorm_surf(isurf,2) & + & + vec_surf(3) * surf%vnorm_surf(isurf,3)) & + & * dble(surf%isf_4_ele(iele,isf_1ele) / isurf) + if(flux .eq. zero) then + fln_src%iflag_outward_flux_fline(i) = 1 + else + fln_src%iflag_outward_flux_fline(i) = int(flux / abs(flux)) + end if +! + if(fln_prm%id_fline_direction .ne. iflag_both_trace) then + icou = icou + check_fline_start_surf & + & (fln_src%iflag_outward_flux_fline(i), & + & iele, isf_1ele, isurf, ele, surf, & + & isf_4_ele_dbl, fln_prm%id_fline_direction) + else + icou = icou + check_fline_start_surf & + & (fln_src%iflag_outward_flux_fline(i), & + & iele, isf_1ele, isurf, ele, surf, & + & isf_4_ele_dbl, iflag_forward_trace) + icou = icou + check_fline_start_surf & + & (fln_src%iflag_outward_flux_fline(i), & + & iele, isf_1ele, isurf, ele, surf, & + & isf_4_ele_dbl, iflag_backward_trace) + end if + end do + count_fline_start_surf = icou +! + end function count_fline_start_surf +! +! --------------------------------------------------------------------- +! + subroutine set_fline_start_surf(node, ele, surf, isf_4_ele_dbl, & + & nod_fld, fln_prm, fln_src, fln_tce) +! + use m_constants + use m_geometry_constants + use t_phys_data + use t_control_params_4_fline + use t_source_of_filed_line +! + use cal_field_on_surf_viz + use trace_in_element + use tracer_field_interpolate +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + integer(kind = kint), intent(in) & + & :: isf_4_ele_dbl(ele%numele,nsurf_4_ele,2) + type(phys_data), intent(in) :: nod_fld + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_source), intent(in) :: fln_src +! + type(each_fieldline_trace), intent(inout) :: fln_tce +! + integer(kind = kint) :: icou +! + integer(kind = kint) :: i, iele, isf_1ele, isurf + real(kind = kreal) :: xyz_surf(4), vec_surf(4) + real(kind = kreal), parameter :: xi(2) = (/zero, zero/) +! + integer(kind = kint) :: isf_dbl_st_tmp(2) +! +! + icou = 0 + do i = 1, fln_src%num_line_local + iele = fln_prm%id_surf_start_fline(1,i) + isf_1ele = fln_prm%id_surf_start_fline(2,i) + isurf = abs(surf%isf_4_ele(iele,isf_1ele)) +! + xyz_surf(1:3) = surf%x_surf(isurf,1:3) + xyz_surf(4) = 1.0d0 + call cal_field_on_surf_vector & + & (node%numnod, surf%numsurf, surf%nnod_4_surf, surf%ie_surf, & + & isurf, xi, nod_fld%d_fld(1,fln_prm%iphys_4_fline), & + & vec_surf(1)) + vec_surf(4) = one +! + if(fln_prm%id_fline_direction .ne. iflag_both_trace) then + call choose_fline_start_surf & + & (fln_src%iflag_outward_flux_fline(i), & + & iele, isf_1ele, isurf, ele, surf, isf_4_ele_dbl, & + & fln_prm%id_fline_direction, isf_dbl_st_tmp) + if(isf_dbl_st_tmp(2) .le. 0) cycle +! + icou = icou + 1 + fln_tce%iline_original(icou) = i & + & + fln_tce%istack_current_fline(my_rank) + fln_tce%iflag_direction(icou) = fln_prm%id_fline_direction + fln_tce%isf_dbl_start(1,icou) = my_rank + fln_tce%isf_dbl_start(2,icou) = isf_dbl_st_tmp(1) + fln_tce%isf_dbl_start(3,icou) = isf_dbl_st_tmp(2) + fln_tce%xx_fline_start(1:4,icou) = xyz_surf(1:4) + fln_tce%v_fline_start(1:4,icou) = vec_surf(1:4) + fln_tce%trace_length(icou) = 0.0d0 + fln_tce%icount_fline(icou) = 0 +! + call cal_fields_on_line(isurf, xi, xyz_surf(1), & + & surf, nod_fld, fln_prm%fline_fields, & + & fln_tce%c_fline_start(1,icou)) + else + fln_tce%iflag_direction(icou) = iflag_forward_trace +! + call choose_fline_start_surf & + & (fln_src%iflag_outward_flux_fline(i), & + & iele, isf_1ele, isurf, ele, surf, isf_4_ele_dbl, & + & iflag_forward_trace, isf_dbl_st_tmp) +! + if(isf_dbl_st_tmp(2) .gt. 0) then + icou = icou + 1 + fln_tce%iline_original(icou) = i & + & + fln_tce%istack_current_fline(my_rank) + fln_tce%iflag_direction(icou) = iflag_backward_trace + fln_tce%isf_dbl_start(1,icou) = my_rank + fln_tce%isf_dbl_start(2,icou) = isf_dbl_st_tmp(1) + fln_tce%isf_dbl_start(3,icou) = isf_dbl_st_tmp(2) + fln_tce%xx_fline_start(1:4,icou) = xyz_surf(1:4) + fln_tce%v_fline_start(1:4,icou) = vec_surf(1:4) + fln_tce%trace_length(icou) = 0.0d0 + fln_tce%icount_fline(icou) = 0 +! + call cal_fields_on_line(isurf, xi, xyz_surf(1), & + & surf, nod_fld, fln_prm%fline_fields, & + & fln_tce%c_fline_start(1,icou)) + end if +! + call choose_fline_start_surf & + & (fln_src%iflag_outward_flux_fline(i), & + & iele, isf_1ele, isurf, ele, surf, isf_4_ele_dbl, & + & iflag_backward_trace, isf_dbl_st_tmp) + if(isf_dbl_st_tmp(2) .le. 0) cycle +! + icou = icou + 1 + fln_tce%iflag_direction(icou) = iflag_backward_trace + fln_tce%isf_dbl_start(1,icou) = my_rank + fln_tce%isf_dbl_start(2,icou) = isf_dbl_st_tmp(1) + fln_tce%isf_dbl_start(3,icou) = isf_dbl_st_tmp(2) + fln_tce%trace_length(icou) = 0.0d0 + fln_tce%icount_fline(icou) = 0 + call copy_global_start_fline(icou, (icou-1), & + & fln_prm%fline_fields, fln_tce) + end if + end do +! + end subroutine set_fline_start_surf +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + integer(kind = kint) function check_fline_start_surf & + & (iflag_outward_flux, iele, isf_1ele, isurf, ele, surf, & + & isf_4_ele_dbl, iflag_direction) +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + integer(kind = kint), intent(in) & + & :: isf_4_ele_dbl(ele%numele,nsurf_4_ele,2) + integer(kind = kint), intent(in) :: iflag_outward_flux + integer(kind = kint), intent(in) :: iele, isf_1ele, isurf + integer(kind = kint), intent(in) :: iflag_direction +! + integer(kind = kint) :: iflag +! +! + check_fline_start_surf = 1 + if((iflag_direction*iflag_outward_flux) .le. 0) then + iflag = isf_1ele + else if(isf_4_ele_dbl(iele,isf_1ele,2) .le. 0) then + iflag = surf%iele_4_surf(isurf,1,2) + else + iflag = surf%iele_4_surf(isurf,2,2) + end if + if(iflag .eq. 0) check_fline_start_surf = 0 +! + end function check_fline_start_surf +! +! --------------------------------------------------------------------- +! + subroutine choose_fline_start_surf & + & (iflag_outward_flux, iele, isf_1ele, isurf, ele, surf, & + & isf_4_ele_dbl, iflag_direction, isf_dbl_start) +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + integer(kind = kint), intent(in) & + & :: isf_4_ele_dbl(ele%numele,nsurf_4_ele,2) + integer(kind = kint), intent(in) :: iflag_outward_flux + integer(kind = kint), intent(in) :: iele, isf_1ele, isurf +! + integer(kind = kint), intent(in) :: iflag_direction + integer(kind = kint), intent(inout) :: isf_dbl_start(2) +! +! + if((iflag_direction*iflag_outward_flux) .le. 0) then + isf_dbl_start(1) = iele + isf_dbl_start(2) = isf_1ele + else if(isf_4_ele_dbl(iele,isf_1ele,2) .le. 0) then + isf_dbl_start(1) = surf%iele_4_surf(isurf,1,1) + isf_dbl_start(2) = surf%iele_4_surf(isurf,1,2) + else + isf_dbl_start(1) = surf%iele_4_surf(isurf,2,1) + isf_dbl_start(2) = surf%iele_4_surf(isurf,2,2) + end if +! + end subroutine choose_fline_start_surf +! +! --------------------------------------------------------------------- +! + end module set_fline_start_surface diff --git a/src/Fortran_libraries/VIZ_src/fieldline/set_iflag_for_used_ele.f90 b/src/Fortran_libraries/VIZ_src/fieldline/set_iflag_for_used_ele.f90 new file mode 100644 index 00000000..de51db07 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/set_iflag_for_used_ele.f90 @@ -0,0 +1,114 @@ +!>@file set_iflag_for_used_ele.f90 +!!@brief module set_iflag_for_used_ele +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief Mark used elements for field line and PVR +!! +!!@verbatim +!! subroutine s_set_iflag_for_used_ele & +!! & (ele, ele_grp, ngrp_ele, id_ele_grp, iflag_used_ele) +!! subroutine set_iflag_used_ele_w_overlap(ele, ele_grp, & +!! & ngrp_ele, id_ele_grp, iflag_used_ele) +!! type(element_data), intent(in) :: ele +!! type(group_data), intent(in) :: ele_grp +!!@endverbatim +! + module set_iflag_for_used_ele +! + use m_precision + use t_geometry_data + use t_group_data +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_set_iflag_for_used_ele & + & (ele, ele_grp, ngrp_ele, id_ele_grp, iflag_used_ele) +! + type(element_data), intent(in) :: ele + type(group_data), intent(in) :: ele_grp +! + integer(kind = kint), intent(in) :: ngrp_ele + integer(kind = kint), intent(in) :: id_ele_grp(ngrp_ele) + integer(kind = kint), intent(inout) :: iflag_used_ele(ele%numele) +! + integer(kind = kint) :: jgrp, jnum, jele, jg, jst, jed +! +! +!$omp parallel workshare + iflag_used_ele(1:ele%numele) = 0 +!$omp end parallel workshare +! + do jgrp = 1, ngrp_ele + jg = id_ele_grp(jgrp) + if(jg .le. 0) then +!$omp parallel do + do jele = 1, ele%numele + if(ele%interior_ele(jele) .gt. 0) iflag_used_ele(jele) = 1 + end do +!$omp end parallel do + else + jst = ele_grp%istack_grp(jg-1) + 1 + jed = ele_grp%istack_grp(jg) +!$omp parallel do private(jnum,jele) + do jnum = jst, jed + jele = ele_grp%item_grp(jnum) + if(ele%interior_ele(jele) .gt. 0) iflag_used_ele(jele) = 1 + end do +!$omp end parallel do + end if + end do +! + end subroutine s_set_iflag_for_used_ele +! +! --------------------------------------------------------------------- +! + subroutine set_iflag_used_ele_w_overlap(ele, ele_grp, & + & ngrp_ele, id_ele_grp, iflag_used_ele) +! + type(element_data), intent(in) :: ele + type(group_data), intent(in) :: ele_grp +! + integer(kind = kint), intent(in) :: ngrp_ele + integer(kind = kint), intent(in) :: id_ele_grp(ngrp_ele) + integer(kind = kint), intent(inout) :: iflag_used_ele(ele%numele) +! + integer(kind = kint) :: jgrp, jnum, jele, jg, jst, jed +! +! +!$omp parallel workshare + iflag_used_ele(1:ele%numele) = 0 +!$omp end parallel workshare +! + do jgrp = 1, ngrp_ele + jg = id_ele_grp(jgrp) + if(jg .le. 0) then +!$omp parallel do + do jele = 1, ele%numele + iflag_used_ele(jele) = 1 + end do +!$omp end parallel do + else + jst = ele_grp%istack_grp(jg-1) + 1 + jed = ele_grp%istack_grp(jg) +!$omp parallel do private(jnum,jele) + do jnum = jst, jed + jele = ele_grp%item_grp(jnum) + iflag_used_ele(jele) = 1 + end do +!$omp end parallel do + end if + end do +! + end subroutine set_iflag_used_ele_w_overlap +! +! --------------------------------------------------------------------- +! + end module set_iflag_for_used_ele diff --git a/src/Fortran_libraries/VIZ_src/fieldline/start_surface_4_fline.f90 b/src/Fortran_libraries/VIZ_src/fieldline/start_surface_4_fline.f90 new file mode 100644 index 00000000..94d5f512 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/start_surface_4_fline.f90 @@ -0,0 +1,111 @@ +!start_surface_4_fline.f90 +! +! module start_surface_4_fline +! +! Written by H. Matsui on Aug., 2011 +! +!! subroutine s_start_surface_4_fline(node, surf, nod_fld, & +!! & fln_prm, fln_src, fln_tce) +!! type(node_data), intent(in) :: node +!! type(surface_data), intent(in) :: surf +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_paramter), intent(inout) :: fln_prm +!! type(each_fieldline_source), intent(inout) :: fln_src +!! type(each_fieldline_trace), intent(inout) :: fln_tce +! + module start_surface_4_fline +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter +! + use t_phys_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_control_params_4_fline + use t_source_of_filed_line + use t_tracing_data +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_start_surface_4_fline(node, ele, surf, nod_fld, & + & isf_4_ele_dbl, fln_prm, fln_src, fln_tce) +! + use calypso_mpi_int + use extend_field_line + use cal_field_on_surf_viz + use set_fline_start_surface + use cal_field_on_surf_viz +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + integer(kind = kint), intent(in) & + & :: isf_4_ele_dbl(ele%numele,nsurf_4_ele,2) + type(phys_data), intent(in) :: nod_fld +! + type(fieldline_paramter), intent(inout) :: fln_prm + type(each_fieldline_source), intent(inout) :: fln_src + type(each_fieldline_trace), intent(inout) :: fln_tce +! + integer(kind = kint) :: i, ist, ied, inum +! +! + fln_tce%num_current_fline & + & = count_fline_start_surf(node, ele, surf, isf_4_ele_dbl, & + & nod_fld, fln_prm, fln_src) + call resize_line_start_fline(fln_tce%num_current_fline, & + & fln_prm%fline_fields, fln_tce) +! + fln_tce%istack_current_fline(0) = 0 + call calypso_mpi_allgather_one_int & + & (fln_tce%num_current_fline, fln_tce%istack_current_fline(1)) + do i = 1, nprocs + fln_tce%istack_current_fline(i) & + & = fln_tce%istack_current_fline(i-1) & + & + fln_tce%istack_current_fline(i) + end do +! + call set_fline_start_surf(node, ele, surf, isf_4_ele_dbl, & + & nod_fld, fln_prm, fln_src, fln_tce) +! + if(i_debug .gt. iflag_full_msg) then + write(50+my_rank,*) 'num_current_fline', & + & fln_tce%num_current_fline + write(50+my_rank,*) 'istack_current_fline', & + & fln_tce%istack_current_fline(:) +! + write(50+my_rank,*) 'num_line_local', fln_src%num_line_local + do i = 1, fln_src%num_line_local + write(50+my_rank,*) 'id_surf_start_fline', i, & + & fln_prm%id_surf_start_fline(1:2,i) + write(50+my_rank,'(a,1p4e16.5)') 'start_point, flux', & + & fln_src%xx4_initial_fline(1:3,i) + end do +! +! + ist = fln_tce%istack_current_fline(my_rank) + 1 + ied = fln_tce%istack_current_fline(my_rank+1) + do inum = ist, ied + write(50+my_rank,*) 'isf_dbl_start', inum, & + & fln_tce%isf_dbl_start(1:3,inum) + write(50+my_rank,'(a,i16, 1p4e16.5)') 'start_point', & + & fln_tce%iline_original(inum), & + & fln_tce%xx_fline_start(1:4,inum) + end do + end if +! + end subroutine s_start_surface_4_fline +! +! --------------------------------------------------------------------- +! + end module start_surface_4_fline diff --git a/src/Fortran_libraries/VIZ_src/fieldline/start_surface_by_flux.f90 b/src/Fortran_libraries/VIZ_src/fieldline/start_surface_by_flux.f90 new file mode 100644 index 00000000..b9ecfe10 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/start_surface_by_flux.f90 @@ -0,0 +1,254 @@ +!>@file start_surface_by_flux.f90 +!!@brief module start_surface_by_flux +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Surface group list to set seed points +!! +!!@verbatim +!! subroutine s_start_surface_by_flux(ele, surf, sf_grp, nod_fld, & +!! & fln_prm, fln_src, fln_tce) +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(surface_group_data), intent(in) :: sf_grp +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_paramter), intent(inout) :: fln_prm +!! type(each_fieldline_source), intent(inout) :: fln_src +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!!@endverbatim +! + module start_surface_by_flux +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter +! + use t_phys_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_control_params_4_fline + use t_source_of_filed_line + use t_tracing_data + use t_fline_seeds_surf_group +! + implicit none +! + private :: start_surface_by_random, start_surface_witout_random +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_start_surface_by_flux(ele, surf, sf_grp, nod_fld, & + & fln_prm, fln_src, fln_tce) +! + use calypso_mpi_real + use extend_field_line + use cal_field_on_surf_viz + use set_fline_start_surface +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(surface_group_data), intent(in) :: sf_grp + type(phys_data), intent(in) :: nod_fld +! + type(fieldline_paramter), intent(inout) :: fln_prm + type(each_fieldline_source), intent(inout) :: fln_src + type(each_fieldline_trace), intent(inout) :: fln_tce +! + type(fieldline_seeds_surf_group) :: seed_sf_grp +! + integer(kind = kint) :: ip, i + integer(kind = kint) :: num_sf +! + real(kind = kreal) :: tot_flux_start, tot_flux_start_l + real(kind = kreal) :: abs_flux_start, abs_flux_start_l + real(kind = kreal) :: flux_4_each_line +! +! + call init_flux_on_seed_surface(ele, surf, sf_grp, nod_fld, & + & fln_prm, seed_sf_grp) +! + abs_flux_start_l = 0.0d0 + tot_flux_start_l = 0.0d0 + do i = 1, seed_sf_grp%nsurf_seed + abs_flux_start_l & + & = abs_flux_start_l + abs(seed_sf_grp%flux_start(i)) + tot_flux_start_l & + & = tot_flux_start_l + seed_sf_grp%flux_start(i) + end do +! + call calypso_mpi_allreduce_one_real & + & (tot_flux_start_l, tot_flux_start, MPI_SUM) + call calypso_mpi_allgather_one_real & + & (abs_flux_start_l, fln_src%flux_stack_fline(1)) +! + fln_src%flux_stack_fline(0) = 0.0d0 + do ip = 1, nprocs + fln_src%flux_stack_fline(ip) & + & = fln_src%flux_stack_fline(ip-1) & + & + fln_src%flux_stack_fline(ip) + end do + abs_flux_start = fln_src%flux_stack_fline(nprocs) + flux_4_each_line & + & = abs_flux_start / dble(fln_prm%num_each_field_line) +! + fln_tce%istack_current_fline(0) = 0 + do ip = 1, nprocs + fln_tce%istack_current_fline(ip) & + & = nint((fln_src%flux_stack_fline(ip) & + & - fln_src%flux_stack_fline(ip-1)) / flux_4_each_line) + end do + fln_src%num_line_local & + & = fln_tce%istack_current_fline(my_rank+1) +! + if(i_debug .gt. 0) then + write(my_rank+50,*) 'abs_flux_start', & + & abs_flux_start_l, abs_flux_start + write(my_rank+50,*) 'tot_flux_start', & + & tot_flux_start_l, tot_flux_start + write(my_rank+50,*) 'original num_line_local', & + & fln_src%num_line_local + write(my_rank+50,*) 'flux_4_each_line', flux_4_each_line + end if +! + if(fln_src%num_line_local .gt. 0) then + flux_4_each_line & + & = abs_flux_start_l / dble(fln_src%num_line_local) + end if + write(my_rank+50,*) 'adjusted flux_4_each_line', & + & flux_4_each_line +! + if(fln_prm%num_each_field_line .gt. 0) then + if(fln_prm%id_seed_distribution .eq. iflag_no_random) then + call start_surface_witout_random & + & (seed_sf_grp, abs_flux_start_l, fln_src%num_line_local, & + & fln_prm%num_each_field_line, fln_prm%id_surf_start_fline) + else + if(iflag_debug .gt. 0) write(*,*) 'start_surface_by_random' + call start_surface_by_random & + & (seed_sf_grp, abs_flux_start_l, fln_src%num_line_local, & + & fln_prm%num_each_field_line, fln_prm%id_surf_start_fline) + end if + end if +! + call dealloc_flux_on_seed_surface(seed_sf_grp) +! + end subroutine s_start_surface_by_flux +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine start_surface_by_random & + & (seed_sf_grp, abs_flux_start_l, num_line_local, & + & num_line, id_surf_start_fline) +! + use extend_field_line + use cal_field_on_surf_viz + use set_fline_start_surface +! + type(fieldline_seeds_surf_group), intent(in) :: seed_sf_grp + real(kind = kreal), intent(in) :: abs_flux_start_l + integer(kind = kint), intent(in) :: num_line_local +! + integer(kind = kint), intent(in) :: num_line +! + integer(kind = kint), intent(inout) & + & :: id_surf_start_fline(2,num_line) +! + integer(kind = kint) :: i, inum + real(kind = kreal) :: flux, flux_new +! +! + real(kind = 8), allocatable :: r_rnd(:) + real(kind = kreal), allocatable :: rnd_flux(:) +! + integer(kind = 4) :: nRand = 2 + integer(kind = 4) :: count, clock + integer(kind = 4), allocatable :: seed(:) +! +! +! write(my_rank+50,*) 'random_seed', nRand, num_line_local + call random_seed(size = nRand) +! + allocate(seed(nRand)) + allocate(r_rnd(num_line_local)) + allocate(rnd_flux(num_line_local)) +! +! if(iflag_debug .gt. 0) write(*,*) 'system_clock', num_line_local + call system_clock(count = clock) + seed = clock +! + if(num_line_local .gt. 0) then +! if(iflag_debug .gt. 0) write(*,*) 'random_seed' + call random_seed(put = seed) +! if(iflag_debug .gt. 0) write(*,*) 'random_number' + call random_number(r_rnd) + do i = 1, num_line_local + rnd_flux(i) = r_rnd(i) * abs_flux_start_l +! + flux = 0.0d0 + do inum = 1, seed_sf_grp%nsurf_seed + flux_new = flux + abs(seed_sf_grp%flux_start(inum)) + if(rnd_flux(i) .gt. flux & + & .and. rnd_flux(i) .le. flux_new) exit + flux = flux_new + end do + id_surf_start_fline(1:2,i) & + & = seed_sf_grp%isf_grp_seed_item(1:2,inum) + end do + end if +! + deallocate(rnd_flux, r_rnd, seed) +! + end subroutine start_surface_by_random +! +! --------------------------------------------------------------------- +! + subroutine start_surface_witout_random & + & (seed_sf_grp, abs_flux_start_l, num_line_local, & + & num_line, id_surf_start_fline) +! + use extend_field_line + use cal_field_on_surf_viz + use set_fline_start_surface +! + type(fieldline_seeds_surf_group), intent(in) :: seed_sf_grp + real(kind = kreal), intent(in) :: abs_flux_start_l + integer(kind = kint), intent(in) :: num_line_local + integer(kind = kint), intent(in) :: num_line +! + integer(kind = kint), intent(inout) & + & :: id_surf_start_fline(2,num_line) +! + integer(kind = kint) :: icou, inum + real(kind = kreal) :: flux, ref_flux +! +! + if(num_line_local .le. 0) return +! + ref_flux = abs_flux_start_l / dble(num_line_local+1) + icou = 0 + flux = 0.0d0 + do inum = 1, seed_sf_grp%nsurf_seed + flux = flux + abs(seed_sf_grp%flux_start(inum)) + if(flux .ge. ref_flux) then + icou = icou + 1 + id_surf_start_fline(1:2,icou) & + & = seed_sf_grp%isf_grp_seed_item(1:2,inum) + flux = 0.0d0 + end if + if(icou .ge. num_line_local) exit + end do +! + end subroutine start_surface_witout_random +! +! --------------------------------------------------------------------- +! + end module start_surface_by_flux diff --git a/src/Fortran_libraries/VIZ_src/fieldline/start_surface_by_gl_table.f90 b/src/Fortran_libraries/VIZ_src/fieldline/start_surface_by_gl_table.f90 new file mode 100644 index 00000000..976b8c8c --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/start_surface_by_gl_table.f90 @@ -0,0 +1,150 @@ +!start_surface_by_gl_table.f90 +! +! module start_surface_by_gl_table +! +! Written by H. Matsui on Aug., 2011 +! +!! subroutine s_start_surface_by_gl_table & +!! & (ele, ele_grp, fln_prm, fln_src) +!! type(element_data), intent(in) :: ele +!! type(group_data), intent(in) :: ele_grp +!! type(fieldline_paramter), intent(in) :: fln_prm +!! type(each_fieldline_source), intent(inout) :: fln_src +! + module start_surface_by_gl_table +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter +! + use t_geometry_data + use t_group_data + use t_control_params_4_fline + use t_source_of_filed_line +! + implicit none +! + private :: cnt_start_surface_by_gl_table + private :: set_start_surface_by_gl_table +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_start_surface_by_gl_table & + & (ele, ele_grp, fln_prm, fln_src) +! + use extend_field_line + use cal_field_on_surf_viz + use set_fline_start_surface +! + type(element_data), intent(in) :: ele + type(group_data), intent(in) :: ele_grp +! + type(fieldline_paramter), intent(inout) :: fln_prm + type(each_fieldline_source), intent(inout) :: fln_src +! +! + fln_src%num_line_local & + & = cnt_start_surface_by_gl_table(ele%numele, ele%iele_global, & + & ele%interior_ele, ele_grp%num_grp, ele_grp%num_item, & + & ele_grp%istack_grp, ele_grp%item_grp, fln_prm) + call set_start_surface_by_gl_table & + & (ele%numele, ele%iele_global, ele%interior_ele, & + & ele_grp%num_grp, ele_grp%num_item, & + & ele_grp%istack_grp, ele_grp%item_grp, fln_prm) +! + end subroutine s_start_surface_by_gl_table +! +! --------------------------------------------------------------------- +! + integer(kind = kint) function cnt_start_surface_by_gl_table & + & (numele, iele_global, interior_ele, num_mat, num_mat_bc, & + & mat_istack, mat_item, fln_prm) +! + integer(kind=kint), intent(in) :: numele + integer(kind=kint_gl), intent(in) :: iele_global(numele) + integer(kind = kint), intent(in) :: interior_ele(numele) +! + integer(kind=kint), intent(in) :: num_mat, num_mat_bc + integer(kind=kint), intent(in) :: mat_istack(0:num_mat) + integer(kind=kint), intent(in) :: mat_item(num_mat_bc) + type(fieldline_paramter), intent(in) :: fln_prm +! + integer(kind = kint) :: inum, jgrp + integer(kind = kint) :: icou, jnum, jele, jg, jst, jed + integer(kind = kint_gl) :: iele_g +! +! + icou = 0 + do inum = 1, fln_prm%num_each_field_line + iele_g = fln_prm%id_gl_surf_start_fline(1,inum) + do jgrp = 1, fln_prm%nele_grp_area_fline + jg = fln_prm%id_ele_grp_area_fline(jgrp) + jst = mat_istack(jg-1) + 1 + jed = mat_istack(jg) + do jnum = jst, jed + jele = mat_item(jnum) + if(iele_g.eq.iele_global(jele) & + & .and. interior_ele(jele) .gt. 0) then + icou = icou + 1 + exit + end if + end do + end do + end do + cnt_start_surface_by_gl_table = icou +! + end function cnt_start_surface_by_gl_table +! +! --------------------------------------------------------------------- +! + subroutine set_start_surface_by_gl_table & + & (numele, iele_global, interior_ele, & + & num_mat, num_mat_bc, mat_istack, mat_item, fln_prm) +! + integer(kind = kint), intent(in) :: numele + integer(kind = kint_gl), intent(in) :: iele_global(numele) + integer(kind = kint), intent(in) :: interior_ele(numele) +! + integer(kind=kint), intent(in) :: num_mat, num_mat_bc + integer(kind=kint), intent(in) :: mat_istack(0:num_mat) + integer(kind=kint), intent(in) :: mat_item(num_mat_bc) +! + type(fieldline_paramter), intent(inout) :: fln_prm +! + integer(kind = kint) :: inum, jgrp + integer(kind = kint) :: icou, jnum, jele, jg, jst, jed + integer(kind = kint_gl) :: iele_g +! +! + icou = 0 + do inum = 1, fln_prm%num_each_field_line + iele_g = fln_prm%id_gl_surf_start_fline(1,inum) + do jgrp = 1, fln_prm%nele_grp_area_fline + jg = fln_prm%id_ele_grp_area_fline(jgrp) + jst = mat_istack(jg-1) + 1 + jed = mat_istack(jg) + do jnum = jst, jed + jele = mat_item(jnum) + if(iele_g.eq.iele_global(jele) & + & .and. interior_ele(jele) .gt. 0) then + icou = icou + 1 + fln_prm%id_surf_start_fline(1,icou) = jele + fln_prm%id_surf_start_fline(2,icou) & + & = fln_prm%id_gl_surf_start_fline(2,inum) + exit + end if + end do + end do + end do +! + end subroutine set_start_surface_by_gl_table +! +! --------------------------------------------------------------------- +! + end module start_surface_by_gl_table diff --git a/src/Fortran_libraries/VIZ_src/fieldline/start_surface_by_volume.f90 b/src/Fortran_libraries/VIZ_src/fieldline/start_surface_by_volume.f90 new file mode 100644 index 00000000..4b09de86 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/start_surface_by_volume.f90 @@ -0,0 +1,256 @@ +!>@file start_surface_by_volume.f90 +!!@brief module start_surface_by_volume +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Element group list to set seed points +!! +!!@verbatim +!! subroutine s_start_surface_by_volume(node, ele, ele_grp, & +!! & nod_fld, fln_prm, fln_src, fln_tce) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(group_data), intent(in) :: ele_grp +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_paramter), intent(inout) :: fln_prm +!! type(each_fieldline_source), intent(inout) :: fln_src +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!!@endverbatim +! + module start_surface_by_volume +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter +! + use t_phys_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_control_params_4_fline + use t_fline_seeds_ele_group + use t_source_of_filed_line + use t_tracing_data +! + implicit none +! + private :: start_element_by_random, start_element_witout_random +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_start_surface_by_volume(node, ele, ele_grp, & + & nod_fld, fln_prm, fln_src, fln_tce) +! + use calypso_mpi_real + use extend_field_line + use cal_field_on_surf_viz + use set_fline_start_surface +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(group_data), intent(in) :: ele_grp + type(phys_data), intent(in) :: nod_fld +! + type(fieldline_paramter), intent(inout) :: fln_prm + type(each_fieldline_source), intent(inout) :: fln_src + type(each_fieldline_trace), intent(inout) :: fln_tce +! + type(fieldline_seeds_ele_group) :: seed_ele_grp +! + integer(kind = kint) :: i, ip +! + real(kind = kreal) :: tot_flux_start, tot_flux_start_l + real(kind = kreal) :: abs_flux_start, abs_flux_start_l + real(kind = kreal) :: dencity_4_each_line +! +! + call init_density_on_seed_ele(node, ele, ele_grp, nod_fld, & + & fln_prm, seed_ele_grp) +! + abs_flux_start_l = 0.0d0 + tot_flux_start_l = 0.0d0 + do i = 1, seed_ele_grp%nele_seed + abs_flux_start_l & + & = abs_flux_start_l + abs(seed_ele_grp%density_seed(i)) + tot_flux_start_l & + & = tot_flux_start_l + seed_ele_grp%density_seed(i) + end do +! + call calypso_mpi_allreduce_one_real & + & (tot_flux_start_l, tot_flux_start, MPI_SUM) + call calypso_mpi_allgather_one_real & + & (abs_flux_start_l, fln_src%flux_stack_fline(1)) +! + fln_src%flux_stack_fline(0) = 0.0d0 + do ip = 1, nprocs + fln_src%flux_stack_fline(ip) & + & = fln_src%flux_stack_fline(ip-1) & + & + fln_src%flux_stack_fline(ip) + end do + abs_flux_start = fln_src%flux_stack_fline(nprocs) + dencity_4_each_line & + & = abs_flux_start / dble(fln_prm%num_each_field_line) +! + fln_tce%istack_current_fline(0) = 0 + do ip = 1, nprocs + fln_tce%istack_current_fline(ip) & + & = nint((fln_src%flux_stack_fline(ip) & + & - fln_src%flux_stack_fline(ip-1)) / dencity_4_each_line) + end do + fln_src%num_line_local & + & = fln_tce%istack_current_fline(my_rank+1) +! + if(i_debug .gt. 0) then + write(my_rank+50,*) 'abs_flux_start', & + & abs_flux_start_l, abs_flux_start + write(my_rank+50,*) 'tot_flux_start', & + & tot_flux_start_l, tot_flux_start + write(my_rank+50,*) 'original num_line_local', & + & fln_src%num_line_local + write(my_rank+50,*) 'dencity_4_each_line', dencity_4_each_line + end if +! + if(fln_src%num_line_local .gt. 0) then + dencity_4_each_line & + & = abs_flux_start_l / dble(fln_src%num_line_local) + end if + write(my_rank+50,*) 'adjusted dencity_4_each_line', & + & dencity_4_each_line +! + if(fln_prm%num_each_field_line .gt. 0) then + if(fln_prm%id_seed_distribution .eq. iflag_no_random) then + if(iflag_debug .gt. 0) & + & write(*,*) 'start_element_witout_random' + call start_element_witout_random & + & (seed_ele_grp, fln_src%num_line_local, abs_flux_start_l, & + & fln_prm%num_each_field_line, fln_prm%id_surf_start_fline) + else + if(iflag_debug .gt. 0) write(*,*) 'start_element_by_random' + call start_element_by_random & + & (seed_ele_grp, fln_src%num_line_local, abs_flux_start_l, & + & fln_prm%num_each_field_line, fln_prm%id_surf_start_fline) + end if + end if +! + call dealloc_density_on_seed_ele(seed_ele_grp) +! + end subroutine s_start_surface_by_volume +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine start_element_by_random & + & (seed_ele_grp, num_line_local, abs_flux_start_l, & + & num_line, id_surf_start_fline) +! + use extend_field_line + use cal_field_on_surf_viz + use set_fline_start_surface +! + type(fieldline_seeds_ele_group), intent(in) :: seed_ele_grp + integer(kind = kint), intent(in) :: num_line_local + real(kind = kreal), intent(in) :: abs_flux_start_l +! + integer(kind = kint), intent(in) :: num_line +! + integer(kind = kint), intent(inout) & + & :: id_surf_start_fline(2,num_line) +! + integer(kind = kint) :: i, inum + real(kind = kreal) :: flux, flux_new +! +! + real(kind = 8), allocatable :: r_rnd(:) + real(kind = kreal), allocatable :: rnd_flux(:) +! + integer(kind = 4) :: nRand = 2 + integer(kind = 4) :: count, clock + integer(kind = 4), allocatable :: seed(:) +! +! + call random_seed(size = nRand) +! + allocate(seed(nRand)) + allocate(r_rnd(num_line_local)) + allocate(rnd_flux(num_line_local)) +! + if(iflag_debug .gt. 0) write(*,*) 'system_clock', num_line_local + call system_clock(count = clock) + seed = clock +! + if(num_line_local .gt. 0) then + if(iflag_debug .gt. 0) write(*,*) 'random_seed' + call random_seed(put = seed) + if(iflag_debug .gt. 0) write(*,*) 'random_number' + call random_number(r_rnd) + do i = 1, num_line_local + rnd_flux(i) = r_rnd(i) * abs_flux_start_l +! + flux = 0.0d0 + do inum = 1, seed_ele_grp%nele_seed + flux_new = flux + abs(seed_ele_grp%density_seed(inum)) + if(rnd_flux(i) .gt. flux & + & .and. rnd_flux(i) .le. flux_new) exit + flux = flux_new + end do + id_surf_start_fline(1,i) & + & = seed_ele_grp%iele_grp_seed_item(inum) + id_surf_start_fline(2,i) = 0 + end do + end if +! + deallocate(rnd_flux, r_rnd, seed) +! + end subroutine start_element_by_random +! +! --------------------------------------------------------------------- +! + subroutine start_element_witout_random & + & (seed_ele_grp, num_line_local, abs_flux_start_l, & + & num_line, id_surf_start_fline) +! + use extend_field_line + use cal_field_on_surf_viz + use set_fline_start_surface +! + integer(kind = kint), intent(in) :: num_line_local + type(fieldline_seeds_ele_group), intent(in) :: seed_ele_grp + real(kind = kreal), intent(in) :: abs_flux_start_l + integer(kind = kint), intent(in) :: num_line +! + integer(kind = kint), intent(inout) & + & :: id_surf_start_fline(2,num_line) +! + integer(kind = kint) :: icou, inum + real(kind = kreal) :: flux, ref_flux +! +! + if(num_line_local .le. 0) return +! + ref_flux = abs_flux_start_l / dble(num_line_local+1) + icou = 0 + flux = 0.0d0 + do inum = 1, seed_ele_grp%nele_seed + flux = flux + abs(seed_ele_grp%density_seed(inum)) + if(flux .ge. ref_flux) then + icou = icou + 1 + id_surf_start_fline(1,icou) & + & = seed_ele_grp%iele_grp_seed_item(inum) + id_surf_start_fline(2,icou) = 0 + flux = 0.0d0 + end if + if(icou .ge. num_line_local) exit + end do +! + end subroutine start_element_witout_random +! +! --------------------------------------------------------------------- +! + end module start_surface_by_volume diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_broadcast_trace_data.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_broadcast_trace_data.f90 new file mode 100644 index 00000000..a0bb88df --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_broadcast_trace_data.f90 @@ -0,0 +1,250 @@ +!>@file t_broadcast_trace_data.f90 +!!@brief module t_broadcast_trace_data +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Routines to construct field lines +!! +!!@verbatim +!! subroutine alloc_broadcast_trace_data(num_each_field_line, & +!! & viz_fields, fln_bcast) +!! subroutine dealloc_broadcast_trace_data(fln_bcast) +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! type(broadcast_trace_data), intent(inout) :: fln_bcast +!! +!! subroutine s_broadcast_trace_data(fln_prm, fln_tce, & +!! & fln_bcast, nline_global) +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!! type(broadcast_trace_data), intent(inout) :: fln_bcast +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! integer(kind = kint), intent(in) & +!! & :: isf_4_ele_dbl(ele%numele,nsurf_4_ele,2) +!! integer(kind = kint), intent(in) & +!! & :: iele_4_surf_dbl(surf%numsurf,2,3) +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!! type(broadcast_trace_data), intent(inout) :: fln_bcast +!! integer(kind = kint), intent(inout) :: nline_global +!!@endverbatim +! + module t_broadcast_trace_data +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter + use m_geometry_constants + use t_comm_table + use t_para_double_numbering + use t_control_params_4_fline +! + implicit none +! + integer(kind= kint), parameter, private :: nitem8_bcast = 1 + integer(kind= kint), parameter, private :: nitem_bcast = 6 +! + type broadcast_trace_data + integer(kind= kint) :: ncomp_bcast + integer(kind= kint_gl), allocatable :: igl_fline_export(:,:) + integer(kind= kint), allocatable :: id_fline_export(:,:) + real(kind = kreal), allocatable :: fline_export(:,:) + end type broadcast_trace_data + + private :: set_fline_start_2_bcast, set_fline_start_from_neib +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_broadcast_trace_data(num_each_field_line, & + & viz_fields, fln_bcast) +! + use t_ctl_params_viz_fields +! + integer(kind = kint), intent(in) :: num_each_field_line + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(broadcast_trace_data), intent(inout) :: fln_bcast +! + integer(kind = kint) :: num +! +! + num = 2 * num_each_field_line + fln_bcast%ncomp_bcast = 9 + viz_fields%ntot_color_comp + allocate(fln_bcast%igl_fline_export(nitem8_bcast,num)) + allocate(fln_bcast%id_fline_export(nitem_bcast,num)) + allocate(fln_bcast%fline_export(fln_bcast%ncomp_bcast,num)) + fln_bcast%id_fline_export = 0 + fln_bcast%fline_export = 0.0d0 +! + end subroutine alloc_broadcast_trace_data +! +! --------------------------------------------------------------------- +! + subroutine dealloc_broadcast_trace_data(fln_bcast) +! + type(broadcast_trace_data), intent(inout) :: fln_bcast +! + deallocate(fln_bcast%igl_fline_export) + deallocate(fln_bcast%id_fline_export) + deallocate(fln_bcast%fline_export) +! + end subroutine dealloc_broadcast_trace_data +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine s_broadcast_trace_data(fln_prm, fln_tce, & + & fln_bcast, nline_global) +! + use t_tracing_data + use calypso_mpi_real + use calypso_mpi_int + use calypso_mpi_int8 + use transfer_to_long_integers +! + type(fieldline_paramter), intent(in) :: fln_prm +! + type(each_fieldline_trace), intent(inout) :: fln_tce + type(broadcast_trace_data), intent(inout) :: fln_bcast + integer(kind = kint), intent(inout) :: nline_global +! + integer(kind = kint) :: ist, ip, inum + integer(kind = kint_gl) :: num64 + integer :: src_rank +! +! + do inum = 1, fln_tce%num_current_fline + call set_fline_start_2_bcast(inum, fln_tce, fln_bcast) + end do +! + do ip = 1, nprocs + src_rank = int(ip - 1) + ist = fln_tce%istack_current_fline(ip-1) + num64 = fln_tce%istack_current_fline(ip) - ist + if(num64 .le. 0) cycle + call calypso_mpi_bcast_int8 & + & (fln_bcast%igl_fline_export(1,ist+1), & + & (num64*nitem8_bcast), src_rank) + call calypso_mpi_bcast_int & + & (fln_bcast%id_fline_export(1,ist+1), & + & (num64*nitem_bcast), src_rank) + call calypso_mpi_bcast_real & + & (fln_bcast%fline_export(1,ist+1), & + & (num64*fln_bcast%ncomp_bcast), src_rank) + end do +! + call set_fline_start_from_neib(fln_bcast, fln_prm, fln_tce) +! + nline_global = fln_tce%istack_current_fline(nprocs) & + & - fln_tce%istack_current_fline(0) +! + end subroutine s_broadcast_trace_data +! +! --------------------------------------------------------------------- +! + subroutine set_fline_start_2_bcast(i, fln_tce, fln_bcast) +! + use t_tracing_data +! + integer(kind = kint), intent(in) :: i + type(each_fieldline_trace), intent(in) :: fln_tce +! + type(broadcast_trace_data), intent(inout) :: fln_bcast +! + integer(kind = kint) :: ist +! +! + ist = fln_tce%istack_current_fline(my_rank) + if(fln_tce%iflag_comm_start(i) .eq. ione) then + fln_bcast%igl_fline_export(1,i+ist) & + & = fln_tce%iline_original(i) + fln_bcast%id_fline_export(1,i+ist) = my_rank + fln_bcast%id_fline_export(2,i+ist) = fln_tce%iflag_direction(i) + fln_bcast%id_fline_export(3,i+ist) = fln_tce%icount_fline(i) +! + fln_bcast%id_fline_export(4:6,i+ist) & + & = fln_tce%isf_dbl_start(1:3,i) +! + fln_bcast%fline_export(1:4,i+ist) & + & = fln_tce%xx_fline_start(1:4,i) + fln_bcast%fline_export(5:8,i+ist) & + & = fln_tce%v_fline_start(1:4,i) + fln_bcast%fline_export(9,i+ist) = fln_tce%trace_length(i) + fln_bcast%fline_export(9+1:fln_bcast%ncomp_bcast,i+ist) & + & = fln_tce%c_fline_start(1:fln_bcast%ncomp_bcast-9,i) + else + fln_bcast%id_fline_export(1:6,i+ist) = izero + fln_bcast%id_fline_export(4,i+ist) = -ione + fln_bcast%fline_export(1:fln_bcast%ncomp_bcast,i+ist) = zero + end if +! + end subroutine set_fline_start_2_bcast +! +! --------------------------------------------------------------------- +! + subroutine set_fline_start_from_neib(fln_bcast, fln_prm, fln_tce) +! + use calypso_mpi_int + use t_tracing_data +! + type(broadcast_trace_data), intent(in) :: fln_bcast + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_trace), intent(inout) :: fln_tce +! + integer(kind = kint) :: ied_lin, i, icou, ip +! +! +! + ied_lin = fln_tce%istack_current_fline(nprocs) + icou = 0 + do i = 1, ied_lin + if(fln_bcast%id_fline_export(4,i) .ne. my_rank) cycle +! + icou = icou + 1 + end do + fln_tce%num_current_fline = icou + call resize_line_start_fline(fln_tce%num_current_fline, & + & fln_prm%fline_fields, fln_tce) +! + fln_tce%istack_current_fline(0) = 0 + call calypso_mpi_allgather_one_int(fln_tce%num_current_fline, & + & fln_tce%istack_current_fline(1)) +! + do ip = 1, nprocs + fln_tce%istack_current_fline(ip) & + & = fln_tce%istack_current_fline(ip-1) & + & + fln_tce%istack_current_fline(ip) + end do +! + icou = 0 + do i = 1, ied_lin + if(fln_bcast%id_fline_export(4,i) .ne. my_rank) cycle +! + icou = icou + 1 + fln_tce%iline_original(icou) & + & = fln_bcast%igl_fline_export(1,i) + fln_tce%iflag_direction(icou) & + & = fln_bcast%id_fline_export(2,i) + fln_tce%icount_fline(icou) = fln_bcast%id_fline_export(3,i) + fln_tce%isf_dbl_start(1:3,icou) & + & = fln_bcast%id_fline_export(4:6,i) +! + fln_tce%xx_fline_start(1:4,icou) & + & = fln_bcast%fline_export(1:4,i) + fln_tce%v_fline_start(1:4,icou) & + & = fln_bcast%fline_export(5:8,i) + fln_tce%trace_length(icou) = fln_bcast%fline_export(9,i) + fln_tce%c_fline_start(1:fln_bcast%ncomp_bcast-9,icou) & + & = fln_bcast%fline_export(9+1:fln_bcast%ncomp_bcast,i) + end do +! + end subroutine set_fline_start_from_neib +! +! --------------------------------------------------------------------- +! + end module t_broadcast_trace_data + diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_control_data_flines.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_control_data_flines.f90 new file mode 100644 index 00000000..f33d09e9 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_control_data_flines.f90 @@ -0,0 +1,214 @@ +!>@file t_control_data_flines.f90 +!!@brief module t_control_data_flines +!! +!!@date Programmed by H.Matsui in May, 2006 +! +!>@brief control data for cross sections +!! +!!@verbatim +!! subroutine dealloc_fline_ctl_struct(fline_ctls) +!! subroutine alloc_fline_ctl_struct(fline_ctls) +!! subroutine init_fline_ctl_struct(hd_block, fline_ctls) +!! +!! subroutine add_fields_4_flines_to_fld_ctl(fline_ctls, field_ctl) +!! type(fieldline_controls), intent(in) :: fline_ctls +!! type(ctl_array_c3), intent(inout) :: field_ctl +!! +!! subroutine append_fline_control(idx_in, hd_block, fline_ctls) +!! subroutine delete_fline_control(idx_in, fline_ctls) +!! integer(kind = kint), intent(in) :: idx_in +!! character(len=kchara), intent(in) :: hd_block +!! type(fieldline_controls), intent(inout) :: fline_ctls +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array fieldline 1 +!! file fieldline 'ctl_fline_magne' +!! end array fieldline +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_control_data_flines +! + use m_precision + use m_constants +! + use m_machine_parameter + use t_ctl_data_field_line +! + implicit none +! + type fieldline_controls +!> Control block name + character(len = kchara) :: block_name = 'fieldline' +! + integer(kind = kint) :: num_fline_ctl = 0 + character(len = kchara), allocatable :: fname_fline_ctl(:) + type(fline_ctl), allocatable :: fline_ctl_struct(:) + end type fieldline_controls +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine dealloc_fline_ctl_struct(fline_ctls) +! + type(fieldline_controls), intent(inout) :: fline_ctls +! + integer(kind = kint) :: i +! + if(allocated(fline_ctls%fline_ctl_struct) .eqv. .FALSE.) return +! + do i = 1, fline_ctls%num_fline_ctl + call deallocate_cont_dat_fline(fline_ctls%fline_ctl_struct(i)) + end do + deallocate(fline_ctls%fline_ctl_struct) + deallocate(fline_ctls%fname_fline_ctl) + fline_ctls%num_fline_ctl = 0 +! + end subroutine dealloc_fline_ctl_struct +! +! --------------------------------------------------------------------- +! + subroutine alloc_fline_ctl_struct(fline_ctls) +! + type(fieldline_controls), intent(inout) :: fline_ctls +! + allocate(fline_ctls%fline_ctl_struct(fline_ctls%num_fline_ctl)) + allocate(fline_ctls%fname_fline_ctl(fline_ctls%num_fline_ctl)) +! + end subroutine alloc_fline_ctl_struct +! +! --------------------------------------------------------------------- +! + subroutine init_fline_ctl_struct(hd_block, fline_ctls) +! + character(len=kchara), intent(in) :: hd_block + type(fieldline_controls), intent(inout) :: fline_ctls +! + fline_ctls%block_name = hd_block + fline_ctls%num_fline_ctl = 0 +! + end subroutine init_fline_ctl_struct +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine append_fline_control(idx_in, hd_block, fline_ctls) +! + use ctl_data_field_line_IO +! + integer(kind = kint), intent(in) :: idx_in + character(len=kchara), intent(in) :: hd_block + type(fieldline_controls), intent(inout) :: fline_ctls +! + type(fieldline_controls) :: tmp_fline_c + integer(kind = kint) :: i +! +! + if(idx_in.lt.0 .or. idx_in.gt.fline_ctls%num_fline_ctl) return +! + tmp_fline_c%num_fline_ctl = fline_ctls%num_fline_ctl + call alloc_fline_ctl_struct(tmp_fline_c) +! + do i = 1, tmp_fline_c%num_fline_ctl + tmp_fline_c%fname_fline_ctl(i) & + & = fline_ctls%fname_fline_ctl(i) + call dup_control_4_fline(fline_ctls%fline_ctl_struct(i), & + tmp_fline_c%fline_ctl_struct(i)) + end do +! + call dealloc_fline_ctl_struct(fline_ctls) + fline_ctls%num_fline_ctl = tmp_fline_c%num_fline_ctl + 1 + call alloc_fline_ctl_struct(fline_ctls) +! + do i = 1, idx_in + fline_ctls%fname_fline_ctl(i) & + & = tmp_fline_c%fname_fline_ctl(i) + call dup_control_4_fline(tmp_fline_c%fline_ctl_struct(i), & + fline_ctls%fline_ctl_struct(i)) + end do +! + fline_ctls%fname_fline_ctl(idx_in+1) = 'NO_FILE' + call init_field_line_ctl_label(hd_block, & + & fline_ctls%fline_ctl_struct(idx_in+1)) +! + do i = idx_in+1, tmp_fline_c%num_fline_ctl + fline_ctls%fname_fline_ctl(i+1) & + & = tmp_fline_c%fname_fline_ctl(i) + call dup_control_4_fline(tmp_fline_c%fline_ctl_struct(i), & + fline_ctls%fline_ctl_struct(i+1)) + end do +! + call dealloc_fline_ctl_struct(tmp_fline_c) +! + end subroutine append_fline_control +! +! ----------------------------------------------------------------------- +! + subroutine delete_fline_control(idx_in, fline_ctls) +! + use ctl_data_field_line_IO +! + integer(kind = kint), intent(in) :: idx_in + type(fieldline_controls), intent(inout) :: fline_ctls +! + type(fieldline_controls) :: tmp_fline_c + integer(kind = kint) :: i +! +! + if(idx_in.le.0 .or. idx_in.gt.fline_ctls%num_fline_ctl) return +! + tmp_fline_c%num_fline_ctl = fline_ctls%num_fline_ctl + call alloc_fline_ctl_struct(tmp_fline_c) +! + do i = 1, tmp_fline_c%num_fline_ctl + tmp_fline_c%fname_fline_ctl(i) & + & = fline_ctls%fname_fline_ctl(i) + call dup_control_4_fline(fline_ctls%fline_ctl_struct(i), & + tmp_fline_c%fline_ctl_struct(i)) + end do +! + call dealloc_fline_ctl_struct(fline_ctls) + fline_ctls%num_fline_ctl = tmp_fline_c%num_fline_ctl + 1 + call alloc_fline_ctl_struct(fline_ctls) +! + do i = 1, idx_in-1 + fline_ctls%fname_fline_ctl(i) & + & = tmp_fline_c%fname_fline_ctl(i) + call dup_control_4_fline(tmp_fline_c%fline_ctl_struct(i), & + fline_ctls%fline_ctl_struct(i)) + end do + do i = idx_in, fline_ctls%num_fline_ctl + fline_ctls%fname_fline_ctl(i) & + & = tmp_fline_c%fname_fline_ctl(i+1) + call dup_control_4_fline(tmp_fline_c%fline_ctl_struct(i+1), & + fline_ctls%fline_ctl_struct(i)) + end do +! + call dealloc_fline_ctl_struct(tmp_fline_c) +! + end subroutine delete_fline_control +! +! ----------------------------------------------------------------------- +! + subroutine add_fields_4_flines_to_fld_ctl(fline_ctls, field_ctl) +! + use t_control_array_character3 +! + type(fieldline_controls), intent(in) :: fline_ctls + type(ctl_array_c3), intent(inout) :: field_ctl +! + integer(kind = kint) :: i_fline +! +! + do i_fline = 1, fline_ctls%num_fline_ctl + call add_field_4_fline_to_fld_ctl & + & (fline_ctls%fline_ctl_struct(i_fline), field_ctl) + end do +! + end subroutine add_fields_4_flines_to_fld_ctl +! +! --------------------------------------------------------------------- +! + end module t_control_data_flines diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_control_data_tracers.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_control_data_tracers.f90 new file mode 100644 index 00000000..e1910a6d --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_control_data_tracers.f90 @@ -0,0 +1,234 @@ +!>@file t_control_data_tracers.f90 +!!@brief module t_control_data_tracers +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Control data structure for visualization controls +!! +!!@verbatim +!! subroutine dealloc_tracer_controls(tracer_ctls) +!! type(tracers_control), intent(inout) :: tracer_ctls +!! subroutine add_flds_4_tracers_to_fld_ctl(tracer_ctls, field_ctl) +!! type(tracers_control), intent(in) :: tracer_ctls +!! type(ctl_array_c3), intent(inout) :: field_ctl +!! subroutine read_tracer_controls & +!! & (id_control, hd_block, tracer_ctls, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(tracers_control), intent(inout) :: tracer_ctls +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_tracer_controls(id_control, tracer_ctls, level) +!! integer(kind = kint), intent(in) :: id_control +!! type(tracers_control), intent(in) :: tracer_ctls +!! integer(kind = kint), intent(inout) :: level +!! subroutine init_tracers_ctl_label(hd_block, tracer_ctls) +!! character(len=kchara), intent(in) :: hd_block +!! type(tracers_control), intent(inout) :: tracer_ctls +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! begin tracers_control +!! array tracer_ctl +!! file tracer_ctl +!! +!! begin tracer_ctl +!! ... +!! end tracer_ctl +!! end array tracer_ctl +!! end tracers_control +!! +!! delta_t_tracer_output 1.0e-1 +!! i_step_tracer_output 400 +!! end tracers_control +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! +! + module t_control_data_tracers +! + use m_precision +! + use m_machine_parameter + use t_control_data_flines + use t_control_array_character + use t_control_array_real + use t_control_array_integer +! + implicit none +! +!> Structures of visualization controls + type tracers_control +!> Block name + character(len=kchara) :: block_name = 'tracers_control' +!> Structures of tracer controls + type(fieldline_controls) :: tracer_controls +! +!> Increment for field line + type(read_integer_item) :: i_step_tracer_out_ctl +!> time interval for field line + type(read_real_item) :: delta_t_tracer_out_ctl +! + integer (kind=kint) :: i_tracers_control = 0 + end type tracers_control +! + character(len=kchara), parameter, private & + & :: hd_tracer_ctl = 'tracer_ctl' + character(len=kchara), parameter, private & + & :: hd_i_step_tracer = 'i_step_tracer_output' + character(len=kchara), parameter, private & + & :: hd_delta_t_tracer = 'delta_t_tracer_output' +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine dealloc_tracer_controls(tracer_ctls) +! + type(tracers_control), intent(inout) :: tracer_ctls +! +! + call dealloc_fline_ctl_struct(tracer_ctls%tracer_controls) +! + tracer_ctls%delta_t_tracer_out_ctl%iflag = 0 + tracer_ctls%i_step_tracer_out_ctl%iflag = 0 +! + tracer_ctls%i_tracers_control = 0 +! + end subroutine dealloc_tracer_controls +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine add_flds_4_tracers_to_fld_ctl(tracer_ctls, field_ctl) +! + use t_control_array_character3 +! + type(tracers_control), intent(in) :: tracer_ctls + type(ctl_array_c3), intent(inout) :: field_ctl +! + if(tracer_ctls%tracer_controls%num_fline_ctl .gt. 0) then + call add_fields_4_flines_to_fld_ctl & + & (tracer_ctls%tracer_controls, field_ctl) + end if +! + end subroutine add_flds_4_tracers_to_fld_ctl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine read_tracer_controls & + & (id_control, hd_block, tracer_ctls, c_buf) +! + use t_read_control_elements + use ctl_file_fieldlines_IO + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(tracers_control), intent(inout) :: tracer_ctls + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(tracer_ctls%i_tracers_control .gt. 0) return + tracer_ctls%block_name = trim(hd_block) + call init_fline_ctl_struct(hd_tracer_ctl, & + & tracer_ctls%tracer_controls) + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_files_4_fline_ctl(id_control, hd_tracer_ctl, & + & tracer_ctls%tracer_controls, c_buf) +! + call read_integer_ctl_type(c_buf, hd_i_step_tracer, & + & tracer_ctls%i_step_tracer_out_ctl) + call read_real_ctl_type(c_buf, hd_delta_t_tracer, & + & tracer_ctls%delta_t_tracer_out_ctl) + end do + tracer_ctls%i_tracers_control = 1 +! + end subroutine read_tracer_controls +! +! --------------------------------------------------------------------- +! + subroutine write_tracer_controls(id_control, tracer_ctls, level) +! + use t_read_control_elements + use ctl_file_fieldlines_IO + use write_control_elements + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + type(tracers_control), intent(in) :: tracer_ctls + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(tracer_ctls%i_tracers_control .le. 0) return +! + maxlen = len_trim(hd_delta_t_tracer) + maxlen = max(maxlen, len_trim(hd_i_step_tracer)) +! + level = write_begin_flag_for_ctl(id_control, level, & + & tracer_ctls%block_name) + call write_real_ctl_type(id_control, level, maxlen, & + & tracer_ctls%delta_t_tracer_out_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & tracer_ctls%i_step_tracer_out_ctl) + call write_files_4_fline_ctl(id_control, hd_tracer_ctl, & + & tracer_ctls%tracer_controls, level) +! + level = write_end_flag_for_ctl(id_control, level, & + & tracer_ctls%block_name) +! + end subroutine write_tracer_controls +! +! --------------------------------------------------------------------- +! + subroutine init_tracers_ctl_label(hd_block, tracer_ctls) +! + use ctl_file_fieldlines_IO +! + character(len=kchara), intent(in) :: hd_block + type(tracers_control), intent(inout) :: tracer_ctls +! +! + tracer_ctls%block_name = trim(hd_block) + call init_fline_ctl_struct(hd_tracer_ctl, & + & tracer_ctls%tracer_controls) +! + call init_int_ctl_item_label(hd_i_step_tracer, & + & tracer_ctls%i_step_tracer_out_ctl) + call init_real_ctl_item_label(hd_delta_t_tracer, & + & tracer_ctls%delta_t_tracer_out_ctl) +! + end subroutine init_tracers_ctl_label +! +! --------------------------------------------------------------------- +! + subroutine tracer_step_ctls_to_time_ctl(tracer_ctls, tctl) +! + use t_ctl_data_4_time_steps +! + type(tracers_control), intent(in) :: tracer_ctls + type(time_data_control), intent(inout) :: tctl +! + if(tracer_ctls%i_step_tracer_out_ctl%iflag .gt. 0) then + call copy_integer_ctl(tracer_ctls%i_step_tracer_out_ctl, & + & tctl%i_step_tracer_output_ctl) + end if + if(tracer_ctls%delta_t_tracer_out_ctl%iflag .gt. 0) then + call copy_real_ctl(tracer_ctls%delta_t_tracer_out_ctl, & + & tctl%delta_t_tracer_output_ctl) + end if +! + end subroutine tracer_step_ctls_to_time_ctl +! +! --------------------------------------------------------------------- +! + end module t_control_data_tracers diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_control_params_4_fline.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_control_params_4_fline.f90 new file mode 100644 index 00000000..05aa7bc6 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_control_params_4_fline.f90 @@ -0,0 +1,238 @@ +!>@file t_control_params_4_fline.f90 +!!@brief module t_control_params_4_fline +!! +!!@date Programmed by H.Matsui in Aug. 2011 +! +!>@brief control parameters for each field line +!! +!!@verbatim +!! subroutine alloc_fline_starts_ctl(fln_prm) +!! subroutine alloc_iflag_fline_used_ele(ele, fln_prm) +!! type(element_data), intent(in) :: ele +!! type(fieldline_paramter), intent(inout) :: fln_prm +!! +!! subroutine dealloc_fline_starts_ctl(fln_prm) +!! subroutine dealloc_iflag_fline_used_ele(fln_prm) +!! type(fieldline_paramter), intent(inout) :: fln_prm +!! +!! subroutine check_control_params_fline(fln_prm) +!! type(fieldline_paramter), intent(in) :: fln_prm +!!@endverbatim +! + module t_control_params_4_fline +! + use m_precision + use t_file_IO_parameter + use t_ctl_params_viz_fields +! + implicit none +! +! + integer(kind = kint), parameter :: id_fline_data_code = 11 + character(len=kchara), parameter & + & :: default_tracer_prefix = 'tracer' +! +! integer(kind = kint) :: num_fline +! + type fieldline_paramter +!> File parameters for field line data file + type(field_IO_params) :: fline_file_IO +!> File parameters for tracer restart file + type(field_IO_params) :: fline_rst_IO +! +!> flag to use MPI_Bcast for data communication + logical :: flag_use_broadcast +! +!> Area of seed point + integer(kind = kint) :: id_fline_seed_type = 0 +!> Direction of field line tracing + integer(kind = kint) :: id_fline_direction = 0 +!> Distoribution of seed point + integer(kind = kint) :: id_seed_distribution = 0 +! +!> Surface group ID for seed points + integer(kind = kint) :: igrp_start_fline_surf_grp = 0 +! +!> Element group ID for seed points + integer(kind = kint) :: igrp_start_fline_ele_grp = 0 +!> field ID to find reference density for seed points + integer(kind = kint) :: ifield_4_density = 0 +!> field ID to find reference component for seed points + integer(kind = kint) :: icomp_4_density = 0 +! +!> Element group ID for seed points + integer(kind = kint) :: id_tracer_for_seed = 0 +! +!> Maximum step length for line tracing + integer(kind = kint) :: max_line_stepping = 1000 +!> Maximum trace length for line tracing + real(kind = kreal) :: max_trace_length = 1.0d30 +! +!> start address for of field data for fieldline + integer(kind = kint) :: iphys_4_fline = 0 +! +!> control parameter for vizulization field output + type(ctl_params_viz_fields) :: fline_fields +! +! +!> Number of element group to use in fieldline + integer(kind = kint) :: nele_grp_area_fline = 0 +!> Element group list to use in fieldline + integer(kind = kint), allocatable :: id_ele_grp_area_fline(:) +!> Element flag to use in fieldline + integer(kind = kint), allocatable :: iflag_fline_used_ele(:) +! +!> number of seed points + integer(kind = kint) :: num_each_field_line = 0 +!> local surface ID for seed points + integer(kind = kint), allocatable :: id_surf_start_fline(:,:) +!> global surface ID for seed points + integer(kind = kint), allocatable & + & :: id_gl_surf_start_fline(:,:) + +!> Position list of seed point + real(kind = kreal), allocatable :: xx_surf_start_fline(:,:) + end type fieldline_paramter +! +! + integer(kind = kint), parameter :: iflag_surface_group = 0 + integer(kind = kint), parameter :: iflag_surface_list = 1 + integer(kind = kint), parameter :: iflag_position_list = 2 + integer(kind = kint), parameter :: iflag_spray_in_domain = 3 + integer(kind = kint), parameter :: iflag_read_reastart = 10 + integer(kind = kint), parameter :: iflag_tracer_seeds = 20 +! +! + integer(kind = kint), parameter :: iflag_backward_trace = -1 + integer(kind = kint), parameter :: iflag_both_trace = 0 + integer(kind = kint), parameter :: iflag_forward_trace = 1 +! + integer(kind = kint), parameter :: iflag_random_by_amp = 0 + integer(kind = kint), parameter :: iflag_random_by_area = 1 + integer(kind = kint), parameter :: iflag_no_random = 2 +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_fline_starts_ctl(fln_prm) +! + type(fieldline_paramter), intent(inout) :: fln_prm +! + integer(kind = kint) :: num +! +! + num = fln_prm%nele_grp_area_fline + allocate(fln_prm%id_ele_grp_area_fline(num)) + if(num .gt. 0) fln_prm%id_ele_grp_area_fline = 0 +! + num = fln_prm%num_each_field_line + allocate(fln_prm%id_surf_start_fline(2,num)) + allocate(fln_prm%id_gl_surf_start_fline(2,num)) +! + allocate(fln_prm%xx_surf_start_fline(3,num)) +! + if(num .gt. 0) then + fln_prm%id_surf_start_fline(1:2,1:num) = 0 + fln_prm%id_gl_surf_start_fline(1:2,1:num) = 0 + fln_prm%xx_surf_start_fline(1:3,1:num) = 0.0d0 + end if +! + end subroutine alloc_fline_starts_ctl +! +! --------------------------------------------------------------------- +! + subroutine alloc_iflag_fline_used_ele(ele, fln_prm) +! + use t_geometry_data +! + type(element_data), intent(in) :: ele + type(fieldline_paramter), intent(inout) :: fln_prm +! +! + allocate(fln_prm%iflag_fline_used_ele(ele%numele)) +! +!$omp parallel workshare + fln_prm%iflag_fline_used_ele = 0 +!$omp end parallel workshare +! + end subroutine alloc_iflag_fline_used_ele +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dealloc_fline_starts_ctl(fln_prm) +! + type(fieldline_paramter), intent(inout) :: fln_prm +! +! + call dealloc_ctl_params_viz_fields(fln_prm%fline_fields) +! + deallocate(fln_prm%id_ele_grp_area_fline) +! + deallocate(fln_prm%id_surf_start_fline) + deallocate(fln_prm%id_gl_surf_start_fline) + + deallocate(fln_prm%xx_surf_start_fline) +! + end subroutine dealloc_fline_starts_ctl +! +! --------------------------------------------------------------------- +! + subroutine dealloc_iflag_fline_used_ele(fln_prm) +! + type(fieldline_paramter), intent(inout) :: fln_prm +! +! + deallocate(fln_prm%iflag_fline_used_ele) +! + end subroutine dealloc_iflag_fline_used_ele +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine check_control_params_fline(fln_prm) +! + type(fieldline_paramter), intent(in) :: fln_prm +! + integer(kind = kint) :: i +! +! + write(*,*) 'fline_header: ', & + & trim(fln_prm%fline_file_IO%file_prefix) + write(*,*) 'file format: ', fln_prm%fline_file_IO%iflag_format + write(*,*) 'id_fline_direction: ', fln_prm%id_fline_direction + write(*,*) 'id_fline_seed_type: ', fln_prm%id_fline_seed_type + write(*,*) 'id_seed_distribution: ', & + & fln_prm%id_seed_distribution + write(*,*) 'max_line_stepping: ', fln_prm%max_line_stepping + write(*,*) 'max_trace_length: ', fln_prm%max_trace_length +! + write(*,*) 'nele_grp_area_fline: ', & + & fln_prm%nele_grp_area_fline +! + write(*,*) 'num_each_field_line: ', & + & fln_prm%num_each_field_line + if (fln_prm%id_fline_seed_type & + & .eq. iflag_surface_group) then + write(*,*) 'igrp_start_fline_surf_grp: ', & + & fln_prm%igrp_start_fline_surf_grp + else if(fln_prm%id_fline_seed_type & + & .eq. iflag_surface_list) then + do i = 1, fln_prm%num_each_field_line + write(*,*) i, fln_prm%id_gl_surf_start_fline(1:2,i) + end do + else if(fln_prm%id_fline_seed_type & + & .eq. iflag_position_list) then + do i = 1, fln_prm%num_each_field_line + write(*,*) i, fln_prm%xx_surf_start_fline(1:3,i) + end do + end if +! + end subroutine check_control_params_fline +! +! --------------------------------------------------------------------- +! + end module t_control_params_4_fline diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_ctl_data_field_line.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_ctl_data_field_line.f90 new file mode 100644 index 00000000..d3b784fd --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_ctl_data_field_line.f90 @@ -0,0 +1,302 @@ +!>@file t_ctl_data_field_line.f90 +!!@brief module t_ctl_data_field_line +!! +!!@date Programmed by H.Matsui in May, 2006 +! +!>@brief control data for each field line +!! +!!@verbatim +!! subroutine deallocate_cont_dat_fline(fln) +!! subroutine reset_fline_control_flags(fln) +!! type(fline_ctl), intent(inout) :: fln +!! +!! subroutine dup_control_4_fline(org_fln, new_fln) +!! type(fline_ctl), intent(in) :: org_fln +!! type(fline_ctl), intent(inout) :: new_fln +!! +!! subroutine add_field_4_fline_to_fld_ctl & +!! & (fline_ctl_struct, field_ctl) +!! type(fline_ctl), intent(in) :: fline_ctl_struct +!! type(ctl_array_c3), intent(inout) :: field_ctl +!! --------------------------------------------------------------------- +!! example of control for Kemo's field line +!! +!! begin fieldline +!! fline_file_prefix 'fline' +!! fline_output_format ucd +!! +!! array chosen_ele_grp_ctl +!! chosen_ele_grp_ctl outer_core end +!! end array chosen_ele_grp_ctl +!! +!! starting_type: position_list, surface_list, +!! element_group, or surface_group +!! line_direction_ctl forward +!! max_line_stepping_ctl 1000 +!! max_trace_length_ctl 20.0 +!! starting_type_ctl position_list +!! +!! seed_surface_grp_ctl icb_surf +!! seed_element_grp_ctl outer_core +!! num_fieldline_ctl 10 +!! +!! seed_reference_field_ctl magnetic_field +!! seed_reference_component_ctl radial +!! +!! selection_type_ctl: amplitude, area_size +!! selection_type_ctl amplitude +!! +!! begin seed_lists_ctl +!! array seed_point_ctl +!! seed_point_ctl 0.0 0.0 0.0 +!! end array seed_point_ctl +!! +!! array seed_geological_ctl +!! seed_geological_ctl 1.03 36.5 140.0 +!! end array seed_geological_ctl +!! +!! array seed_spherical_ctl +!! seed_geological_ctl 0.75 -1.047 3.141592 +!! end array seed_spherical_ctl +!! +!! array starting_gl_surface_id 10 +!! starting_gl_surface_id 12 3 +!! end array +!! end seed_lists_ctl +!! +!! field type: +!! scalar, vector, sym_tensor, asym_tensor +!! spherical_vector, spherical_sym_tensor +!! cylindrical_vector, cylindrical_sym_tensor +!! norm, +!! +!! field_line_field_ctl magnetic_field end +!! array output_field +!! output_field velocity vector +!! output_field magnetic_field radial +!! end array output_field +!! +!! end fieldline +!! --------------------------------------------------------------------- +!!@endverbatim +! + module t_ctl_data_field_line +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_array_integer + use t_control_array_character + use t_control_array_real + use t_control_array_character2 + use t_fline_seeds_list_ctl + use skip_comment_f +! + implicit none +! +! + type fline_ctl +!> Control block name + character(len = kchara) :: block_name = 'fieldline' +! + type(read_character_item) :: fline_file_head_ctl + type(read_character_item) :: fline_output_type_ctl +! + type(read_character_item) :: fline_rst_prefix_ctl + type(read_character_item) :: fline_rst_format_ctl +! + type(read_character_item) :: fline_field_ctl + type(read_character_item) :: fline_color_field_ctl + type(read_character_item) :: fline_color_comp_ctl +!> Structure for list of output field +!!@n field_output_ctl%c1_tbl: Name of field +!!@n field_output_ctl%c2_tbl: Name of component + type(ctl_array_c2) :: fline_field_output_ctl +! +!> Structure for element group to draw field line +!!@n fline_area_grp_ctl%c_tbl: element group to draw field line + type(ctl_array_chara) :: fline_area_grp_ctl +! + type(read_character_item) :: fline_comm_mode_ctl +! + type(read_character_item) :: starting_type_ctl + type(read_character_item) :: selection_type_ctl + type(read_character_item) :: line_direction_ctl +! + type(read_character_item) :: seed_surf_grp_ctl + type(read_character_item) :: seed_ele_grp_ctl +! + type(read_integer_item) :: num_fieldline_ctl + type(read_integer_item) :: max_line_stepping_ctl + type(read_real_item) :: max_trace_length_ctl +! + type(read_character_item) :: seed_ref_field_ctl + type(read_character_item) :: seed_ref_comp_ctl +! + type(read_character_item) :: seed_file_prefix_ctl +! + type(fline_seeds_list_ctl) :: seeds_ctl +! + integer (kind=kint) :: i_vr_fline_ctl = 0 + end type fline_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine deallocate_cont_dat_fline(fln) +! + type(fline_ctl), intent(inout) :: fln +! +! + call dealloc_fline_seeds_list_ctl(fln%seeds_ctl) +! + call dealloc_control_array_chara(fln%fline_area_grp_ctl) +! + call reset_fline_control_flags(fln) +! + end subroutine deallocate_cont_dat_fline +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine reset_fline_control_flags(fln) +! + type(fline_ctl), intent(inout) :: fln +! +! + call reset_fline_seeds_list_ctl(fln%seeds_ctl) + fln%fline_area_grp_ctl%num = 0 +! + fln%fline_file_head_ctl%iflag = 0 + fln%fline_output_type_ctl%iflag = 0 +! + fln%fline_rst_prefix_ctl%iflag = 0 + fln%fline_rst_format_ctl%iflag = 0 +! + fln%num_fieldline_ctl%iflag = 0 + fln%max_line_stepping_ctl%iflag = 0 + fln%max_trace_length_ctl%iflag = 0 + fln%fline_comm_mode_ctl%iflag = 0 + fln%starting_type_ctl%iflag = 0 + fln%selection_type_ctl%iflag = 0 + fln%seed_surf_grp_ctl%iflag = 0 + fln%seed_ele_grp_ctl%iflag = 0 + fln%seed_ref_field_ctl%iflag = 0 + fln%seed_ref_comp_ctl%iflag = 0 + fln%seed_file_prefix_ctl%iflag = 0 +! + fln%i_vr_fline_ctl = 0 +! + fln%fline_area_grp_ctl%icou = 0 + fln%fline_field_output_ctl%icou = 0 +! + fln%fline_color_field_ctl%iflag = 0 + fln%fline_color_comp_ctl%iflag = 0 + fln%fline_field_ctl%iflag = 0 + fln%line_direction_ctl%iflag = 0 +! + end subroutine reset_fline_control_flags +! +! --------------------------------------------------------------------- +! + subroutine dup_control_4_fline(org_fln, new_fln) +! + type(fline_ctl), intent(in) :: org_fln + type(fline_ctl), intent(inout) :: new_fln +! +! + call copy_chara_ctl(org_fln%fline_file_head_ctl, & + & new_fln%fline_file_head_ctl) + call copy_chara_ctl(org_fln%fline_output_type_ctl, & + & new_fln%fline_output_type_ctl) +! + call copy_chara_ctl(org_fln%fline_rst_prefix_ctl, & + & new_fln%fline_rst_prefix_ctl) + call copy_chara_ctl(org_fln%fline_rst_format_ctl, & + & new_fln%fline_rst_format_ctl) +! + call copy_chara_ctl(org_fln%fline_field_ctl, & + & new_fln%fline_field_ctl) + call copy_chara_ctl(org_fln%fline_color_field_ctl, & + & new_fln%fline_color_field_ctl) + call copy_chara_ctl(org_fln%fline_color_comp_ctl, & + & new_fln%fline_color_comp_ctl) +! + call copy_chara_ctl(org_fln%fline_comm_mode_ctl, & + & new_fln%fline_comm_mode_ctl) +! + call copy_chara_ctl(org_fln%starting_type_ctl, & + & new_fln%starting_type_ctl) + call copy_chara_ctl(org_fln%selection_type_ctl, & + & new_fln%selection_type_ctl) + call copy_chara_ctl(org_fln%line_direction_ctl, & + & new_fln%line_direction_ctl) +! + call copy_chara_ctl(org_fln%seed_surf_grp_ctl, & + & new_fln%seed_surf_grp_ctl) + call copy_chara_ctl(org_fln%seed_ele_grp_ctl, & + & new_fln%seed_ele_grp_ctl) +! + call copy_chara_ctl(org_fln%seed_ref_field_ctl, & + & new_fln%seed_ref_field_ctl) + call copy_chara_ctl(org_fln%seed_ref_comp_ctl, & + & new_fln%seed_ref_comp_ctl) +! + call copy_chara_ctl(org_fln%seed_file_prefix_ctl, & + & new_fln%seed_file_prefix_ctl) +! + call copy_integer_ctl(org_fln%num_fieldline_ctl, & + & new_fln%num_fieldline_ctl) + call copy_integer_ctl(org_fln%max_line_stepping_ctl, & + & new_fln%max_line_stepping_ctl) + call copy_real_ctl(org_fln%max_trace_length_ctl, & + & new_fln%max_trace_length_ctl) +! + call dup_control_array_c1(org_fln%fline_area_grp_ctl, & + & new_fln%fline_area_grp_ctl) +! + call dup_fline_seeds_list_ctl(org_fln%seeds_ctl, & + & new_fln%seeds_ctl) +! + call dup_control_array_c2(org_fln%fline_field_output_ctl, & + & new_fln%fline_field_output_ctl) +! + new_fln%block_name = org_fln%block_name + new_fln%i_vr_fline_ctl = org_fln%i_vr_fline_ctl +! + end subroutine dup_control_4_fline +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine add_field_4_fline_to_fld_ctl & + & (fline_ctl_struct, field_ctl) +! + use t_control_array_character3 +! + use add_nodal_fields_ctl +! + type(fline_ctl), intent(in) :: fline_ctl_struct + type(ctl_array_c3), intent(inout) :: field_ctl +! +! + if(fline_ctl_struct%fline_field_ctl%iflag .gt. 0) then + call add_viz_name_ctl & + & (fline_ctl_struct%fline_field_ctl%charavalue, field_ctl) + end if +! + if(fline_ctl_struct%fline_color_field_ctl%iflag .gt. 0) then + call add_viz_name_ctl & + & (fline_ctl_struct%fline_color_field_ctl%charavalue, & + & field_ctl) + end if +! + end subroutine add_field_4_fline_to_fld_ctl +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_field_line diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_fieldline.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_fieldline.f90 new file mode 100644 index 00000000..9142f4ee --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_fieldline.f90 @@ -0,0 +1,271 @@ +!>@file t_fieldline.f90 +!!@brief module t_fieldline +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Main routine for field line module +!! +!!@verbatim +!! subroutine FLINE_initialize(increment_fline, geofem, nod_fld, & +!! & tracer, fline_ctls, fline) +!! subroutine FLINE_visualize(istep_fline, elps_fline, time_d, & +!! & geofem, para_surf, nod_fld, tracer, fline, m_SR) +!! subroutine FLINE_finalize(fline) +!! type(time_data), intent(in) :: time_d +!! type(mesh_data), intent(in) :: geofem +!! type(paralell_surface_indices), intent(in) :: para_surf +!! type(next_nod_ele_table), intent(in) :: next_tbl +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_controls), intent(inout) :: fline_ctls +!! type(fieldline_module), intent(inout) :: fline +!!@endverbatim +! + module t_fieldline +! + use m_precision + use m_machine_parameter + use m_geometry_constants + use m_work_time +! + use t_time_data + use t_mesh_data + use t_phys_data + use t_parallel_surface_indices + use t_control_params_4_fline + use t_source_of_filed_line + use t_trace_data_send_recv + use t_broadcast_trace_data + use t_tracing_data + use t_local_fline + use t_ucd_data + use t_particle_trace +! + implicit none +! + type fieldline_module + integer(kind = kint) :: num_fline +! + type(fieldline_paramter), allocatable :: fln_prm(:) +! + type(each_fieldline_source), allocatable :: fln_src(:) + type(each_fieldline_trace), allocatable :: fln_tce(:) + type(local_fieldline), allocatable :: fline_lc(:) + type(broadcast_trace_data), allocatable :: fln_bcast(:) + type(trace_data_send_recv), allocatable :: fln_SR(:) +! + type(ucd_data) :: fline_ucd + end type fieldline_module +! + private :: set_fline_controls, s_const_field_lines +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine FLINE_initialize(increment_fline, geofem, nod_fld, & + & tracer, fline_ctls, fline) +! + use calypso_mpi + use calypso_mpi_int + use m_connect_hexa_2_tetra + use t_control_data_flines + use multi_tracer_fieldline +! + integer(kind = kint), intent(in) :: increment_fline + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_controls), intent(inout) :: fline_ctls + type(fieldline_module), intent(inout) :: fline +! +! + fline%num_fline = fline_ctls%num_fline_ctl + if(increment_fline .le. 0) fline%num_fline = 0 + if(fline%num_fline .le. 0) return +! + call alloc_FLINE_modules(fline) +! + call set_fline_controls & + & (geofem%mesh, geofem%group, nod_fld, tracer, & + & fline%num_fline, fline_ctls, fline%fln_prm) + call dealloc_fline_ctl_struct(fline_ctls) +! + call alloc_each_FLINE_data & + & (fline%num_fline, fline%fln_prm, fline%fln_src, fline%fln_tce, & + & fline%fline_lc, fline%fln_SR, fline%fln_bcast) + call set_fixed_FLINE_seed_points(geofem%mesh, fline%num_fline, & + & fline%fln_prm, fline%fln_src) +! + end subroutine FLINE_initialize +! +! --------------------------------------------------------------------- +! + subroutine alloc_FLINE_modules(fline) +! + type(fieldline_module), intent(inout) :: fline +! + allocate(fline%fln_prm(fline%num_fline)) + allocate(fline%fln_src(fline%num_fline)) + allocate(fline%fln_tce(fline%num_fline)) + allocate(fline%fln_SR(fline%num_fline)) + allocate(fline%fln_bcast(fline%num_fline)) + allocate(fline%fline_lc(fline%num_fline)) +! + end subroutine alloc_FLINE_modules +! +! --------------------------------------------------------------------- +! + subroutine FLINE_visualize(istep_fline, elps_fline, time_d, & + & geofem, para_surf, nod_fld, tracer, fline, m_SR) +! + use multi_tracer_fieldline + use const_field_lines + use multi_tracer_file_IO + use t_mesh_SR +! +! + integer(kind = kint), intent(in) :: istep_fline + type(elapsed_lables), intent(in) :: elps_fline + type(time_data), intent(in) :: time_d + type(mesh_data), intent(in) :: geofem + type(paralell_surface_indices), intent(in) :: para_surf + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer +! + type(fieldline_module), intent(inout) :: fline + type(mesh_SR), intent(inout) :: m_SR +! +! + if (fline%num_fline.le.0 .or. istep_fline.le.0) return +! + call s_const_field_lines(elps_fline, geofem%mesh, geofem%group, & + & para_surf, nod_fld, tracer, fline%num_fline, & + & fline%fln_prm, fline%fln_src, fline%fln_tce, & + & fline%fln_SR, fline%fln_bcast, fline%fline_lc, m_SR) +! + if(elps_fline%flag_elapsed) & + & call start_elapsed_time(elps_fline%ist_elapsed+4) + call output_field_lines(istep_fline, time_d, fline%num_fline, & + & fline%fln_prm, fline%fline_lc) + if(elps_fline%flag_elapsed) & + & call end_elapsed_time(elps_fline%ist_elapsed+4) +! + end subroutine FLINE_visualize +! +! --------------------------------------------------------------------- +! + subroutine FLINE_finalize(fline) +! + use multi_tracer_fieldline +! + type(fieldline_module), intent(inout) :: fline +! +! + if (fline%num_fline .le. 0) return +! +! + call dealloc_each_FLINE_data(fline%num_fline, fline%fln_prm, & + & fline%fln_src, fline%fln_tce, fline%fline_lc, & + & fline%fln_SR, fline%fln_bcast) + deallocate(fline%fln_src, fline%fline_lc, fline%fln_bcast) + deallocate(fline%fln_tce, fline%fln_prm, fline%fln_SR) +! + end subroutine FLINE_finalize +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_fline_controls(mesh, group, nod_fld, tracer, & + & num_fline, fline_ctls, fln_prm) +! + use t_control_data_flines + use set_fline_control + + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer +! + integer(kind = kint), intent(in) ::num_fline + type(fieldline_controls), intent(inout) :: fline_ctls + type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) +! + integer(kind = kint) :: i_fln +! + do i_fln = 1, num_fline + call s_set_fline_control(mesh, group, nod_fld, & + & tracer%num_trace, tracer%fln_prm, & + & fline_ctls%fline_ctl_struct(i_fln), fln_prm(i_fln)) + end do +! + end subroutine set_fline_controls +! +! --------------------------------------------------------------------- +! + subroutine s_const_field_lines & + & (elps_fline, mesh, group, para_surf, nod_fld, tracer, & + & num_fline, fln_prm, fln_src, fln_tce, & + & fln_SR, fln_bcast, fline_lc, m_SR) +! + use const_field_lines + use set_fline_seed_from_tracer + use set_fline_seeds_from_list + use set_fields_for_fieldline +! + type(elapsed_lables), intent(in) :: elps_fline + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(paralell_surface_indices), intent(in) :: para_surf + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer +! + integer(kind = kint), intent(in) :: num_fline + type(fieldline_paramter), intent(inout) :: fln_prm(num_fline) + type(each_fieldline_source), intent(inout) :: fln_src(num_fline) + type(each_fieldline_trace), intent(inout) :: fln_tce(num_fline) + type(local_fieldline), intent(inout) :: fline_lc(num_fline) + type(trace_data_send_recv), intent(inout) :: fln_SR(num_fline) + type(broadcast_trace_data), intent(inout) :: fln_bcast(num_fline) + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_fln +! + do i_fln = 1, num_fline + if(elps_fline%flag_elapsed) & + & call start_elapsed_time(elps_fline%ist_elapsed+1) + if(fln_prm(i_fln)%id_fline_seed_type & + & .eq. iflag_tracer_seeds) then + call const_fline_seed_from_tracer(mesh%node, mesh%ele, & + & nod_fld, tracer%num_trace, tracer%fln_tce, & + & fln_prm(i_fln), fln_tce(i_fln)) + else if(fln_prm(i_fln)%id_fline_seed_type & + & .eq. iflag_position_list) then + call count_FLINE_seed_from_list & + & (fln_prm(i_fln), fln_src(i_fln), fln_tce(i_fln)) + call set_FLINE_seed_field_from_list & + & (mesh%node, mesh%ele, nod_fld, & + & fln_prm(i_fln), fln_src(i_fln), fln_tce(i_fln)) + else + call s_set_fields_for_fieldline & + & (mesh, group, para_surf, nod_fld, & + & fln_prm(i_fln), fln_src(i_fln), fln_tce(i_fln)) + end if + if(elps_fline%flag_elapsed) & + & call end_elapsed_time(elps_fline%ist_elapsed+1) + call calypso_mpi_barrier() +! + call const_each_field_line(elps_fline, mesh, para_surf, & + & nod_fld, fln_prm(i_fln), fln_tce(i_fln), fln_SR(i_fln), & + & fln_bcast(i_fln), fline_lc(i_fln), m_SR) + call calypso_mpi_barrier() + end do +! + end subroutine s_const_field_lines +! +! --------------------------------------------------------------------- +! + end module t_fieldline diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_fline_seeds_ele_group.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_fline_seeds_ele_group.f90 new file mode 100644 index 00000000..64eef6ae --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_fline_seeds_ele_group.f90 @@ -0,0 +1,292 @@ +!>@file t_fline_seeds_ele_group.f90 +!!@brief module t_fline_seeds_ele_group +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Element group list to set seed points +!! +!!@verbatim +!! subroutine init_density_on_seed_ele(node, ele, ele_grp, nod_fld,& +!! & fln_prm, seed_ele_grp) +!! subroutine dealloc_density_on_seed_ele(seed_ele_grp) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(group_data), intent(in) :: ele_grp +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_paramter), intent(inout) :: fln_prm +!! type(fieldline_seeds_ele_group), intent(inout) :: seed_ele_grp +!!@endverbatim +! + module t_fline_seeds_ele_group +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter + use m_geometry_constants +! + use t_phys_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_control_params_4_fline + use t_source_of_filed_line + use t_tracing_data +! + implicit none +! + type fieldline_seeds_ele_group + integer(kind = kint) :: nele_seed = 0 + integer(kind = kint), allocatable :: iele_grp_seed_item(:) + real(kind = kreal), allocatable :: density_seed(:) +! + real(kind = kreal), allocatable :: seed_field(:) + end type fieldline_seeds_ele_group +! + type(fieldline_seeds_ele_group), save :: seed_ele_grp +! + private :: alloc_local_start_grp_item + private :: count_nele_for_seeds, set_iele_for_seeds +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine init_density_on_seed_ele(node, ele, ele_grp, nod_fld, & + & fln_prm, seed_ele_grp) +! + use convert_components_4_viz +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(group_data), intent(in) :: ele_grp + type(phys_data), intent(in) :: nod_fld +! + type(fieldline_paramter), intent(in) :: fln_prm + type(fieldline_seeds_ele_group), intent(inout) :: seed_ele_grp +! + integer(kind = kint) :: num_ele, i_field, ist_fld, num_comp +! +! + num_ele = count_nele_for_seeds(ele, ele_grp, & + & fln_prm%igrp_start_fline_ele_grp) + call alloc_local_start_grp_item(num_ele, seed_ele_grp) +! + call set_iele_for_seeds & + & (ele, ele_grp, fln_prm%igrp_start_fline_ele_grp, & + & seed_ele_grp%nele_seed, seed_ele_grp%iele_grp_seed_item) +! + if( fln_prm%id_seed_distribution .eq. iflag_random_by_area & + & .or. fln_prm%id_seed_distribution .eq. iflag_no_random) then + if(iflag_debug .gt. 0) write(*,*) 'cal_volume_for_1egrp' + call cal_volume_for_1egrp(ele, & + & seed_ele_grp%nele_seed, seed_ele_grp%iele_grp_seed_item, & + & seed_ele_grp%density_seed) + else + i_field = fln_prm%ifield_4_density + ist_fld = nod_fld%istack_component(i_field-1) + num_comp = nod_fld%istack_component(i_field) - ist_fld + call alloc_density_for_seed(node%numnod, seed_ele_grp) + call convert_comps_4_viz & + & (node%numnod, node%istack_nod_smp, node%xx, node%rr, & + & node%a_r, node%ss, node%a_s, ione, num_comp, & + & fln_prm%icomp_4_density, nod_fld%d_fld(1,ist_fld+1), & + & seed_ele_grp%seed_field) +! + if(iflag_debug .gt. 0) write(*,*) 'cal_density_for_1egrp' + call cal_density_for_1egrp(ele, & + & seed_ele_grp%nele_seed, seed_ele_grp%iele_grp_seed_item, & + & nod_fld%n_point, seed_ele_grp%seed_field, & + & seed_ele_grp%density_seed) + call dealloc_density_for_seed(seed_ele_grp) + end if +! + end subroutine init_density_on_seed_ele +! +! --------------------------------------------------------------------- +! + subroutine dealloc_density_on_seed_ele(seed_ele_grp) +! + type(fieldline_seeds_ele_group), intent(inout) :: seed_ele_grp +! +! + deallocate(seed_ele_grp%iele_grp_seed_item) + deallocate(seed_ele_grp%density_seed) +! + end subroutine dealloc_density_on_seed_ele +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine alloc_local_start_grp_item(num, seed_ele_grp) +! + integer(kind = kint), intent(in) :: num + type(fieldline_seeds_ele_group), intent(inout) :: seed_ele_grp +! +! + seed_ele_grp%nele_seed = num + allocate(seed_ele_grp%iele_grp_seed_item(num)) + allocate(seed_ele_grp%density_seed(num)) + if(num .gt. 0) seed_ele_grp%iele_grp_seed_item = 0 + if(num .gt. 0) seed_ele_grp%density_seed = 0.0d0 +! + end subroutine alloc_local_start_grp_item +! +! --------------------------------------------------------------------- +! + subroutine alloc_density_for_seed(numnod, seed_ele_grp) +! + integer(kind = kint), intent(in) :: numnod + type(fieldline_seeds_ele_group), intent(inout) :: seed_ele_grp +! + allocate(seed_ele_grp%seed_field(numnod)) + if(numnod .gt. 0) seed_ele_grp%seed_field = 0 +! + end subroutine alloc_density_for_seed +! +! --------------------------------------------------------------------- +! + subroutine dealloc_density_for_seed(seed_ele_grp) + type(fieldline_seeds_ele_group), intent(inout) :: seed_ele_grp +! + deallocate(seed_ele_grp%seed_field) +! + end subroutine dealloc_density_for_seed +! +! --------------------------------------------------------------------- +! + integer(kind = kint) function count_nele_for_seeds(ele, ele_grp, & + & igrp_seed) +! + integer(kind = kint), intent(in) :: igrp_seed +! + type(element_data), intent(in) :: ele + type(group_data), intent(in) :: ele_grp +! + integer(kind = kint) :: inum, iele, icou, ist, ied +! +! + icou = 0 + ist = ele_grp%istack_grp(igrp_seed-1) + 1 + ied = ele_grp%istack_grp(igrp_seed) + do inum = ist, ied + iele = ele_grp%item_grp(inum) + if(ele%interior_ele(iele) .ne. izero) icou = icou + 1 + end do +! + count_nele_for_seeds = icou +! + end function count_nele_for_seeds +! +! --------------------------------------------------------------------- +! + subroutine set_iele_for_seeds(ele, ele_grp, igrp_seed, & + & nele_seed, iele_grp_seed_item) +! + type(element_data), intent(in) :: ele + type(group_data), intent(in) :: ele_grp + integer(kind = kint), intent(in) :: igrp_seed +! + integer(kind = kint), intent(in) :: nele_seed + integer(kind = kint), intent(inout) & + & :: iele_grp_seed_item(nele_seed) +! + integer(kind = kint) :: icou, inum, iele, ist, ied +! +! + icou = 0 + ist = ele_grp%istack_grp(igrp_seed-1) + 1 + ied = ele_grp%istack_grp(igrp_seed) + do inum = ist, ied + iele = ele_grp%item_grp(inum) + if(ele%interior_ele(iele) .ne. izero) then + icou = icou + 1 + iele_grp_seed_item(inum) = ele_grp%item_grp(iele) + end if + end do +! + end subroutine set_iele_for_seeds +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine cal_density_for_1egrp(ele, num_egrp, iele_grp, & + & n_point, d_nod, density) +! + type(element_data), intent(in) :: ele + integer(kind = kint), intent(in) :: num_egrp + integer(kind = kint), intent(in) :: iele_grp(num_egrp) + integer(kind = kint), intent(in) :: n_point + real(kind = kreal), intent(in) :: d_nod(n_point) +! + real(kind = kreal), intent(inout) :: density(num_egrp) +! + integer (kind = kint) :: iele, inum + integer (kind = kint) :: i1, i2, i3, i4, i5, i6, i7, i8 + real(kind = kreal) :: d_ele +! +! +!$omp parallel workshare + density(1:num_egrp) = 0.0d0 +!$omp end parallel workshare +! +!$omp parallel do & +!$omp& private(inum,iele,i1,i2,i3,i4,i5,i6,i7,i8,d_ele) +!$cdir nodep + do inum = 1, num_egrp + iele = iele_grp(inum) +! + i1 = ele%ie(iele, 1) + i2 = ele%ie(iele, 2) + i3 = ele%ie(iele, 3) + i4 = ele%ie(iele, 4) + i5 = ele%ie(iele, 5) + i6 = ele%ie(iele, 6) + i7 = ele%ie(iele, 7) + i8 = ele%ie(iele, 8) +! + d_ele = r125 * (d_nod(i1) + d_nod(i2) + d_nod(i3) + d_nod(i4) & + & + d_nod(i5) + d_nod(i7) + d_nod(i7) + d_nod(i8)) +! + density(inum) = density(inum) & + & + abs(d_ele) * ele%volume_ele(iele) & + & * dble(ele%interior_ele(iele)) + end do +!$omp end parallel do +! + end subroutine cal_density_for_1egrp +! +! --------------------------------------------------------------------- +! + subroutine cal_volume_for_1egrp(ele, num_egrp, iele_grp, density) +! + type(element_data), intent(in) :: ele + integer(kind = kint), intent(in) :: num_egrp + integer(kind = kint), intent(in) :: iele_grp(num_egrp) +! + real(kind = kreal), intent(inout) :: density(num_egrp) +! + integer (kind = kint) :: inum, iele +! +! +!$omp parallel workshare + density(1:num_egrp) = 0.0d0 +!$omp end parallel workshare +! +!$omp parallel do private(inum,iele) + do inum = 1, num_egrp + iele = iele_grp(inum) + density(inum) = density(inum) + ele%volume_ele(iele) & + & * dble(ele%interior_ele(iele)) + end do +!$omp end parallel do +! + end subroutine cal_volume_for_1egrp +! +! --------------------------------------------------------------------- +! + end module t_fline_seeds_ele_group diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_fline_seeds_list_ctl.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_fline_seeds_list_ctl.f90 new file mode 100644 index 00000000..f10e649d --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_fline_seeds_list_ctl.f90 @@ -0,0 +1,256 @@ +!>@file t_fline_seeds_list_ctl.f90 +!!@brief module t_fline_seeds_list_ctl +!! +!!@date Programmed by H.Matsui in May, 2006 +! +!>@brief control data for each field line +!! +!!@verbatim +!! subroutine init_fline_seeds_list_ctl(hd_block, fln_seeds) +!! subroutine read_fline_seeds_list_ctl(id_control, hd_block, & +!! & fln_seeds, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(fline_seeds_list_ctl), intent(inout) :: fln_seeds +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_fline_seeds_list_ctl(id_control, fln_seeds, & +!! & level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(fline_seeds_list_ctl), intent(in) :: fln_seeds +!! integer(kind = kint), intent(inout) :: level +!! +!! subroutine dealloc_fline_seeds_list_ctl(fln_seeds) +!! subroutine reset_fline_seeds_list_ctl(fln_seeds) +!! type(fline_seeds_list_ctl), intent(inout) :: fln_seeds +!! subroutine dup_fline_seeds_list_ctl(org_fln_seeds, & +!! & new_fln_seeds) +!! type(fline_seeds_list_ctl), intent(in) :: org_fln_seeds +!! type(fline_seeds_list_ctl), intent(inout) :: new_fln_seeds +!! --------------------------------------------------------------------- +!! example of control for Kemo's field line +!! +!! begin seed_lists_ctl +!! array seed_point_ctl +!! seed_point_ctl 0.0 0.0 0.0 +!! end array seed_point_ctl +!! +!! array seed_geological_ctl +!! seed_geological_ctl 1.03 36.5 140.0 +!! end array seed_geological_ctl +!! +!! array seed_spherical_ctl +!! seed_geological_ctl 0.75 -1.047 3.141592 +!! end array seed_spherical_ctl +!! +!! array starting_gl_surface_id 10 +!! starting_gl_surface_id 12 3 +!! end array +!! end seed_lists_ctl +!! +!! --------------------------------------------------------------------- +!!@endverbatim +! + module t_fline_seeds_list_ctl +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_array_integer2 + use t_control_array_real3 + use calypso_mpi +! + implicit none +! +! + type fline_seeds_list_ctl +!> Control block name + character(len = kchara) :: block_name = 'seed_lists_ctl' +! +!> Structure for seed points +!!@n seed_point_ctl%vec1: X-component of seed points +!!@n seed_point_ctl%vec2: Y-component of seed points +!!@n seed_point_ctl%vec3: Z-component of seed points + type(ctl_array_r3) :: seed_point_ctl +!> Structure for seed points +!!@n seed_geological_ctl%vec1: r-component of seed points +!!@n seed_geological_ctl%vec2: latitude of seed points in degree +!!@n seed_geological_ctl%vec3: longitude of seed points in degree + type(ctl_array_r3) :: seed_geological_ctl +!> Structure for seed points +!!@n seed_spherical_ctl%vec1: r-component of seed points +!!@n seed_spherical_ctl%vec2: theta-component of seed points +!!@n seed_spherical_ctl%vec3: phi-component of seed points + type(ctl_array_r3) :: seed_spherical_ctl +! +!> Structure for seed points on center of the surfaces +!!@n seed_surface_ctl%int1: element ID for seed points +!!@n seed_surface_ctl%int2: Surface ID for seed points + type(ctl_array_i2) :: seed_surface_ctl +! + integer (kind=kint) :: i_seeds_list_ctl = 0 + end type fline_seeds_list_ctl +! +! + character(len=kchara), parameter, private & + & :: hd_xx_start_point = 'seed_point_ctl' + character(len=kchara), parameter, private & + & :: hd_geo_start_point = 'seed_geological_ctl' + character(len=kchara), parameter, private & + & :: hd_rtp_start_point = 'seed_spherical_ctl' +! + character(len=kchara), parameter, private & + & :: hd_start_global_surf = 'starting_gl_surface_id' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_fline_seeds_list_ctl(id_control, hd_block, & + & fln_seeds, c_buf) +! + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(fline_seeds_list_ctl), intent(inout) :: fln_seeds + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return +! + if (fln_seeds%i_seeds_list_ctl.gt.0) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_control_array_r3(id_control, & + & hd_xx_start_point, fln_seeds%seed_point_ctl, c_buf) + call read_control_array_r3(id_control, & + & hd_geo_start_point, fln_seeds%seed_geological_ctl, c_buf) + call read_control_array_r3(id_control, & + & hd_rtp_start_point, fln_seeds%seed_spherical_ctl, c_buf) +! + call read_control_array_i2(id_control, & + & hd_start_global_surf, fln_seeds%seed_surface_ctl, c_buf) + end do + fln_seeds%i_seeds_list_ctl = 1 +! + end subroutine read_fline_seeds_list_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_fline_seeds_list_ctl(id_control, fln_seeds, & + & level) +! + use skip_comment_f + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + type(fline_seeds_list_ctl), intent(in) :: fln_seeds +! + integer(kind = kint), intent(inout) :: level +! +! + if(fln_seeds%i_seeds_list_ctl .le. 0) return +! + level = write_begin_flag_for_ctl(id_control, level, & + & fln_seeds%block_name) +! + call write_control_array_r3(id_control, level, & + & fln_seeds%seed_point_ctl) + call write_control_array_r3(id_control, level, & + & fln_seeds%seed_geological_ctl) + call write_control_array_r3(id_control, level, & + & fln_seeds%seed_spherical_ctl) + call write_control_array_i2 (id_control, level, & + & fln_seeds%seed_surface_ctl) +! + level = write_end_flag_for_ctl(id_control, level, & + & fln_seeds%block_name) +! + end subroutine write_fline_seeds_list_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_fline_seeds_list_ctl(hd_block, fln_seeds) +! + character(len=kchara), intent(in) :: hd_block + type(fline_seeds_list_ctl), intent(inout) :: fln_seeds +! +! + fln_seeds%block_name = hd_block +! + call init_r3_ctl_array_label & + & (hd_xx_start_point, fln_seeds%seed_point_ctl) + call init_r3_ctl_array_label & + & (hd_geo_start_point, fln_seeds%seed_geological_ctl) + call init_r3_ctl_array_label & + & (hd_rtp_start_point, fln_seeds%seed_spherical_ctl) +! + call init_int2_ctl_array_label & + & (hd_start_global_surf, fln_seeds%seed_surface_ctl) +! + end subroutine init_fline_seeds_list_ctl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dealloc_fline_seeds_list_ctl(fln_seeds) +! + type(fline_seeds_list_ctl), intent(inout) :: fln_seeds +! +! + call dealloc_control_array_i2(fln_seeds%seed_surface_ctl) + call dealloc_control_array_r3(fln_seeds%seed_point_ctl) + call dealloc_control_array_r3(fln_seeds%seed_geological_ctl) + call dealloc_control_array_r3(fln_seeds%seed_spherical_ctl) +! + end subroutine dealloc_fline_seeds_list_ctl +! +! --------------------------------------------------------------------- +! + subroutine reset_fline_seeds_list_ctl(fln_seeds) +! + type(fline_seeds_list_ctl), intent(inout) :: fln_seeds +! +! + fln_seeds%seed_point_ctl%icou = 0 + fln_seeds%seed_geological_ctl%icou = 0 + fln_seeds%seed_spherical_ctl%icou = 0 + fln_seeds%seed_surface_ctl%icou = 0 +! + end subroutine reset_fline_seeds_list_ctl +! +! --------------------------------------------------------------------- +! + subroutine dup_fline_seeds_list_ctl(org_fln_seeds, & + & new_fln_seeds) +! + type(fline_seeds_list_ctl), intent(in) :: org_fln_seeds + type(fline_seeds_list_ctl), intent(inout) :: new_fln_seeds +! +! + call dup_control_array_r3(org_fln_seeds%seed_point_ctl, & + & new_fln_seeds%seed_point_ctl) + call dup_control_array_r3(org_fln_seeds%seed_geological_ctl, & + & new_fln_seeds%seed_geological_ctl) + call dup_control_array_r3(org_fln_seeds%seed_spherical_ctl, & + & new_fln_seeds%seed_spherical_ctl) +! + call dup_control_array_i2(org_fln_seeds%seed_surface_ctl, & + & new_fln_seeds%seed_surface_ctl) +! + new_fln_seeds%block_name = org_fln_seeds%block_name + new_fln_seeds%i_seeds_list_ctl = org_fln_seeds%i_seeds_list_ctl +! + end subroutine dup_fline_seeds_list_ctl +! +! --------------------------------------------------------------------- +! + end module t_fline_seeds_list_ctl diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_fline_seeds_surf_group.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_fline_seeds_surf_group.f90 new file mode 100644 index 00000000..c570b934 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_fline_seeds_surf_group.f90 @@ -0,0 +1,258 @@ +!>@file t_fline_seeds_surf_group.f90 +!!@brief module t_fline_seeds_surf_group +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Surface group list to set seed points +!! +!!@verbatim +!! subroutine init_flux_on_seed_surface(ele, surf, sf_grp, nod_fld,& +!! & fln_prm, seed_sf_grp) +!! subroutine dealloc_flux_on_seed_surface(seed_sf_grp) +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(surface_group_data), intent(in) :: sf_grp +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_paramter), intent(in) :: fln_prm +!! type(fieldline_seeds_surf_group), intent(inout) :: seed_sf_grp +!!@endverbatim +! + module t_fline_seeds_surf_group +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter +! + use t_phys_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_control_params_4_fline +! + implicit none +! + type fieldline_seeds_surf_group + integer(kind = kint) :: nsurf_seed = 0 + integer(kind = kint), allocatable :: isf_grp_seed_item(:,:) + real(kind = kreal), allocatable :: flux_start(:) + end type fieldline_seeds_surf_group +! + private :: alloc_local_start_grp_item + private :: cal_flux_for_1sgrp, cal_area_for_1sgrp +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine init_flux_on_seed_surface(ele, surf, sf_grp, nod_fld, & + & fln_prm, seed_sf_grp) +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(surface_group_data), intent(in) :: sf_grp + type(phys_data), intent(in) :: nod_fld +! + type(fieldline_paramter), intent(in) :: fln_prm + type(fieldline_seeds_surf_group), intent(inout) :: seed_sf_grp +! + integer(kind = kint) :: num_sf +! + num_sf = count_nsurf_for_starting(ele, sf_grp, & + & fln_prm%igrp_start_fline_surf_grp) + call alloc_local_start_grp_item(num_sf, seed_sf_grp) +! + call set_isurf_for_starting & + & (ele, sf_grp, fln_prm%igrp_start_fline_surf_grp, & + & seed_sf_grp%nsurf_seed, seed_sf_grp%isf_grp_seed_item) +! + if( fln_prm%id_seed_distribution .eq. iflag_random_by_area & + & .or. fln_prm%id_seed_distribution .eq. iflag_no_random) then + if(iflag_debug .gt. 0) write(*,*) 'cal_area_for_1sgrp' + call cal_area_for_1sgrp(ele, surf, & + & seed_sf_grp%nsurf_seed, seed_sf_grp%isf_grp_seed_item, & + & seed_sf_grp%flux_start) + else + if(iflag_debug .gt. 0) write(*,*) 'cal_flux_for_1sgrp' + call cal_flux_for_1sgrp(ele, surf, & + & seed_sf_grp%nsurf_seed, seed_sf_grp%isf_grp_seed_item, & + & nod_fld%n_point, nod_fld%d_fld(1,fln_prm%iphys_4_fline), & + & seed_sf_grp%flux_start) + end if +! + end subroutine init_flux_on_seed_surface +! +! --------------------------------------------------------------------- +! + subroutine dealloc_flux_on_seed_surface(seed_sf_grp) + type(fieldline_seeds_surf_group), intent(inout) :: seed_sf_grp +! + deallocate(seed_sf_grp%isf_grp_seed_item, seed_sf_grp%flux_start) +! + end subroutine dealloc_flux_on_seed_surface +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine alloc_local_start_grp_item(num, seed_sf_grp) +! + integer(kind = kint), intent(in) :: num + type(fieldline_seeds_surf_group), intent(inout) :: seed_sf_grp +! +! + seed_sf_grp%nsurf_seed = num + allocate(seed_sf_grp%isf_grp_seed_item(2,num)) + allocate(seed_sf_grp%flux_start(num)) + if(num .gt. 0) seed_sf_grp%isf_grp_seed_item = 0 + if(num .gt. 0) seed_sf_grp%flux_start = 0.0d0 +! + end subroutine alloc_local_start_grp_item +! +! --------------------------------------------------------------------- +! + integer(kind = kint) function count_nsurf_for_starting & + & (ele, sf_grp, igrp_seed) +! + integer(kind = kint), intent(in) :: igrp_seed +! + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: sf_grp +! + integer(kind = kint) :: isurf, iele, icou, ist, ied +! +! + icou = 0 + ist = sf_grp%istack_grp(igrp_seed-1) + 1 + ied = sf_grp%istack_grp(igrp_seed) + do isurf = ist, ied + iele = sf_grp%item_sf_grp(1,isurf) + if(ele%interior_ele(iele) .ne. izero) icou = icou + 1 + end do +! + count_nsurf_for_starting = icou +! + end function count_nsurf_for_starting +! +! --------------------------------------------------------------------- +! + subroutine set_isurf_for_starting(ele, sf_grp, igrp_seed, & + & nsurf_seed, isf_grp_seed_item) +! + type(element_data), intent(in) :: ele + type(surface_group_data), intent(in) :: sf_grp + integer(kind = kint), intent(in) :: igrp_seed +! + integer(kind = kint), intent(in) :: nsurf_seed + integer(kind = kint), intent(inout) & + & :: isf_grp_seed_item(2,nsurf_seed) +! + integer(kind = kint) :: isurf, inum, iele, ist, ied +! +! + inum = 0 + ist = sf_grp%istack_grp(igrp_seed-1) + 1 + ied = sf_grp%istack_grp(igrp_seed) + do isurf = ist, ied + iele = sf_grp%item_sf_grp(1,isurf) + if(ele%interior_ele(iele) .ne. izero) then + inum = inum + 1 + isf_grp_seed_item(1:2,inum) = sf_grp%item_sf_grp(1:2,isurf) + end if + end do +! + end subroutine set_isurf_for_starting +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine cal_flux_for_1sgrp(ele, surf, num_sgrp, isurf_grp, & + & n_point, d_nod, flux) +! + use m_geometry_constants +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + integer(kind = kint), intent(in) :: num_sgrp + integer(kind = kint), intent(in) :: isurf_grp(2,num_sgrp) + integer(kind = kint), intent(in) :: n_point + real(kind = kreal), intent(in) :: d_nod(n_point,3) +! + real(kind = kreal), intent(inout) :: flux(num_sgrp) +! + integer (kind = kint) :: iele, isf, isurf, inum + integer (kind = kint) :: i1, i2, i3, i4 + real(kind = kreal) :: sign_surf, d_surf(3) +! +! + flux(1:num_sgrp) = 0.0d0 +! +!$omp parallel do & +!$omp& private(inum,iele,isf,isurf,sign_surf,i1,i2,i3,i4,d_surf) +!$cdir nodep + do inum = 1, num_sgrp + iele = isurf_grp(1,inum) + isf = isurf_grp(2,inum) + isurf = abs(surf%isf_4_ele(iele,isf)) + sign_surf = dble(surf%isf_4_ele(iele,isf) / isurf) +! + i1 = surf%ie_surf(isurf, 1) + i2 = surf%ie_surf(isurf, 2) + i3 = surf%ie_surf(isurf, 3) + i4 = surf%ie_surf(isurf, 4) +! + d_surf(1) = quad * (d_nod(i1,1) + d_nod(i2,1) & + & + d_nod(i3,1) + d_nod(i4,1)) + d_surf(2) = quad * (d_nod(i1,2) + d_nod(i2,2) & + & + d_nod(i3,2) + d_nod(i4,2)) + d_surf(3) = quad * (d_nod(i1,3) + d_nod(i2,3) & + & + d_nod(i3,3) + d_nod(i4,3)) +! + flux(inum) = flux(inum) + (surf%vnorm_surf(isurf,1) * d_surf(1) & + & + surf%vnorm_surf(isurf,2) * d_surf(2) & + & + surf%vnorm_surf(isurf,3) * d_surf(3)) & + & * surf%area_surf(isurf) * sign_surf & + & * dble(ele%interior_ele(iele)) + end do +!$omp end parallel do +! + end subroutine cal_flux_for_1sgrp +! +! --------------------------------------------------------------------- +! + subroutine cal_area_for_1sgrp(ele, surf, & + & num_sgrp, isurf_grp, flux) +! + use m_geometry_constants +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + integer(kind = kint), intent(in) :: num_sgrp + integer(kind = kint), intent(in) :: isurf_grp(2,num_sgrp) +! + real(kind = kreal), intent(inout) :: flux(num_sgrp) +! + integer (kind = kint) :: iele, isf, isurf, inum +! +! + flux(1:num_sgrp) = 0.0d0 +! +!$omp parallel do private(inum,iele,isf,isurf) + do inum = 1, num_sgrp + iele = isurf_grp(1,inum) + isf = isurf_grp(2,inum) + isurf = abs(surf%isf_4_ele(iele,isf)) +! + flux(inum) = flux(inum) + surf%area_surf(isurf) & + & * dble(ele%interior_ele(iele)) + end do +!$omp end parallel do +! + end subroutine cal_area_for_1sgrp +! +! --------------------------------------------------------------------- +! + end module t_fline_seeds_surf_group diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_local_fline.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_local_fline.f90 new file mode 100644 index 00000000..3eeb39af --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_local_fline.f90 @@ -0,0 +1,397 @@ +!>@file t_local_fline.f90 +!!@brief module t_local_fline +!! +!!@author H.Matsui +!!@date Programmed in June, 2024 +! +!>@brief local field line and tracer data structure +!! +!!@verbatim +!! subroutine reset_fline_start(fline_lc) +!! subroutine add_fline_start(xx4_add, v4_add, ntot_comp, col_add, & +!! & fline_lc) +!! subroutine alloc_local_fline(viz_fields, fline_lc) +!! type(ctl_params_viz_fields), intent(inout) :: viz_fields +!! subroutine dealloc_local_fline(fline_lc) +!! subroutine add_fline_list(iglobal_add, xx4_add, v4_add, & +!! & ntot_comp, col_add, fline_lc) +!! integer(kind = kint_gl), intent(in) :: iglobal_add +!! integer(kind = kint), intent(in) :: ntot_comp +!! real(kind = kreal), intent(in) :: xx4_add(4), +!! real(kind = kreal), intent(in) :: col_add(ntot_comp) +!! type(local_fieldline), intent(inout) :: fline_lc +!! +!! subroutine raise_local_fline_connect(fline_lc) +!! subroutine raise_local_fline_data(fline_lc) +!! type(local_fieldline), intent(inout) :: fline_lc +!! +!! subroutine check_local_fline(id_file, fline_lc) +!! type(local_fieldline), intent(in) :: fline_lc +!!@endverbatim +! + module t_local_fline +! + use m_precision + use m_constants +! + implicit none +! + type local_fieldline + integer(kind = kint) :: nele_line_buf + integer(kind = kint) :: nele_line_l + integer(kind = kint), allocatable :: iedge_line_l(:,:) +! + integer(kind = kint) :: nnod_line_buf + integer(kind = kint) :: nnod_line_l + integer(kind = kint) :: ntot_comp_l + integer(kind = kint_gl), allocatable :: iglobal_fline(:) + real(kind = kreal), allocatable :: xx_line_l(:,:) + real(kind = kreal), allocatable :: v_line_l(:,:) + real(kind = kreal), allocatable :: col_line_l(:,:) +! + integer(kind = kint), allocatable :: iedge_line_tmp(:,:) + integer(kind = kint_gl), allocatable :: iglobal_tmp(:) + real(kind = kreal), allocatable :: xx_line_tmp(:,:) + real(kind = kreal), allocatable :: v_line_tmp(:,:) + real(kind = kreal), allocatable :: col_line_tmp(:,:) + end type local_fieldline +! + private :: alloc_local_fline_data + private :: dealloc_local_fline_conn, dealloc_local_fline_data + private :: allocate_local_fline_conn_tmp + private :: allocate_local_fline_data_tmp + private :: deallocate_local_fline_conn_tmp + private :: deallocate_local_fline_data_tmp +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine reset_fline_start(fline_lc) +! + type(local_fieldline), intent(inout) :: fline_lc +! +! + fline_lc%nnod_line_l = 0 + fline_lc%nele_line_l = 0 +! + end subroutine reset_fline_start +! +! --------------------------------------------------------------------- +! + subroutine add_fline_start(xx4_add, v4_add, ntot_comp, col_add, & + & fline_lc) +! + integer(kind = kint), intent(in) :: ntot_comp + real(kind = kreal), intent(in) :: xx4_add(4), v4_add(4) + real(kind = kreal), intent(in) :: col_add(ntot_comp) + type(local_fieldline), intent(inout) :: fline_lc +! +! + if(fline_lc%nnod_line_l .ge. fline_lc%nnod_line_buf) then + call raise_local_fline_data(fline_lc) + end if + fline_lc%nnod_line_l = fline_lc%nnod_line_l + 1 +! + fline_lc%xx_line_l(1:3,fline_lc%nnod_line_l) = xx4_add(1:3) + fline_lc%v_line_l(1:3,fline_lc%nnod_line_l) = v4_add(1:3) + fline_lc%col_line_l(1:ntot_comp,fline_lc%nnod_line_l) & + & = col_add(1:ntot_comp) +! + end subroutine add_fline_start +! +! --------------------------------------------------------------------- +! + subroutine add_fline_list(iglobal_add, xx4_add, v4_add, & + & ntot_comp, col_add, fline_lc) +! + integer(kind = kint_gl), intent(in) :: iglobal_add + real(kind = kreal), intent(in) :: xx4_add(4), v4_add(4) + integer(kind = kint), intent(in) :: ntot_comp + real(kind = kreal), intent(in) :: col_add(ntot_comp) + type(local_fieldline), intent(inout) :: fline_lc +! +! + if(fline_lc%nele_line_l .ge. fline_lc%nele_line_buf) then + call raise_local_fline_connect(fline_lc) + end if + if(fline_lc%nnod_line_l .ge. fline_lc%nnod_line_buf) then + call raise_local_fline_data(fline_lc) + end if +! + fline_lc%nele_line_l = fline_lc%nele_line_l + 1 + fline_lc%nnod_line_l = fline_lc%nnod_line_l + 1 +! + fline_lc%iedge_line_l(1,fline_lc%nele_line_l) & + & = fline_lc%nnod_line_l - 1 + fline_lc%iedge_line_l(2,fline_lc%nele_line_l) & + & = fline_lc%nnod_line_l +! + fline_lc%iglobal_fline(fline_lc%nnod_line_l) = iglobal_add + fline_lc%xx_line_l(1:3,fline_lc%nnod_line_l) = xx4_add(1:3) + fline_lc%v_line_l(1:3,fline_lc%nnod_line_l) = v4_add(1:3) + fline_lc%col_line_l(1:ntot_comp,fline_lc%nnod_line_l) & + & = col_add(1:ntot_comp) +! + end subroutine add_fline_list +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine alloc_local_fline(viz_fields, fline_lc) +! + use t_ctl_params_viz_fields +! + type(ctl_params_viz_fields), intent(inout) :: viz_fields + type(local_fieldline), intent(inout) :: fline_lc +! +! + call reset_fline_start(fline_lc) +! + fline_lc%ntot_comp_l = viz_fields%ntot_color_comp + call alloc_local_fline_conn(ione, fline_lc) + call alloc_local_fline_data(itwo, fline_lc) +! + end subroutine alloc_local_fline +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dealloc_local_fline(fline_lc) +! + type(local_fieldline), intent(inout) :: fline_lc +! + call dealloc_local_fline_conn(fline_lc) + call dealloc_local_fline_data(fline_lc) +! + end subroutine dealloc_local_fline +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine raise_local_fline_connect(fline_lc) +! + type(local_fieldline), intent(inout) :: fline_lc + integer(kind = kint) :: i +! +! + call allocate_local_fline_conn_tmp(fline_lc) +!$omp parallel do + do i = 1, fline_lc%nele_line_l + fline_lc%iedge_line_tmp(1,i) = fline_lc%iedge_line_l(1,i) + fline_lc%iedge_line_tmp(2,i) = fline_lc%iedge_line_l(2,i) + end do +!$omp end parallel do +! + call dealloc_local_fline_conn(fline_lc) + call alloc_local_fline_conn(itwo*fline_lc%nele_line_l, fline_lc) +! +!$omp parallel do + do i = 1, fline_lc%nele_line_l + fline_lc%iedge_line_l(1,i) = fline_lc%iedge_line_tmp(1,i) + fline_lc%iedge_line_l(2,i) = fline_lc%iedge_line_tmp(2,i) + end do +!$omp end parallel do +! + call deallocate_local_fline_conn_tmp(fline_lc) +! + end subroutine raise_local_fline_connect +! +! --------------------------------------------------------------------- +! + subroutine raise_local_fline_data(fline_lc) +! + type(local_fieldline), intent(inout) :: fline_lc + integer(kind = kint) :: i +! +! + call allocate_local_fline_data_tmp(fline_lc) +! +!$omp parallel do + do i = 1, fline_lc%nnod_line_l + fline_lc%iglobal_tmp(i) = fline_lc%iglobal_fline(i) + fline_lc%xx_line_tmp(1,i) = fline_lc%xx_line_l(1,i) + fline_lc%xx_line_tmp(2,i) = fline_lc%xx_line_l(2,i) + fline_lc%xx_line_tmp(3,i) = fline_lc%xx_line_l(3,i) + fline_lc%v_line_tmp(1,i) = fline_lc%v_line_l(1,i) + fline_lc%v_line_tmp(2,i) = fline_lc%v_line_l(2,i) + fline_lc%v_line_tmp(3,i) = fline_lc%v_line_l(3,i) + fline_lc%col_line_tmp(1:fline_lc%ntot_comp_l,i) & + & = fline_lc%col_line_l(1:fline_lc%ntot_comp_l,i) + end do +!$omp end parallel do +! + call dealloc_local_fline_data(fline_lc) + call alloc_local_fline_data(itwo*fline_lc%nnod_line_l, fline_lc) +! +!$omp parallel do + do i = 1, fline_lc%nnod_line_l + fline_lc%iglobal_fline(i) = fline_lc%iglobal_tmp(i) + fline_lc%xx_line_l(1,i) = fline_lc%xx_line_tmp(1,i) + fline_lc%xx_line_l(2,i) = fline_lc%xx_line_tmp(2,i) + fline_lc%xx_line_l(3,i) = fline_lc%xx_line_tmp(3,i) + fline_lc%v_line_l(1,i) = fline_lc%v_line_tmp(1,i) + fline_lc%v_line_l(2,i) = fline_lc%v_line_tmp(2,i) + fline_lc%v_line_l(3,i) = fline_lc%v_line_tmp(3,i) + fline_lc%col_line_l(1:fline_lc%ntot_comp_l,i) & + & = fline_lc%col_line_tmp(1:fline_lc%ntot_comp_l,i) + end do +!$omp end parallel do +! + call deallocate_local_fline_data_tmp(fline_lc) +! + end subroutine raise_local_fline_data +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine alloc_local_fline_conn(nele_buf, fline_lc) +! + integer(kind = kint), intent(in) :: nele_buf + type(local_fieldline), intent(inout) :: fline_lc +! + fline_lc%nele_line_buf = nele_buf + allocate(fline_lc%iedge_line_l(2,fline_lc%nele_line_buf)) + if(fline_lc%nele_line_buf .gt. 0) fline_lc%iedge_line_l = 0 +! + end subroutine alloc_local_fline_conn +! +! --------------------------------------------------------------------- +! + subroutine alloc_local_fline_data(nnod_buf, fline_lc) +! + integer(kind = kint), intent(in) :: nnod_buf + type(local_fieldline), intent(inout) :: fline_lc +! + fline_lc%nnod_line_buf = nnod_buf + allocate(fline_lc%iglobal_fline(fline_lc%nnod_line_buf)) + allocate(fline_lc%xx_line_l(3,fline_lc%nnod_line_buf)) + allocate(fline_lc%v_line_l(3,fline_lc%nnod_line_buf)) + allocate(fline_lc%col_line_l(fline_lc%ntot_comp_l, & + & fline_lc%nnod_line_buf)) + if(fline_lc%nele_line_buf .gt. 0) fline_lc%iglobal_fline = 0 + if(fline_lc%nnod_line_buf .gt. 0) fline_lc%xx_line_l = 0.0d0 + if(fline_lc%nnod_line_buf .gt. 0) fline_lc%v_line_l = 0.0d0 + if(fline_lc%nnod_line_buf .gt. 0) fline_lc%col_line_l = 0.0d0 +! + end subroutine alloc_local_fline_data +! +! --------------------------------------------------------------------- +! + subroutine allocate_local_fline_conn_tmp(fline_lc) +! + type(local_fieldline), intent(inout) :: fline_lc +! + allocate(fline_lc%iedge_line_tmp(2,fline_lc%nele_line_l)) + if(fline_lc%nele_line_l .gt. 0) fline_lc%iedge_line_tmp = 0 +! + end subroutine allocate_local_fline_conn_tmp +! +! --------------------------------------------------------------------- +! + subroutine allocate_local_fline_data_tmp(fline_lc) +! + type(local_fieldline), intent(inout) :: fline_lc +! + allocate(fline_lc%iglobal_tmp(fline_lc%nnod_line_l)) + allocate(fline_lc%xx_line_tmp(3,fline_lc%nnod_line_l)) + allocate(fline_lc%v_line_tmp(3,fline_lc%nnod_line_l)) + allocate(fline_lc%col_line_tmp(fline_lc%ntot_comp_l, & + & fline_lc%nnod_line_l)) +! + if(fline_lc%nele_line_l .le. 0) return + fline_lc%iglobal_tmp = 0 + fline_lc%xx_line_tmp = 0.0d0 + fline_lc%v_line_tmp = 0.0d0 + fline_lc%col_line_tmp = 0.0d0 +! + end subroutine allocate_local_fline_data_tmp +! +! --------------------------------------------------------------------- +! + subroutine dealloc_local_fline_conn(fline_lc) +! + type(local_fieldline), intent(inout) :: fline_lc +! + deallocate(fline_lc%iedge_line_l) +! + end subroutine dealloc_local_fline_conn +! +! --------------------------------------------------------------------- +! + subroutine dealloc_local_fline_data(fline_lc) +! + type(local_fieldline), intent(inout) :: fline_lc +! +! + deallocate(fline_lc%xx_line_l, fline_lc%v_line_l) + deallocate(fline_lc%iglobal_fline, fline_lc%col_line_l) +! + end subroutine dealloc_local_fline_data +! +! --------------------------------------------------------------------- +! + subroutine deallocate_local_fline_conn_tmp(fline_lc) + type(local_fieldline), intent(inout) :: fline_lc +! + deallocate(fline_lc%iedge_line_tmp) +! + end subroutine deallocate_local_fline_conn_tmp +! +! --------------------------------------------------------------------- +! + subroutine deallocate_local_fline_data_tmp(fline_lc) + type(local_fieldline), intent(inout) :: fline_lc +! +! + deallocate(fline_lc%xx_line_tmp, fline_lc%v_line_tmp) + deallocate(fline_lc%col_line_tmp, fline_lc%iglobal_tmp) +! + end subroutine deallocate_local_fline_data_tmp +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine check_local_fline(id_file, fline_lc) +! + integer(kind = kint), intent(in) :: id_file + type(local_fieldline), intent(in) :: fline_lc + integer(kind = kint) :: i, nd +! +! + write(id_file,*) 'xx_line_l', fline_lc%nnod_line_l + do i = 1, fline_lc%nnod_line_l + write(id_file,'(i16,1p3e16.7)') i, fline_lc%xx_line_l(1:3,i) + end do +! + write(id_file,*) 'v_line_l', fline_lc%nnod_line_l + do i = 1, fline_lc%nnod_line_l + write(id_file,'(i16,1p3e16.7)') i, fline_lc%v_line_l(1:3,i) + end do +! + write(id_file,*) 'iedge_line_l', fline_lc%nele_line_l + do i = 1, fline_lc%nele_line_l + write(id_file,'(2i16,a7,2i16)') i, ione, ' line ', & + & fline_lc%iedge_line_l(1:2,i) + end do +! + write(id_file,'(2i4)') ione, ione + write(id_file,'(a)') 'color col_line_l,' + do i = 1, fline_lc%nnod_line_l + write(id_file,'(i16)', ADVANCE='NO') i + do nd = 1, fline_lc%ntot_comp_l + write(id_file,'(i16,1pe16.7)', ADVANCE='NO') & + & fline_lc%iglobal_fline(i), fline_lc%col_line_l(nd,i) + end do + write(id_file,*) + end do +! + close(id_file) +! + end subroutine check_local_fline +! +! --------------------------------------------------------------------- +! + end module t_local_fline diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_particle_trace.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_particle_trace.f90 new file mode 100644 index 00000000..403f34a1 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_particle_trace.f90 @@ -0,0 +1,251 @@ +!>@file t_particle_trace.f90 +!!@brief module t_particle_trace +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Main routine for field line module +!! +!!@verbatim +!! subroutine TRACER_initialize(init_d, finish_d, rst_step, & +!! & geofem, para_surf, & +!! & nod_fld, tracer_ctls, tracer) +!! type(time_data), intent(in) :: init_d +!! type(finish_data), intent(in) :: finish_d +!! type(IO_step_param), intent(in) :: rst_step +!! type(mesh_data), intent(in) :: geofem +!! type(paralell_surface_indices), intent(in) :: para_surf +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_controls), intent(inout) :: tracer_ctls +!! type(tracer_module), intent(inout) :: tracer +!! subroutine TRACER_evolution & +!! & (elps_tracer, time_d, finish_d, rst_step, istep_tracer,& +!! & geofem, para_surf, nod_fld, tracer, m_SR) +!! type(elapsed_lables), intent(in) :: elps_tracer +!! integer(kind = kint), intent(in) :: istep_tracer +!! type(time_data), intent(in) :: time_d +!! type(finish_data), intent(in) :: finish_d +!! type(IO_step_param), intent(in) :: rst_step +!! type(IO_step_param), intent(in) :: TRACER_d +!! type(mesh_data), intent(in) :: geofem +!! type(paralell_surface_indices), intent(in) :: para_surf +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(inout) :: tracer +!! type(mesh_SR), intent(inout) :: m_SR +!! subroutine TRACER_visualize(istep_tracer, time_d, rst_step, & +!! & tracer) +!! integer(kind = kint), intent(in) :: istep_tracer +!! type(time_data), intent(in) :: time_d +!! type(IO_step_param), intent(in) :: rst_step +!! type(tracer_module), intent(inout) :: tracer +!! subroutine TRACER_finalize(fline) +!! type(tracer_module), intent(inout) :: tracer +!!@endverbatim +! + module t_particle_trace +! + use m_precision +! + use m_machine_parameter + use m_geometry_constants + use m_work_time +! + use t_time_data + use t_mesh_data + use t_phys_data + use t_parallel_surface_indices + use t_control_params_4_fline + use t_source_of_filed_line + use t_trace_data_send_recv + use t_broadcast_trace_data + use t_tracing_data + use t_local_fline + use t_ucd_data +! + implicit none +! + type tracer_module + integer(kind = kint) :: num_trace +! + type(fieldline_paramter), allocatable :: fln_prm(:) +! + type(each_fieldline_source), allocatable :: fln_src(:) + type(each_fieldline_trace), allocatable :: fln_tce(:) + type(local_fieldline), allocatable :: fline_lc(:) + type(broadcast_trace_data), allocatable :: fln_bcast(:) + type(trace_data_send_recv), allocatable :: fln_SR(:) + end type tracer_module +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine TRACER_initialize(init_d, finish_d, rst_step, & + & geofem, para_surf, & + & nod_fld, tracer_ctls, tracer) +! + use t_control_data_flines + use m_connect_hexa_2_tetra + use multi_tracer_fieldline + use multi_tracer_file_IO + use multi_trace_particle +! + type(time_data), intent(in) :: init_d + type(finish_data), intent(in) :: finish_d + type(IO_step_param), intent(in) :: rst_step +! + type(mesh_data), intent(in) :: geofem + type(paralell_surface_indices), intent(in) :: para_surf + type(phys_data), intent(in) :: nod_fld + type(fieldline_controls), intent(inout) :: tracer_ctls + type(tracer_module), intent(inout) :: tracer +! +! + tracer%num_trace = tracer_ctls%num_fline_ctl + if(tracer%num_trace .le. 0) return +! + call alloc_TRACER_modules(tracer) + + call set_tracer_controls(geofem%mesh, geofem%group, nod_fld, & + & tracer%num_trace, tracer_ctls, tracer%fln_prm) + call dealloc_fline_ctl_struct(tracer_ctls) +! + call alloc_each_FLINE_data(tracer%num_trace, tracer%fln_prm, & + & tracer%fln_src, tracer%fln_tce, tracer%fline_lc, & + & tracer%fln_SR, tracer%fln_bcast) + call alloc_each_TRACER_data(geofem%mesh%node, tracer%num_trace, & + & tracer%fln_src) +! + call set_fixed_FLINE_seed_points(geofem%mesh, tracer%num_trace, & + & tracer%fln_prm, tracer%fln_src) + + call set_FLINE_seed_fields & + & (geofem%mesh, geofem%group, para_surf, nod_fld, & + & tracer%num_trace, tracer%fln_prm, tracer%fln_src, & + & tracer%fln_tce) +! + call sel_input_tracer_restarts(init_d, rst_step, & + & tracer%num_trace, tracer%fln_prm, & + & tracer%fln_tce, tracer%fline_lc) +! + end subroutine TRACER_initialize +! +! --------------------------------------------------------------------- +! + subroutine TRACER_evolution & + & (elps_tracer, time_d, finish_d, rst_step, istep_tracer, & + & geofem, para_surf, nod_fld, tracer, m_SR) +! + use t_mesh_SR + use set_fields_for_fieldline + use trace_particle + use collect_fline_data + use parallel_ucd_IO_select + use set_fline_seeds_from_list + use multi_tracer_fieldline + use multi_tracer_file_IO + use multi_trace_particle +! +! + integer(kind = kint), intent(in) :: istep_tracer + type(elapsed_lables), intent(in) :: elps_tracer + type(time_data), intent(in) :: time_d + type(finish_data), intent(in) :: finish_d + type(IO_step_param), intent(in) :: rst_step + type(mesh_data), intent(in) :: geofem + type(paralell_surface_indices), intent(in) :: para_surf + type(phys_data), intent(in) :: nod_fld +! + type(tracer_module), intent(inout) :: tracer + type(mesh_SR), intent(inout) :: m_SR +! +! + if(tracer%num_trace .le. 0) return + + call s_multi_trace_particle & + & (time_d, elps_tracer, geofem%mesh, para_surf, & + & nod_fld, tracer%num_trace, tracer%fln_prm, & + & tracer%fln_src, tracer%fln_tce, tracer%fline_lc, & + & tracer%fln_SR, tracer%fln_bcast, m_SR) +! +! + if(elps_tracer%flag_elapsed) & + & call start_elapsed_time(elps_tracer%ist_elapsed+3) + call output_tracer_restarts(time_d, finish_d, rst_step, & + & tracer%num_trace, tracer%fln_prm, tracer%fline_lc) + if(istep_tracer .le. 0) return + call output_tracer_viz_files(istep_tracer, time_d, & + & tracer%num_trace, tracer%fln_prm, tracer%fline_lc) + if(elps_tracer%flag_elapsed) & + & call end_elapsed_time(elps_tracer%ist_elapsed+3) +! + end subroutine TRACER_evolution +! +! --------------------------------------------------------------------- +! + subroutine TRACER_visualize(istep_tracer, time_d, rst_step, & + & tracer) +! + use t_mesh_SR + use set_fields_for_fieldline + use multi_tracer_file_IO +! +! + integer(kind = kint), intent(in) :: istep_tracer + type(time_data), intent(in) :: time_d + type(IO_step_param), intent(in) :: rst_step + type(tracer_module), intent(inout) :: tracer +! +! + if(tracer%num_trace .le. 0) return +! + call input_tracer_restarts(time_d, rst_step, tracer%num_trace, & + & tracer%fln_prm, tracer%fline_lc) +! + if(istep_tracer .le. 0) return + call output_tracer_viz_files(istep_tracer, time_d, & + & tracer%num_trace, tracer%fln_prm, tracer%fline_lc) +! + end subroutine TRACER_visualize +! +! --------------------------------------------------------------------- +! + subroutine TRACER_finalize(tracer) +! + use multi_tracer_fieldline + use multi_trace_particle +! + type(tracer_module), intent(inout) :: tracer +! +! + if (tracer%num_trace .le. 0) return + call dealloc_each_TRACER_data(tracer%num_trace, tracer%fln_src) + call dealloc_each_FLINE_data(tracer%num_trace, tracer%fln_prm, & + & tracer%fln_src, tracer%fln_tce, tracer%fline_lc, & + & tracer%fln_SR, tracer%fln_bcast) + deallocate(tracer%fln_src, tracer%fline_lc, tracer%fln_bcast) + deallocate(tracer%fln_tce, tracer%fln_prm, tracer%fln_SR) +! + end subroutine TRACER_finalize +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine alloc_TRACER_modules(tracer) +! + type(tracer_module), intent(inout) :: tracer +! + allocate(tracer%fln_prm(tracer%num_trace)) + allocate(tracer%fln_src(tracer%num_trace)) + allocate(tracer%fln_tce(tracer%num_trace)) + allocate(tracer%fln_SR(tracer%num_trace)) + allocate(tracer%fln_bcast(tracer%num_trace)) + allocate(tracer%fline_lc(tracer%num_trace)) +! + end subroutine alloc_TRACER_modules +! +! --------------------------------------------------------------------- +! + end module t_particle_trace diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_source_of_filed_line.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_source_of_filed_line.f90 new file mode 100644 index 00000000..f40f3e87 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_source_of_filed_line.f90 @@ -0,0 +1,154 @@ +!>@file t_source_of_filed_line.f90 +!!@brief module t_source_of_filed_line +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structure of start point data for line tracing iteration +!! +!!@verbatim +!! subroutine alloc_start_point_fline(num_pe, fln_prm, fln_src) +!! subroutine alloc_init_tracer_position(fln_prm, fln_src) +!! type(fieldline_paramter), intent(in) :: fln_prm +!! type(each_fieldline_source), intent(inout) :: fln_src +!! +!! subroutine dealloc_start_point_fline(fln_src) +!! subroutine dealloc_init_tracer_position(fln_prm) +!! type(each_fieldline_source), intent(inout) :: fln_src +!!@endverbatim +! + module t_source_of_filed_line +! + use m_precision + use m_constants + use t_control_params_4_fline +! + implicit none +! +! + type each_fieldline_source + integer(kind = kint) :: num_line_local = 0 + real(kind = kreal), allocatable :: xx4_initial_fline(:,:) +! + real(kind = kreal), allocatable :: flux_stack_fline(:) +!> outward flux flag + integer(kind = kint), allocatable & + & :: iflag_outward_flux_fline(:) +! + integer(kind = kint) :: n_points_prev = 0 +!> velocity of previous step + real(kind = kreal), allocatable :: v_prev(:,:) +! +!> Position list of seed point in start element + real(kind = kreal), allocatable :: xi_surf_start_fline(:,:) +!> domain list of seed point + integer(kind = kint), allocatable :: ip_surf_start_fline(:) +!> element list of seed point + integer(kind = kint), allocatable :: iele_surf_start_fline(:) + end type each_fieldline_source +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_velocity_at_previous(numnod, fln_src) +! + integer(kind = kint), intent(in) :: numnod + type(each_fieldline_source), intent(inout) :: fln_src +! +! + fln_src%n_points_prev = numnod + allocate(fln_src%v_prev(fln_src%n_points_prev,3)) + if(fln_src%n_points_prev .gt. 0) then +!$omp parallel workshare + fln_src%v_prev = 0.0d0 +!$omp end parallel workshare + end if +! + end subroutine alloc_velocity_at_previous +! +! --------------------------------------------------------------------- +! + subroutine dealloc_velocity_at_previous(fln_src) + type(each_fieldline_source), intent(inout) :: fln_src +! + deallocate(fln_src%v_prev) +! + end subroutine dealloc_velocity_at_previous +! +! --------------------------------------------------------------------- +! + subroutine alloc_start_point_fline(num_pe, fln_prm, fln_src) +! + integer, intent(in) :: num_pe + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_source), intent(inout) :: fln_src +! + integer(kind = kint) :: num +! +! + allocate(fln_src%flux_stack_fline(0:num_pe)) + fln_src%flux_stack_fline = 0.0d0 +! + num = fln_prm%num_each_field_line + allocate(fln_src%iflag_outward_flux_fline(num)) + allocate(fln_src%xx4_initial_fline(4,num)) +! + fln_src%iflag_outward_flux_fline(1:num) = 0 + fln_src%xx4_initial_fline = 0.0d0 +! + end subroutine alloc_start_point_fline +! +! --------------------------------------------------------------------- +! + subroutine alloc_init_tracer_position(fln_prm, fln_src) +! + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_source), intent(inout) :: fln_src +! + integer(kind = kint) :: num +! +! + num = fln_prm%num_each_field_line + allocate(fln_src%xi_surf_start_fline(3,num)) + allocate(fln_src%ip_surf_start_fline(num)) + allocate(fln_src%iele_surf_start_fline(num)) +! + if(num .gt. 0) then + fln_src%xi_surf_start_fline(1:3,1:num) = 0.0d0 + fln_src%ip_surf_start_fline(1:num) = 0 + fln_src%iele_surf_start_fline(1:num) = 0 + end if +! + end subroutine alloc_init_tracer_position +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dealloc_start_point_fline(fln_src) +! + type(each_fieldline_source), intent(inout) :: fln_src +! + deallocate(fln_src%xx4_initial_fline) + deallocate(fln_src%flux_stack_fline) + deallocate(fln_src%iflag_outward_flux_fline) +! + end subroutine dealloc_start_point_fline +! +! --------------------------------------------------------------------- +! + subroutine dealloc_init_tracer_position(fln_src) +! + type(each_fieldline_source), intent(inout) :: fln_src +! + deallocate(fln_src%xi_surf_start_fline) + deallocate(fln_src%ip_surf_start_fline) + deallocate(fln_src%iele_surf_start_fline) +! + end subroutine dealloc_init_tracer_position +! +! --------------------------------------------------------------------- +! + end module t_source_of_filed_line diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_trace_data_send_recv.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_trace_data_send_recv.f90 new file mode 100644 index 00000000..55dca764 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_trace_data_send_recv.f90 @@ -0,0 +1,495 @@ +!>@file t_trace_data_send_recv.f90 +!!@brief module t_trace_data_send_recv +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Routines to construct field lines +!! +!!@verbatim +!! subroutine alloc_trace_data_SR_num(viz_fields, fln_SR) +!! subroutine dealloc_trace_data_SR_num(fln_SR) +!! subroutine s_trace_data_send_recv(fln_prm, fln_tce, fln_SR, & +!! & SR_sig, nline_global) +!!@endverbatim +! + module t_trace_data_send_recv +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter + use m_geometry_constants + use t_geometry_data + use t_surface_data + use t_comm_table + use t_para_double_numbering + use t_control_params_4_fline +! + implicit none +! + integer(kind= kint), parameter, private :: nitem8_export = 1 + integer(kind= kint), parameter, private :: nitem_export = 6 +! + type trace_data_send_recv + integer(kind = kint) :: npe_send + integer(kind = kint) :: npe_recv + integer(kind = kint), allocatable :: num_send(:) + integer(kind = kint), allocatable :: num_recv(:) +! + integer(kind = kint), allocatable :: id_pe_send(:) + integer(kind = kint), allocatable :: ineib_send(:) + integer(kind = kint), allocatable :: istack_send(:) + integer(kind = kint), allocatable :: istack_isend(:) + integer(kind = kint), allocatable :: icou_send(:) +! + integer(kind = kint), allocatable :: id_pe_recv(:) + integer(kind = kint), allocatable :: ineib_recv(:) + integer(kind = kint), allocatable :: istack_recv(:) + integer(kind = kint), allocatable :: istack_irecv(:) +! + integer(kind = kint) :: ncomp_export + integer(kind = kint) :: ntot_send + integer(kind = kint) :: ntot_sendbuf + integer(kind = kint), allocatable :: item_send(:) + integer(kind = kint_gl), allocatable :: i8Send(:,:) + integer(kind = kint), allocatable :: iSend(:,:) + real(kind = kreal), allocatable :: rSend(:,:) + integer(kind = kint) :: ntot_recv + integer(kind = kint) :: ntot_recvbuf + integer(kind = kint), allocatable :: item_recv(:) + integer(kind = kint_gl), allocatable :: i8Recv(:,:) + integer(kind = kint), allocatable :: iRecv(:,:) + real(kind = kreal), allocatable :: rRecv(:,:) + end type trace_data_send_recv +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_trace_data_SR_num(viz_fields, fln_SR) +! + use t_ctl_params_viz_fields +! + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(trace_data_send_recv), intent(inout) :: fln_SR +! + fln_SR%ntot_sendbuf = 0 + fln_SR%ntot_recvbuf = 0 + fln_SR%ncomp_export = 9 + viz_fields%ntot_color_comp + + allocate(fln_SR%num_send(nprocs)) + allocate(fln_SR%num_recv(nprocs)) +! + allocate(fln_SR%id_pe_send(nprocs)) + allocate(fln_SR%ineib_send(nprocs)) + allocate(fln_SR%istack_send(0:nprocs)) + allocate(fln_SR%istack_isend(0:nprocs)) + allocate(fln_SR%icou_send(nprocs)) + + allocate(fln_SR%id_pe_recv(nprocs)) + allocate(fln_SR%ineib_recv(nprocs)) + allocate(fln_SR%istack_recv(0:nprocs)) + allocate(fln_SR%istack_irecv(0:nprocs)) +! +!$omp parallel workshare + fln_SR%num_send(1:nprocs) = 0 + fln_SR%num_recv(1:nprocs) = 0 + fln_SR%ineib_send(1:nprocs) = 0 + fln_SR%ineib_recv(1:nprocs) = 0 + fln_SR%id_pe_send(1:nprocs) = -1 + fln_SR%id_pe_recv(1:nprocs) = -1 + fln_SR%icou_send(1:nprocs) = 0 +!$omp end parallel workshare +!$omp parallel workshare + fln_SR%istack_send(0:nprocs) = 0 + fln_SR%istack_recv(0:nprocs) = 0 + fln_SR%istack_isend(0:nprocs) = 0 + fln_SR%istack_irecv(0:nprocs) = 0 +!$omp end parallel workshare +! + call alloc_trace_SR_export(ione, fln_SR) + call alloc_trace_SR_import(ione, fln_SR) +! + end subroutine alloc_trace_data_SR_num +! +! --------------------------------------------------------------------- +! + subroutine s_trace_data_send_recv(fln_prm, fln_tce, fln_SR, & + & SR_sig, nline_global) +! + use calypso_SR + use calypso_SR_core + use set_to_send_buffer + use solver_SR_int + use solver_SR_int8 + use set_to_send_buffer + use select_copy_from_recv + use t_solver_SR + use t_tracing_data +! + type(fieldline_paramter), intent(in) :: fln_prm +! + integer(kind = kint), intent(inout) :: nline_global + type(each_fieldline_trace), intent(inout) :: fln_tce + type(trace_data_send_recv), intent(inout) :: fln_SR + type(send_recv_status), intent(inout) :: SR_sig +! +! integer(kind = kint) :: i +! + call count_trace_data_SR_npe(fln_tce, fln_SR) + call count_trace_data_SR_num(fln_SR) + call raise_trace_SR_export(fln_SR%ntot_send, fln_SR) + call raise_trace_SR_import(fln_SR) + + call set_trace_data_to_SR(fln_tce, fln_SR) +! + call resize_SR_flag(fln_SR%npe_send, fln_SR%npe_recv, SR_sig) + call calypso_send_recv_core & + & (fln_SR%ncomp_export, fln_SR%npe_send, fln_SR%id_pe_send, & + & fln_SR%istack_send, fln_SR%rSend(1,1), & + & fln_SR%npe_recv, fln_SR%id_pe_recv, & + & fln_SR%istack_recv, 0, fln_SR%rRecv, SR_sig) + call calypso_send_recv_fin(fln_SR%npe_send, 0, SR_sig) +! + call calypso_send_recv_intcore & + & (fln_SR%npe_send, fln_SR%id_pe_send, & + & fln_SR%istack_isend, fln_SR%iSend(1,1), 0, & + & fln_SR%npe_recv, fln_SR%id_pe_recv, & + & fln_SR%istack_irecv, fln_SR%iRecv(1,1), SR_sig) + call calypso_send_recv_fin(fln_SR%npe_send, 0, SR_sig) +! + call calypso_send_recv_i8core & + & (fln_SR%npe_send, fln_SR%id_pe_send, & + & fln_SR%istack_isend, fln_SR%i8Send(1,1), 0, & + & fln_SR%npe_recv, fln_SR%id_pe_recv, & + & fln_SR%istack_irecv, fln_SR%i8Recv(1,1), SR_sig) + call calypso_send_recv_fin(fln_SR%npe_send, 0, SR_sig) +! + call set_trace_data_from_SR(fln_SR, fln_prm, fln_tce) + nline_global = fln_tce%istack_current_fline(nprocs) & + & - fln_tce%istack_current_fline(0) +! + end subroutine s_trace_data_send_recv +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dealloc_trace_data_SR_num(fln_SR) +! + type(trace_data_send_recv), intent(inout) :: fln_SR +! + deallocate(fln_SR%istack_isend, fln_SR%istack_irecv) + deallocate(fln_SR%istack_send, fln_SR%istack_recv) + deallocate(fln_SR%ineib_send, fln_SR%ineib_recv) + deallocate(fln_SR%id_pe_send, fln_SR%id_pe_recv) + deallocate(fln_SR%num_send, fln_SR%num_recv) + deallocate(fln_SR%icou_send) +! + end subroutine dealloc_trace_data_SR_num +! +! --------------------------------------------------------------------- +! + subroutine raise_trace_SR_export(nnod_org, fln_SR) +! + integer(kind = kint), intent(in) :: nnod_org + type(trace_data_send_recv), intent(inout) :: fln_SR +! + if(fln_SR%ntot_sendbuf .gt. nnod_org) return + call dealloc_trace_SR_export(fln_SR) + call alloc_trace_SR_export(nnod_org, fln_SR) +! + end subroutine raise_trace_SR_export +! +! --------------------------------------------------------------------- +! + subroutine raise_trace_SR_import(fln_SR) +! + type(trace_data_send_recv), intent(inout) :: fln_SR +! + if(fln_SR%ntot_recvbuf .gt. fln_SR%ntot_recv) return + call dealloc_trace_SR_import(fln_SR) + call alloc_trace_SR_import(fln_SR%ntot_recv, fln_SR) +! + end subroutine raise_trace_SR_import +! +! --------------------------------------------------------------------- +! + subroutine alloc_trace_SR_export(ntot, fln_SR) +! + integer(kind = kint), intent(in) :: ntot + type(trace_data_send_recv), intent(inout) :: fln_SR +! + fln_SR%ntot_sendbuf = ntot + allocate(fln_SR%item_send(ntot)) + allocate(fln_SR%iSend(nitem_export,ntot)) + allocate(fln_SR%rSend(fln_SR%ncomp_export,ntot)) + return +! + if(ntot .le. 0) return +!$omp parallel workshare + fln_SR%item_send(:) = 0 +!$omp end parallel workshare +!$omp parallel workshare + fln_SR%iSend(:,:) = 0 +!$omp end parallel workshare +!$omp parallel workshare + fln_SR%i8Send(:,:) = 0 +!$omp end parallel workshare +!$omp parallel workshare + fln_SR%rSend(:,:) = 0 +!$omp end parallel workshare +! + end subroutine alloc_trace_SR_export +! +! --------------------------------------------------------------------- +! + subroutine alloc_trace_SR_import(ntot, fln_SR) +! + integer(kind = kint), intent(in) :: ntot + type(trace_data_send_recv), intent(inout) :: fln_SR +! + fln_SR%ntot_recvbuf = ntot + allocate(fln_SR%item_recv(ntot)) + allocate(fln_SR%iRecv(nitem_export,ntot)) + allocate(fln_SR%i8Recv(nitem8_export,ntot)) + allocate(fln_SR%rRecv(fln_SR%ncomp_export,ntot)) + return +! + if(ntot .le. 0) return +!$omp parallel workshare + fln_SR%item_recv(:) = 0 +!$omp end parallel workshare +!$omp parallel workshare + fln_SR%iRecv(:,:) = 0 +!$omp end parallel workshare +!$omp parallel workshare + fln_SR%i8Recv(:,:) = 0 +!$omp end parallel workshare +!$omp parallel workshare + fln_SR%rRecv(:,:) = 0.0d0 +!$omp end parallel workshare +! + end subroutine alloc_trace_SR_import +! +! --------------------------------------------------------------------- +! + subroutine dealloc_trace_SR_export(fln_SR) + type(trace_data_send_recv), intent(inout) :: fln_SR +! + if(allocated(fln_SR%item_send) .eqv. .FALSE.) return + deallocate(fln_SR%item_send) + deallocate(fln_SR%iSend) + deallocate(fln_SR%i8Send) + deallocate(fln_SR%rSend) +! + end subroutine dealloc_trace_SR_export +! +! --------------------------------------------------------------------- +! + subroutine dealloc_trace_SR_import(fln_SR) + type(trace_data_send_recv), intent(inout) :: fln_SR +! + if(allocated(fln_SR%item_recv) .eqv. .FALSE.) return + deallocate(fln_SR%item_recv) + deallocate(fln_SR%rRecv) + deallocate(fln_SR%i8Recv) + deallocate(fln_SR%iRecv) +! + end subroutine dealloc_trace_SR_import +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine count_trace_data_SR_npe(fln_tce, fln_SR) +! + use calypso_mpi_int + use t_tracing_data +! + type(each_fieldline_trace), intent(in) :: fln_tce + type(trace_data_send_recv), intent(inout) :: fln_SR +! + integer(kind = kint) :: i, ip +! +!$omp parallel workshare + fln_SR%num_send(1:nprocs) = 0 + fln_SR%num_recv(1:nprocs) = 0 + fln_SR%ineib_send(1:nprocs) = 0 + fln_SR%ineib_recv(1:nprocs) = 0 + fln_SR%id_pe_send(1:nprocs) = -1 + fln_SR%id_pe_recv(1:nprocs) = -1 + fln_SR%icou_send(1:nprocs) = 0 +!$omp end parallel workshare +!$omp parallel workshare + fln_SR%istack_send(0:nprocs) = 0 + fln_SR%istack_recv(0:nprocs) = 0 + fln_SR%istack_isend(0:nprocs) = 0 + fln_SR%istack_irecv(0:nprocs) = 0 +!$omp end parallel workshare + + do i = 1, fln_tce%num_current_fline + if(fln_tce%iflag_comm_start(i) .ne. ione) cycle + if(fln_tce%isf_dbl_start(1,i) .eq. my_rank) cycle +! + ip = fln_tce%isf_dbl_start(1,i) + 1 + fln_SR%num_send(ip) = fln_SR%num_send(ip) + 1 + end do + call calypso_mpi_alltoall_one_int(fln_SR%num_send, & + & fln_SR%num_recv) +! + fln_SR%npe_send = 0 + do ip = 1, nprocs + if(fln_SR%num_send(ip) .gt. 0) then + fln_SR%npe_send = fln_SR%npe_send + 1 + end if + end do + fln_SR%npe_recv = 0 + do ip = 1, nprocs + if(fln_SR%num_recv(ip) .gt. 0) then + fln_SR%npe_recv = fln_SR%npe_recv + 1 + end if + end do +! + end subroutine count_trace_data_SR_npe +! +! --------------------------------------------------------------------- +! + subroutine count_trace_data_SR_num(fln_SR) +! + use t_tracing_data +! + type(trace_data_send_recv), intent(inout) :: fln_SR +! + integer(kind = kint) :: ip, icou +! + icou = 0 + fln_SR%istack_send(0) = 0 + do ip = 1, nprocs + if(fln_SR%num_send(ip) .gt. 0) then + icou = icou + 1 + fln_SR%ineib_send(ip) = icou + fln_SR%id_pe_send(icou) = ip-1 + fln_SR%istack_send(icou) = fln_SR%istack_send(icou-1) & + & + fln_SR%num_send(ip) + end if + end do + fln_SR%ntot_send = fln_SR%istack_send(fln_SR%npe_send) + + icou = 0 + fln_SR%istack_recv(0) = 0 + do ip = 1, nprocs + if(fln_SR%num_recv(ip) .gt. 0) then + icou = icou + 1 + fln_SR%ineib_recv(ip) = icou + fln_SR%id_pe_recv(icou) = ip-1 + fln_SR%istack_recv(icou) = fln_SR%istack_recv(icou-1) & + & + fln_SR%num_recv(ip) + end if + end do + fln_SR%ntot_recv = fln_SR%istack_recv(fln_SR%npe_recv) + + fln_SR%istack_isend(0:fln_SR%npe_send) & + & = nitem_export * fln_SR%istack_send(0:fln_SR%npe_send) + fln_SR%istack_irecv(0:fln_SR%npe_recv) & + & = nitem_export * fln_SR%istack_recv(0:fln_SR%npe_recv) +! + end subroutine count_trace_data_SR_num +! +! --------------------------------------------------------------------- +! + subroutine set_trace_data_to_SR(fln_tce, fln_SR) +! + use t_tracing_data +! + type(each_fieldline_trace), intent(in) :: fln_tce + type(trace_data_send_recv), intent(inout) :: fln_SR +! + integer(kind = kint) :: inum, icou + integer(kind = kint) :: irank_send, ineib_tmp +! + do inum = 1, fln_SR%ntot_recv + fln_SR%item_recv(inum) = inum + end do + + fln_SR%icou_send(1:nprocs) = fln_SR%istack_send(0:nprocs-1) + do inum = 1, fln_tce%num_current_fline + if(fln_tce%iflag_comm_start(inum) .ne. ione) cycle + if(fln_tce%isf_dbl_start(1,inum) .eq. my_rank) cycle + + irank_send = fln_tce%isf_dbl_start(1,inum) + ineib_tmp = fln_SR%ineib_send(irank_send+1) + fln_SR%icou_send(ineib_tmp) = fln_SR%icou_send(ineib_tmp) + 1 + icou = fln_SR%icou_send(ineib_tmp) + fln_SR%item_send(icou) = inum + end do +! +!$omp parallel do private(icou,inum) + do icou = 1, fln_SR%ntot_send + inum = fln_SR%item_send(icou) +! + fln_SR%i8Send(1,icou) = fln_tce%iline_original(inum) +! + fln_SR%iSend(1,icou) = my_rank + fln_SR%iSend(2,icou) = fln_tce%iflag_direction(inum) + fln_SR%iSend(3,icou) = fln_tce%icount_fline(inum) + fln_SR%iSend(4:6,icou) = fln_tce%isf_dbl_start(1:3,inum) +! + fln_SR%rSend(1:4,icou) = fln_tce%xx_fline_start(1:4,inum) + fln_SR%rSend(5:8,icou) = fln_tce%v_fline_start(1:4,inum) + fln_SR%rSend(9,icou) = fln_tce%trace_length(inum) + fln_SR%rSend(9+1:fln_SR%ncomp_export,icou) & + & = fln_tce%c_fline_start(1:fln_SR%ncomp_export-9,inum) + end do +!$omp end parallel do +! + end subroutine set_trace_data_to_SR +! +! --------------------------------------------------------------------- +! + subroutine set_trace_data_from_SR(fln_SR, fln_prm, fln_tce) +! + use calypso_mpi_int + use t_tracing_data +! + type(trace_data_send_recv), intent(in) :: fln_SR + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_trace), intent(inout) :: fln_tce +! + integer(kind = kint) :: ip, i +! + fln_tce%num_current_fline = fln_SR%ntot_recv + call resize_line_start_fline(fln_tce%num_current_fline, & + & fln_prm%fline_fields, fln_tce) +! + fln_tce%istack_current_fline(0) = 0 + call calypso_mpi_allgather_one_int(fln_tce%num_current_fline, & + & fln_tce%istack_current_fline(1)) +! + do ip = 1, nprocs + fln_tce%istack_current_fline(ip) & + & = fln_tce%istack_current_fline(ip-1) & + & + fln_tce%istack_current_fline(ip) + end do + do i = 1, fln_SR%ntot_recv + fln_tce%iline_original(i) = fln_SR%i8Recv(1,i) +! + fln_tce%iflag_direction(i) = fln_SR%iRecv(2,i) + fln_tce%icount_fline(i) = fln_SR%iRecv(3,i) + fln_tce%isf_dbl_start(1:3,i) = fln_SR%iRecv(4:6,i) +! + fln_tce%xx_fline_start(1:4,i) = fln_SR%rRecv(1:4,i) + fln_tce%v_fline_start(1:4,i) = fln_SR%rRecv(5:8,i) + fln_tce%trace_length(i) = fln_SR%rRecv(9,i) + fln_tce%c_fline_start(1:fln_SR%ncomp_export-9,i) & + & = fln_SR%rRecv(9+1:fln_SR%ncomp_export,i) + end do +! + end subroutine set_trace_data_from_SR +! +! --------------------------------------------------------------------- +! + end module t_trace_data_send_recv + diff --git a/src/Fortran_libraries/VIZ_src/fieldline/t_tracing_data.f90 b/src/Fortran_libraries/VIZ_src/fieldline/t_tracing_data.f90 new file mode 100644 index 00000000..26b92c38 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/t_tracing_data.f90 @@ -0,0 +1,188 @@ +!>@file t_tracing_data.f90 +!!@brief module t_tracing_data +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structure of start point data for line tracing iteration +!! +!!@verbatim +!! subroutine alloc_num_gl_start_fline(num_pe, viz_fields, fln_tce) +!! subroutine alloc_line_start_fline(num_each_field_line, & +!! & viz_fields, fln_tce) +!! subroutine resize_line_start_fline(num_each_field_line, & +!! & viz_fields, fln_tce) +!! integer, intent(in) :: num_pe +!! integer(kind = kint), intent(in) :: num_each_field_line +!! type(ctl_params_viz_fields), intent(inout) :: viz_fields +!! subroutine copy_global_start_fline(i_copied, i_org, & +!! & viz_fields, fln_tce) +!! integer(kind = kint), intent(in) :: i_copied, i_org +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!! +!! subroutine dealloc_line_start_fline(fln_tce) +!! subroutine dealloc_num_gl_start_fline(fln_tce) +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!!@endverbatim +! + module t_tracing_data +! + use m_precision + use m_constants + use t_control_params_4_fline +! + implicit none +! + type each_fieldline_trace + integer(kind = kint) :: num_current_fline + integer(kind = kint), allocatable :: istack_current_fline(:) +! + integer(kind = kint) :: num_trace_buf + integer(kind= kint_gl), allocatable :: iline_original(:) + integer(kind= kint), allocatable :: iflag_direction(:) + integer(kind= kint), allocatable :: icount_fline(:) + integer(kind= kint), allocatable :: iflag_comm_start(:) + integer(kind= kint), allocatable :: isf_dbl_start(:,:) + real(kind = kreal), allocatable :: xx_fline_start(:,:) + real(kind = kreal), allocatable :: v_fline_start(:,:) + real(kind = kreal), allocatable :: c_fline_start(:,:) + real(kind = kreal), allocatable :: trace_length(:) + end type each_fieldline_trace +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_num_gl_start_fline(num_pe, viz_fields, fln_tce) +! + integer, intent(in) :: num_pe + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(each_fieldline_trace), intent(inout) :: fln_tce +! +! + allocate(fln_tce%istack_current_fline(0:num_pe)) + fln_tce%istack_current_fline = 0 + fln_tce%num_current_fline = 0 +! + call alloc_line_start_fline(ione, viz_fields, fln_tce) +! + end subroutine alloc_num_gl_start_fline +! +! --------------------------------------------------------------------- +! + subroutine alloc_line_start_fline(num_each_field_line, & + & viz_fields, fln_tce) +! + integer(kind = kint), intent(in) :: num_each_field_line + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(each_fieldline_trace), intent(inout) :: fln_tce +! + integer(kind = kint) :: num, i +! +! + fln_tce%num_trace_buf = 2 * num_each_field_line + allocate(fln_tce%iline_original(fln_tce%num_trace_buf)) + allocate(fln_tce%iflag_direction(fln_tce%num_trace_buf)) + allocate(fln_tce%iflag_comm_start(fln_tce%num_trace_buf)) + allocate(fln_tce%icount_fline(fln_tce%num_trace_buf)) + allocate(fln_tce%isf_dbl_start(3,fln_tce%num_trace_buf)) +! + do i = 1, fln_tce%num_trace_buf + fln_tce%iline_original(i) = i + end do +! + num = viz_fields%ntot_color_comp + allocate(fln_tce%xx_fline_start(4,fln_tce%num_trace_buf)) + allocate(fln_tce%v_fline_start(4,fln_tce%num_trace_buf)) + allocate(fln_tce%c_fline_start(num, fln_tce%num_trace_buf)) + allocate(fln_tce%trace_length(fln_tce%num_trace_buf)) +! +!$omp parallel workshare + fln_tce%iflag_direction = 0 + fln_tce%iflag_comm_start = 0 + fln_tce%icount_fline = 0 + fln_tce%isf_dbl_start = 0 + fln_tce%v_fline_start = 0.0d0 + fln_tce%c_fline_start = 0.0d0 + fln_tce%xx_fline_start = 0.0d0 + fln_tce%trace_length = 0.0d0 +!$omp end parallel workshare +! + end subroutine alloc_line_start_fline +! +! --------------------------------------------------------------------- +! + subroutine resize_line_start_fline(num_each_field_line, & + & viz_fields, fln_tce) + integer(kind = kint), intent(in) :: num_each_field_line + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(each_fieldline_trace), intent(inout) :: fln_tce +! + if(num_each_field_line .le. fln_tce%num_trace_buf) return +! write(*,*) 'change local number of lines for',num_each_field_line + call dealloc_line_start_fline(fln_tce) + call alloc_line_start_fline(num_each_field_line, & + & viz_fields, fln_tce) +! + end subroutine resize_line_start_fline +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine copy_global_start_fline(i_copied, i_org, & + & viz_fields, fln_tce) +! + use t_ctl_params_viz_fields +! + integer(kind = kint), intent(in) :: i_copied, i_org + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(each_fieldline_trace), intent(inout) :: fln_tce +! + fln_tce%xx_fline_start(1:4,i_copied) & + & = fln_tce%xx_fline_start(1:4,i_org) + fln_tce%v_fline_start(1:4,i_copied) & + & = fln_tce%v_fline_start(1:4,i_org) + fln_tce%c_fline_start(1:viz_fields%ntot_color_comp,i_copied) & + & = fln_tce%c_fline_start(1:viz_fields%ntot_color_comp,i_org) +! + end subroutine copy_global_start_fline +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dealloc_line_start_fline(fln_tce) +! + type(each_fieldline_trace), intent(inout) :: fln_tce +! +! + deallocate(fln_tce%iline_original) + deallocate(fln_tce%iflag_direction) + deallocate(fln_tce%iflag_comm_start) + deallocate(fln_tce%icount_fline) + deallocate(fln_tce%isf_dbl_start) + deallocate(fln_tce%xx_fline_start) + deallocate(fln_tce%v_fline_start) + deallocate(fln_tce%c_fline_start) + deallocate(fln_tce%trace_length) +! + end subroutine dealloc_line_start_fline +! +! --------------------------------------------------------------------- +! + subroutine dealloc_num_gl_start_fline(fln_tce) +! + type(each_fieldline_trace), intent(inout) :: fln_tce +! +! + call dealloc_line_start_fline(fln_tce) + + deallocate(fln_tce%istack_current_fline) +! + end subroutine dealloc_num_gl_start_fline +! +! --------------------------------------------------------------------- +! + end module t_tracing_data diff --git a/src/Fortran_libraries/VIZ_src/fieldline/trace_in_element.f90 b/src/Fortran_libraries/VIZ_src/fieldline/trace_in_element.f90 new file mode 100644 index 00000000..c782ea12 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/trace_in_element.f90 @@ -0,0 +1,208 @@ +!>@file trace_in_element.f90 +!! module trace_in_element +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief extend field line in each domain +!! +!!@verbatim +!! subroutine find_backside_by_flux(surf, iflag_dir, & +!! & v4_start, isurf_org) +!! integer(kind = kint), intent(in) :: iflag_dir +!! type(surface_data), intent(in) :: surf +!! real(kind = kreal), intent(in) :: v4_start(4) +!! integer(kind = kint), intent(inout) :: isurf_org(2) +!! subroutine check_exit_in_double_number(surf, para_surf, & +!! & isurf_org, isurf_org_dbl) +!! type(surface_data), intent(in) :: surf +!! type(paralell_surface_indices), intent(in) :: para_surf +!! integer(kind = kint), intent(in) :: isurf_org(2) +!! integer(kind = kint), intent(inout) :: isurf_org_dbl(3) +!! +!! subroutine trace_to_element_wall & +!! & (isf_org, iflag_dir, ele, surf, viz_fields, & +!! & x4_ele, v4_ele, c_ele, x4_start, v4_start, & +!! & isf_tgt_8, x4_tgt_8, v4_tgt_8, c_tgt_8) +!! integer(kind = kint), intent(in) :: isf_org +!! integer(kind = kint), intent(in) :: iflag_dir +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! real(kind = kreal), intent(in) :: x4_ele(4,ele%nnod_4_ele) +!! real(kind = kreal), intent(in) :: v4_ele(4,ele%nnod_4_ele) +!! real(kind = kreal), intent(in) & +!! & :: c_ele(viz_fields%ntot_org_comp, ele%nnod_4_ele) +!! real(kind = kreal), intent(in) :: x4_start(4) +!! real(kind = kreal), intent(in) :: v4_start(4) +!! integer(kind = kint), intent(inout) :: isf_tgt_8 +!! real(kind = kreal), intent(inout) :: x4_tgt_8(4) +!! real(kind = kreal), intent(inout) :: v4_tgt_8(4) +!! real(kind = kreal), intent(inout) & +!! & :: c_tgt_8(viz_fields%ntot_color_comp) +!! subroutine update_fline_position(ratio, ntot_color_comp, & +!! & x4_tgt, v4_tgt, c_tgt, & +!! & x4_start, v4_start, c_field) +!! real(kind = kreal), intent(in) :: ratio +!! integer(kind = kint), intent(in) :: ntot_color_comp +!! real(kind = kreal), intent(in) :: x4_tgt(4), v4_tgt(4) +!! real(kind = kreal), intent(in) :: c_tgt(ntot_color_comp) +!! real(kind = kreal), intent(inout) :: x4_start(4) +!! real(kind = kreal), intent(inout) :: v4_start(4) +!! real(kind = kreal), intent(inout) & +!! & :: c_field(ntot_color_comp) +!!@endverbatim +! + module trace_in_element +! + use m_precision +! + use m_constants + use m_geometry_constants + use calypso_mpi +! + use t_geometry_data + use t_surface_data + use t_phys_data + use t_ctl_params_viz_fields +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine find_backside_by_flux(surf, iflag_dir, & + & v4_start, isurf_org) +! + integer(kind = kint), intent(in) :: iflag_dir + type(surface_data), intent(in) :: surf + real(kind = kreal), intent(in) :: v4_start(4) +! + integer(kind = kint), intent(inout) :: isurf_org(2) +! + integer(kind = kint) :: isurf_sign, isurf_end + real(kind = kreal) :: flux +! +! + isurf_sign = surf%isf_4_ele(isurf_org(1),isurf_org(2)) + isurf_end = abs(isurf_sign) + flux = (v4_start(1) * surf%vnorm_surf(isurf_end,1) & + & + v4_start(2) * surf%vnorm_surf(isurf_end,2) & + & + v4_start(3) * surf%vnorm_surf(isurf_end,3)) & + & * dble(iflag_dir) * dble(isurf_end / isurf_sign) + + if(flux .lt. 0) return + if(isurf_sign .lt. 0) then + isurf_org(1:2) = surf%iele_4_surf(isurf_end,1,1:2) + else + isurf_org(1:2) = surf%iele_4_surf(isurf_end,2,1:2) + end if +! + end subroutine find_backside_by_flux +! +! --------------------------------------------------------------------- +! + subroutine check_exit_in_double_number(surf, para_surf, & + & isurf_org, isurf_org_dbl) +! + use t_parallel_surface_indices +! + type(surface_data), intent(in) :: surf + type(paralell_surface_indices), intent(in) :: para_surf + integer(kind = kint), intent(in) :: isurf_org(2) +! + integer(kind = kint), intent(inout) :: isurf_org_dbl(3) +! + integer(kind = kint) :: isurf_end +! +! + isurf_end = abs(surf%isf_4_ele(isurf_org(1),isurf_org(2))) + if(para_surf%isf_4_ele_dbl(isurf_org(1),isurf_org(2),2) & + & .lt. 0) then + isurf_org_dbl(1:3) & + & = para_surf%iele_4_surf_dbl(isurf_end,1,1:3) + else + isurf_org_dbl(1:3) & + & = para_surf%iele_4_surf_dbl(isurf_end,2,1:3) + end if +! + end subroutine check_exit_in_double_number +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine trace_to_element_wall & + & (isf_org, iflag_dir, ele, surf, viz_fields, & + & x4_ele, v4_ele, c_ele, x4_start, v4_start, & + & isf_tgt_8, x4_tgt_8, v4_tgt_8, c_tgt_8) +! + use cal_fline_in_cube + use set_fields_after_tracing +! + integer(kind = kint), intent(in) :: isf_org + integer(kind = kint), intent(in) :: iflag_dir +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(ctl_params_viz_fields), intent(in) :: viz_fields + real(kind = kreal), intent(in) :: x4_ele(4,ele%nnod_4_ele) + real(kind = kreal), intent(in) :: v4_ele(4,ele%nnod_4_ele) + real(kind = kreal), intent(in) & + & :: c_ele(viz_fields%ntot_org_comp, ele%nnod_4_ele) +! + real(kind = kreal), intent(in) :: x4_start(4) + real(kind = kreal), intent(in) :: v4_start(4) +! + integer(kind = kint), intent(inout) :: isf_tgt_8 + real(kind = kreal), intent(inout) :: x4_tgt_8(4) + real(kind = kreal), intent(inout) :: v4_tgt_8(4) + real(kind = kreal), intent(inout) & + & :: c_tgt_8(viz_fields%ntot_color_comp) +! + real(kind = kreal) :: xi_surf_8(2) +! + + call find_line_end_in_ele_8(iflag_dir, isf_org, & + & ele%nnod_4_ele, surf%nnod_4_surf, surf%node_on_sf, & + & v4_start, x4_start, x4_ele, isf_tgt_8, x4_tgt_8, xi_surf_8) +! + call fields_on_surf_from_one_ele & + & (isf_tgt_8, xi_surf_8, ele, surf, viz_fields, & + & v4_ele, c_ele, x4_tgt_8, v4_tgt_8, c_tgt_8) +! + end subroutine trace_to_element_wall +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine update_fline_position(ratio, ntot_color_comp, & + & x4_tgt, v4_tgt, c_tgt, & + & x4_start, v4_start, c_field) +! + real(kind = kreal), intent(in) :: ratio +! + integer(kind = kint), intent(in) :: ntot_color_comp + real(kind = kreal), intent(in) :: x4_tgt(4), v4_tgt(4) + real(kind = kreal), intent(in) :: c_tgt(ntot_color_comp) +! + real(kind = kreal), intent(inout) :: x4_start(4) + real(kind = kreal), intent(inout) :: v4_start(4) + real(kind = kreal), intent(inout) & + & :: c_field(ntot_color_comp) +! + x4_start(1:4) = ratio * x4_tgt(1:4) & + & + (one - ratio) * x4_start(1:4) + v4_start(1:4) = ratio * v4_tgt(1:4) & + & + (one - ratio) * v4_start(1:4) + c_field(1:ntot_color_comp) = ratio * c_tgt(1:ntot_color_comp) & + & + (one - ratio) * c_field(1:ntot_color_comp) +! + end subroutine update_fline_position +! +! --------------------------------------------------------------------- +! + end module trace_in_element + diff --git a/src/Fortran_libraries/VIZ_src/fieldline/trace_particle.f90 b/src/Fortran_libraries/VIZ_src/fieldline/trace_particle.f90 new file mode 100644 index 00000000..c87bff7e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/trace_particle.f90 @@ -0,0 +1,259 @@ +!>@file trace_particle.f90 +!!@brief module trace_particle +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Routines to construct field lines +!! +!!@verbatim +!! subroutine s_trace_particle(dt, elps_tracer, mesh, para_surf, & +!! & nod_fld, fln_prm, fln_tce, fline_lc, & +!! & fln_SR, fln_bcast, v_prev, m_SR) +!! real(kind = kreal), intent(in) :: dt +!! type(elapsed_lables), intent(in) :: elps_tracer +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(paralell_surface_indices), intent(in) :: para_surf +!! type(phys_data), intent(in) :: nod_fld +!! type(fieldline_paramter), intent(in) :: fln_prm +!! type(each_fieldline_trace), intent(inout) :: fln_tce +!! type(broadcast_trace_data), intent(inout) :: fln_bcast +!!@endverbatim +! + module trace_particle +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter + use m_geometry_constants + use m_work_time +! + use t_time_data + use t_mesh_data + use t_phys_data + use t_parallel_surface_indices + use t_tracing_data + use t_control_params_4_fline + use t_source_of_filed_line + use t_trace_data_send_recv + use t_broadcast_trace_data + use t_mesh_SR + use t_local_fline +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_trace_particle(dt, elps_tracer, mesh, para_surf, & + & nod_fld, fln_prm, fln_tce, fline_lc, & + & fln_SR, fln_bcast, v_prev, m_SR) +! + use transfer_to_long_integers + use trace_particle_in_element + use set_fline_seeds_from_list + use copy_field_smp +! + real(kind = kreal), intent(in) :: dt + type(elapsed_lables), intent(in) :: elps_tracer + type(mesh_geometry), intent(in) :: mesh + type(paralell_surface_indices), intent(in) :: para_surf + type(phys_data), intent(in) :: nod_fld + type(fieldline_paramter), intent(in) :: fln_prm +! + type(each_fieldline_trace), intent(inout) :: fln_tce + type(local_fieldline), intent(inout) :: fline_lc + type(trace_data_send_recv), intent(inout) :: fln_SR + type(broadcast_trace_data), intent(inout) :: fln_bcast + real(kind = kreal), intent(inout) :: v_prev(nod_fld%n_point,3) + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: nline, inum +! +! + call return_to_trace_list(fln_prm, fline_lc, fln_tce) + fln_tce%trace_length(1:fln_tce%num_current_fline) = 0.0d0 + + call reset_fline_start(fline_lc) + do + if(elps_tracer%flag_elapsed) & + & call start_elapsed_time(elps_tracer%ist_elapsed+1) + do inum = 1, fln_tce%num_current_fline + call s_trace_particle_in_element & + & (dt, mesh%node, mesh%ele, mesh%surf, para_surf, nod_fld, & + & v_prev, fln_prm%fline_fields, fln_prm%iphys_4_fline, & + & fln_prm%iflag_fline_used_ele, & + & fln_tce%isf_dbl_start(1,inum), & + & fln_tce%xx_fline_start(1,inum), & + & fln_tce%v_fline_start(1,inum), & + & fln_tce%c_fline_start(1,inum), & + & fln_tce%trace_length(inum), & + & fln_tce%iflag_comm_start(inum), inum) +! + if(fln_tce%iflag_comm_start(inum) .eq. -3) then + call set_field_at_each_seed_point(mesh%node, mesh%ele, & + & nod_fld, fln_prm%fline_fields, fln_prm%iphys_4_fline, & + & fln_tce%isf_dbl_start(2,inum), & + & fln_tce%xx_fline_start(1,inum), & + & fln_tce%v_fline_start(1,inum), & + & fln_tce%c_fline_start(1,inum)) + fln_tce%iflag_comm_start(inum) = 0 + end if +! + if(fln_tce%iflag_comm_start(inum) .eq. 0) then + call add_traced_list(fln_tce%iline_original(inum), & + & fln_tce%isf_dbl_start(1,inum), & + & fln_tce%xx_fline_start(1,inum), & + & fln_tce%v_fline_start(1,inum), & + & fln_prm%fline_fields%ntot_color_comp, & + & fln_tce%c_fline_start(1,inum), & + & fline_lc) + end if + end do + if(elps_tracer%flag_elapsed) & + & call end_elapsed_time(elps_tracer%ist_elapsed+1) +! + if(elps_tracer%flag_elapsed) & + & call start_elapsed_time(elps_tracer%ist_elapsed+2) + if(fln_prm%flag_use_broadcast) then + call s_broadcast_trace_data(fln_prm, fln_tce, & + & fln_bcast, nline) + else + call s_trace_data_send_recv(fln_prm, fln_tce, fln_SR, & + & m_SR%SR_sig, nline) + end if + if(elps_tracer%flag_elapsed) & + & call end_elapsed_time(elps_tracer%ist_elapsed+2) +! + if(nline .le. 0) exit + end do +! +!$omp parallel + call copy_nod_vector_smp(nod_fld%n_point, & + & nod_fld%d_fld(1,fln_prm%iphys_4_fline), v_prev) +!$omp end parallel +! + end subroutine s_trace_particle +! +! --------------------------------------------------------------------- +! + subroutine add_traced_list(iglobal_tracer, isf_dbl_start, & + & xx4_add, v4_add, ntot_comp, col_add, fline_lc) +! + integer(kind = kint_gl), intent(in) :: iglobal_tracer + integer(kind = kint), intent(in) :: isf_dbl_start(3) + real(kind = kreal), intent(in) :: xx4_add(4), v4_add(4) + integer(kind = kint), intent(in) :: ntot_comp + real(kind = kreal), intent(in) :: col_add(ntot_comp) + type(local_fieldline), intent(inout) :: fline_lc +! +! + fline_lc%nele_line_l = fline_lc%nele_line_l + 1 + fline_lc%nnod_line_l = fline_lc%nnod_line_l + 1 +! + if(fline_lc%nele_line_l .ge. fline_lc%nele_line_buf) then + call raise_local_fline_connect(fline_lc) + end if + if(fline_lc%nnod_line_l .ge. fline_lc%nnod_line_buf) then + call raise_local_fline_data(fline_lc) + end if +! + fline_lc%iedge_line_l(1,fline_lc%nele_line_l) = isf_dbl_start(2) + fline_lc%iedge_line_l(2,fline_lc%nele_line_l) = isf_dbl_start(3) +! + fline_lc%iglobal_fline(fline_lc%nnod_line_l) = iglobal_tracer + fline_lc%xx_line_l(1:3,fline_lc%nnod_line_l) = xx4_add(1:3) + fline_lc%v_line_l(1:3,fline_lc%nnod_line_l) = v4_add(1:3) + fline_lc%col_line_l(1:ntot_comp,fline_lc%nnod_line_l) & + & = col_add(1:ntot_comp) +! + end subroutine add_traced_list +! +! --------------------------------------------------------------------- +! + subroutine return_to_trace_list(fln_prm, fline_lc, fln_tce) +! + use calypso_mpi_int +! + type(fieldline_paramter), intent(in) :: fln_prm + type(local_fieldline), intent(in) :: fline_lc + type(each_fieldline_trace), intent(inout) :: fln_tce +! + integer(kind = kint) :: i, ip, ntot_comp +! + ntot_comp = fln_prm%fline_fields%ntot_color_comp + fln_tce%num_current_fline = fline_lc%nnod_line_l +! + fln_tce%istack_current_fline(0) = 0 + call calypso_mpi_allgather_one_int(fln_tce%num_current_fline, & + & fln_tce%istack_current_fline(1)) +! + do ip = 1, nprocs + fln_tce%istack_current_fline(ip) & + & = fln_tce%istack_current_fline(ip-1) & + & + fln_tce%istack_current_fline(ip) + end do +! +! + call resize_line_start_fline(fln_tce%num_current_fline, & + & fln_prm%fline_fields, fln_tce) +! + do i = 1, fln_tce%num_current_fline + fln_tce%iline_original(i) = fline_lc%iglobal_fline(i) + fln_tce%xx_fline_start(1:3,i) = fline_lc%xx_line_l(1:3,i) + fln_tce%v_fline_start(1:3,i) = fline_lc%v_line_l(1:3,i) + fln_tce%c_fline_start(1:ntot_comp,i) & + & = fline_lc%col_line_l(1:ntot_comp,i) + end do + do i = 1, fln_tce%num_current_fline + fln_tce%isf_dbl_start(1,i) = my_rank + fln_tce%isf_dbl_start(2:3,i) = fline_lc%iedge_line_l(1:2,i) + end do +! + end subroutine return_to_trace_list +! +! --------------------------------------------------------------------- +! + subroutine local_tracer_from_seeds(fln_prm, fln_tce, fline_lc) +! + type(fieldline_paramter), intent(in) :: fln_prm + type(each_fieldline_trace), intent(in) :: fln_tce + type(local_fieldline), intent(inout) :: fline_lc +! + integer(kind = kint) :: i, ntot_comp +! +! + ntot_comp = fln_prm%fline_fields%ntot_color_comp +! + fline_lc%nnod_line_l = fln_tce%num_current_fline + fline_lc%nele_line_l = fln_tce%num_current_fline + if(fline_lc%nele_line_l .ge. fline_lc%nele_line_buf) then + call raise_local_fline_connect(fline_lc) + end if + if(fline_lc%nnod_line_l .ge. fline_lc%nnod_line_buf) then + call raise_local_fline_data(fline_lc) + end if +! + do i = 1, fln_tce%num_current_fline + fline_lc%iglobal_fline(i) = fln_tce%iline_original(i) + fline_lc%xx_line_l(1:3,i) = fln_tce%xx_fline_start(1:3,i) + fline_lc%v_line_l(1:3,i) = fln_tce%v_fline_start(1:3,i) + fline_lc%col_line_l(1:ntot_comp,i) & + & = fln_tce%c_fline_start(1:ntot_comp,i) +! + fline_lc%iedge_line_l(1,i) = fln_tce%isf_dbl_start(2,i) + fline_lc%iedge_line_l(2,i) = fln_tce%isf_dbl_start(3,i) + end do +! + end subroutine local_tracer_from_seeds +! +! --------------------------------------------------------------------- +! + end module trace_particle diff --git a/src/Fortran_libraries/VIZ_src/fieldline/trace_particle_in_element.f90 b/src/Fortran_libraries/VIZ_src/fieldline/trace_particle_in_element.f90 new file mode 100644 index 00000000..c03dc1eb --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/trace_particle_in_element.f90 @@ -0,0 +1,276 @@ +!>@file trace_particle_in_element.f90 +!! module trace_particle_in_element +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief extend field line in each domain +!! +!!@verbatim +!! subroutine s_trace_particle_in_element(dt, node, ele, surf, & +!! & para_surf, nod_fld, v_prev, viz_fields, & +!! & i_tracer, iflag_used_ele, isurf_org_dbl, & +!! & x4_start, v4_start, c_field, progress, & +!! & iflag_comm, inum) +!! type(node_data), intent(in) :: node +!! type(surface_data), intent(in) :: surf +!! type(paralell_surface_indices), intent(in) :: para_surf +!! type(phys_data), intent(in) :: nod_fld +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! integer(kind = kint), intent(in) :: iflag_used_ele(ele%numele) +!! integer(kind = kint), intent(in) :: i_tracer +!! integer(kind = kint), intent(inout) :: isurf_org_dbl(3) +!! real(kind = kreal), intent(inout) :: v4_start(4), x4_start(4) +!! real(kind = kreal), intent(inout) & +!! & :: c_field(viz_fields%ntot_color_comp) +!! real(kind = kreal), intent(inout) :: progress +!! real(kind = kreal), intent(inout) :: dt +!! real(kind = kreal), intent(inout) :: v_prev(nod_fld%n_point,3) +!! integer(kind = kint), intent(inout) :: iflag_comm +!!@endverbatim +! + module trace_particle_in_element +! + use m_precision +! + use m_constants + use m_geometry_constants + use calypso_mpi +! + use t_geometry_data + use t_surface_data + use t_parallel_surface_indices + use t_phys_data + use t_ctl_params_viz_fields +! + implicit none +! + private s_trace_in_element, ratio_of_trace_to_wall_tracer +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_trace_particle_in_element(dt, node, ele, surf, & + & para_surf, nod_fld, v_prev, viz_fields, & + & i_tracer, iflag_used_ele, isurf_org_dbl, & + & x4_start, v4_start, c_field, progress, & + & iflag_comm, inum) +! + use t_local_fline + use t_control_params_4_fline + use trace_in_element + use set_fields_after_tracing +! + real(kind = kreal), intent(in) :: dt + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(paralell_surface_indices), intent(in) :: para_surf + type(phys_data), intent(in) :: nod_fld + type(ctl_params_viz_fields), intent(in) :: viz_fields + integer(kind = kint), intent(in) :: iflag_used_ele(ele%numele) + integer(kind = kint), intent(in) :: i_tracer + integer(kind = kint), intent(in) :: inum +! + integer(kind = kint), intent(inout) :: isurf_org_dbl(3) + real(kind = kreal), intent(inout) :: v4_start(4), x4_start(4) + real(kind = kreal), intent(inout) & + & :: c_field(viz_fields%ntot_color_comp) + real(kind = kreal), intent(inout) :: progress +! + real(kind = kreal), intent(inout) :: v_prev(nod_fld%n_point,3) + integer(kind = kint), intent(inout) :: iflag_comm +! + real(kind = kreal) :: v4_pre(4,ele%nnod_4_ele) + real(kind = kreal) :: x4_ele(4,ele%nnod_4_ele) + real(kind = kreal) :: v4_ele(4,ele%nnod_4_ele) + real(kind = kreal) & + & :: color_ele(viz_fields%ntot_org_comp, ele%nnod_4_ele) + integer(kind = kint) :: isurf_org(2) + integer(kind = kint) :: isf_tgt + integer(kind = kint) :: jcou + +! + if(isurf_org_dbl(2) .eq. 0) then + iflag_comm = 0 +! write(*,*) 'Exit at initial tracing', my_rank, inum + return + end if +! + isurf_org(1:2) = isurf_org_dbl(2:3) + if(isurf_org(2) .gt. 0) then + call find_backside_by_flux(surf, iflag_forward_trace, & + & v4_start, isurf_org) + end if +! + jcou = 0 + iflag_comm = 0 + do + jcou = jcou + 1 + call fline_vector_at_one_element(isurf_org(1), node, ele, & + & node%xx, x4_ele) + call fline_vector_at_one_element(isurf_org(1), node, ele, & + & v_prev, v4_pre) + call fline_vector_at_one_element(isurf_org(1), node, ele, & + & nod_fld%d_fld(1,i_tracer), v4_ele) + call fline_colors_at_one_element(isurf_org(1), ele, & + & nod_fld, viz_fields, color_ele) +! +! extend in the middle of element + call s_trace_in_element(half, dt, isurf_org(2), ele, surf, & + & viz_fields, x4_ele, v_prev, v4_ele, color_ele, & + & isf_tgt, x4_start, v4_start, c_field, progress) + if(isf_tgt .lt. 0) then + iflag_comm = isf_tgt + write(*,*) 'Trace stops by zero vector', my_rank, inum, & + & ' at ', jcou, ': ', isurf_org(1:2) + exit + end if +! +! extend to surface of element + call s_trace_in_element(one, dt, izero, ele, surf, & + & viz_fields, x4_ele, v_prev, v4_ele, color_ele, & + & isf_tgt, x4_start, v4_start, c_field, progress) + if(progress .ge. 1.0d0) then + iflag_comm = 0 +! write(*,*) 'Finish tracing', my_rank, inum + exit + end if + if(isf_tgt .lt. 0) then + iflag_comm = isf_tgt +! write(*,*) 'Trace stops by zero vector', my_rank, inum, & +! & ' at ', jcou, ': ', isurf_org(1:2) + exit + end if + + isurf_org(2) = isf_tgt + if(isurf_org(2) .gt. 0) then +! set backside element and surface + call check_exit_in_double_number(surf, para_surf, & + & isurf_org, isurf_org_dbl) + if(isurf_org_dbl(1) .ne. my_rank & + & .or. isurf_org_dbl(3) .eq. 0) then + iflag_comm = 1 +! write(*,*) 'Exit for external surface', my_rank, inum +! & ': ', isurf_org_dbl(1:3), ': ', & +! & para_surf%isf_4_ele_dbl(isurf_org(1),isurf_org(2),2) + exit + end if +! + call find_backside_by_flux(surf, iflag_forward_trace, & + & v4_start, isurf_org) + end if +! + if(iflag_used_ele(isurf_org(1)) .eq. 0) then +! isurf_org(2) = isf_tgt + iflag_comm = 1 +! write(*,*) 'Exit from tracing area', my_rank, inum + exit + end if + if(isurf_org(1) .eq. 0) then + iflag_comm = -2 +! write(*,*) 'Trace leaves from domain', my_rank, inum + exit + end if + end do +! + end subroutine s_trace_particle_in_element +! +! --------------------------------------------------------------------- +! + subroutine s_trace_in_element & + & (trace_ratio, dt, isf_org, ele, surf, viz_fields, & + & x4_ele, v4_pre, v4_ele, c_ele, & + & isf_tgt, x4_start, v4_start, c_field, progress) +! + use coordinate_converter + use convert_components_4_viz + use cal_field_on_surf_viz + use cal_fline_in_cube + use trace_in_element + use tracer_field_interpolate +! + real(kind = kreal), intent(in) :: trace_ratio + real(kind = kreal), intent(in) :: dt +! + integer(kind = kint), intent(in) :: isf_org + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(ctl_params_viz_fields), intent(in) :: viz_fields +! + real(kind = kreal), intent(in) :: x4_ele(4,ele%nnod_4_ele) + real(kind = kreal), intent(in) :: v4_pre(4,ele%nnod_4_ele) + real(kind = kreal), intent(in) :: v4_ele(4,ele%nnod_4_ele) + real(kind = kreal), intent(in) & + & :: c_ele(viz_fields%ntot_org_comp, ele%nnod_4_ele) +! + integer(kind = kint), intent(inout) :: isf_tgt + real(kind = kreal), intent(inout) :: x4_start(4) + real(kind = kreal), intent(inout) :: v4_start(4) + real(kind = kreal), intent(inout) & + & :: c_field(viz_fields%ntot_color_comp) + real(kind = kreal), intent(inout) :: progress +! + real(kind = kreal) :: v4_current_e(4,ele%nnod_4_ele) + real(kind = kreal) :: v4_tgt(4), x4_tgt(4) + real(kind = kreal) :: c_tgt(viz_fields%ntot_color_comp) + real(kind = kreal) :: ratio +! +! + if((v4_start(1)**2+v4_start(2)**2+v4_start(3)**2) .le. zero) then + isf_tgt = -3 + return + end if +! +!$omp parallel workshare + v4_current_e(1:4,1:ele%nnod_4_ele) & + & = (one - progress) * v4_pre(1:4,1:ele%nnod_4_ele) & + & + progress * v4_ele(1:4,1:ele%nnod_4_ele) +!$omp end parallel workshare +! + call trace_to_element_wall & + & (isf_org, iflag_forward_line, ele, surf, & + & viz_fields, x4_ele, v4_current_e, c_ele, x4_start, v4_start, & + & isf_tgt, x4_tgt, v4_tgt, c_tgt) +! + call ratio_of_trace_to_wall_tracer(trace_ratio, & + & v4_start, x4_tgt, x4_start, dt, ratio, progress) + call update_fline_position(ratio, viz_fields%ntot_color_comp, & + & x4_tgt, v4_tgt, c_tgt, & + & x4_start, v4_start, c_field) +! + end subroutine s_trace_in_element +! +! --------------------------------------------------------------------- +! + subroutine ratio_of_trace_to_wall_tracer(trace_ratio, & + & v4_start, x4_tgt, x4_start, dt, ratio, progress) + + real(kind = kreal), intent(in) :: x4_tgt(4), x4_start(4) + real(kind = kreal), intent(in) :: v4_start(4) + real(kind = kreal), intent(in) :: dt, trace_ratio + real(kind = kreal), intent(inout) :: ratio, progress +! + real(kind = kreal) :: trip, dl, actual +! + dl = dt * sqrt(v4_start(1) * v4_start(1) & + & + v4_start(2) * v4_start(2) & + & + v4_start(3) * v4_start(3)) & + & * (one - progress) + trip = sqrt((x4_tgt(1)-x4_start(1)) * (x4_tgt(1) - x4_start(1)) & + & + (x4_tgt(2)-x4_start(2)) * (x4_tgt(2) - x4_start(2)) & + & + (x4_tgt(3)-x4_start(3)) * (x4_tgt(3) - x4_start(3))) +! + actual = trace_ratio * min(trip, dl) + ratio = actual / trip + progress = progress + (one - progress) * actual / dl +! + end subroutine ratio_of_trace_to_wall_tracer +! +! --------------------------------------------------------------------- +! + end module trace_particle_in_element + diff --git a/src/Fortran_libraries/VIZ_src/fieldline/tracer_field_interpolate.f90 b/src/Fortran_libraries/VIZ_src/fieldline/tracer_field_interpolate.f90 new file mode 100644 index 00000000..50f95ea5 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/tracer_field_interpolate.f90 @@ -0,0 +1,252 @@ +!>@file tracer_field_interpolate.f90 +!! module tracer_field_interpolate +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief extend field line in each domain +!! +!!@verbatim +!! subroutine cal_xyz_fields_at_node(inod, nod_fld, & +!! & viz_fields, c_xyz) +!! integer(kind = kint), intent(in) :: inod +!! type(phys_data), intent(in) :: nod_fld +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! real(kind = kreal), intent(inout) & +!! & :: c_xyz(viz_fields%ntot_org_comp) +!! subroutine cal_fields_at_node(inod, node, nod_fld, & +!! & viz_fields, c_tgt) +!! integer(kind = kint), intent(in) :: inod +!! type(node_data), intent(in) :: node +!! type(phys_data), intent(in) :: nod_fld +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! real(kind = kreal), intent(inout) & +!! & :: c_tgt(viz_fields%ntot_color_comp) +!! subroutine cal_fields_on_line(isurf, xi_surf, xyz_surf, & +!! & surf, nod_fld, viz_fields, c_tgt) +!! integer(kind = kint), intent(in) :: isurf +!! real(kind = kreal), intent(in) :: xi_surf(2) +!! real(kind = kreal), intent(in) :: xyz_surf(3) +!! type(surface_data), intent(in) :: surf +!! type(phys_data), intent(in) :: nod_fld +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! real(kind = kreal), intent(inout) & +!! & :: c_tgt(viz_fields%ntot_color_comp) +!! subroutine cal_fields_in_element(iele, xi_cube, xyz, ele, & +!! & nod_fld, viz_fields, c_tgt) +!! integer(kind = kint), intent(in) :: iele(1) +!! real(kind = kreal), intent(in) :: xi_cube(3) +!! real(kind = kreal), intent(in) :: xyz(3) +!! type(element_data), intent(in) :: ele +!! type(phys_data), intent(in) :: nod_fld +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! real(kind = kreal), intent(inout) & +!! & :: c_tgt(viz_fields%ntot_color_comp) +!!@endverbatim +! + module tracer_field_interpolate +! + use m_precision +! + use m_constants + use m_geometry_constants + use calypso_mpi +! + use t_geometry_data + use t_surface_data + use t_phys_data + use t_ctl_params_viz_fields +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine cal_xyz_fields_at_node(inod, nod_fld, & + & viz_fields, c_xyz) +! + use coordinate_converter + use convert_components_4_viz +! + integer(kind = kint), intent(in) :: inod + type(phys_data), intent(in) :: nod_fld + type(ctl_params_viz_fields), intent(in) :: viz_fields +! + real(kind = kreal), intent(inout) & + & :: c_xyz(viz_fields%ntot_org_comp) +! + integer(kind = kint) :: inum, ifield, ist, jst, nd +! + do inum = 1, viz_fields%num_color_fields + ifield = viz_fields%ifleld_color_field(inum) + jst = viz_fields%istack_org_ncomp(inum-1) + if(ifield .le. 0) then + c_xyz(jst+1) = zero + else + ist = nod_fld%istack_component(ifield-1) + do nd = 1, viz_fields%ncomp_org_color_field(inum) + c_xyz(jst+nd) = nod_fld%d_fld(inod,ist+nd) + end do + end if + end do +! + end subroutine cal_xyz_fields_at_node +! +! --------------------------------------------------------------------- +! + subroutine cal_fields_at_node(inod, node, nod_fld, & + & viz_fields, c_tgt) +! + use coordinate_converter + use convert_components_4_viz +! + integer(kind = kint), intent(in) :: inod + type(node_data), intent(in) :: node + type(phys_data), intent(in) :: nod_fld + type(ctl_params_viz_fields), intent(in) :: viz_fields +! + real(kind = kreal), intent(inout) & + & :: c_tgt(viz_fields%ntot_color_comp) +! + real(kind = kreal) :: r(1), theta(1), phi(1) + real(kind = kreal) :: a_r(1), rs(1), a_rs(1) + real(kind = kreal) :: c_xyz(9) + integer(kind = kint), parameter :: istack_single(0:1) = (/0,1/) +! + integer(kind = kint) :: inum, ifield, ist, jst, nd +! + call position_2_sph(ione, node%xx(inod,1), r, theta, phi, & + & a_r, rs, a_rs ) + do inum = 1, viz_fields%num_color_fields + ifield = viz_fields%ifleld_color_field(inum) + if(ifield .le. 0) then + jst = viz_fields%istack_color_field(inum-1) + c_tgt(jst+1) = zero + else + ist = nod_fld%istack_component(ifield-1) + jst = viz_fields%istack_color_field(inum-1) + do nd = 1, viz_fields%ncomp_org_color_field(inum) + c_xyz(nd) = nod_fld%d_fld(inod,ist+nd) + end do + call convert_comps_4_viz & + & (ione, istack_single, node%xx(inod,1), r, a_r, rs, a_rs, & + & viz_fields%ncomp_color_field(inum), & + & viz_fields%ncomp_org_color_field(inum), & + & viz_fields%icomp_color_field(inum), & + & c_xyz(1), c_tgt(jst+1)) + end if + end do +! + end subroutine cal_fields_at_node +! +! --------------------------------------------------------------------- +! + subroutine cal_fields_on_line(isurf, xi_surf, xyz_surf, & + & surf, nod_fld, viz_fields, c_tgt) +! + use coordinate_converter + use convert_components_4_viz + use cal_field_on_surf_viz +! + integer(kind = kint), intent(in) :: isurf + real(kind = kreal), intent(in) :: xi_surf(2) + real(kind = kreal), intent(in) :: xyz_surf(3) + type(surface_data), intent(in) :: surf + type(phys_data), intent(in) :: nod_fld + type(ctl_params_viz_fields), intent(in) :: viz_fields +! + real(kind = kreal), intent(inout) & + & :: c_tgt(viz_fields%ntot_color_comp) +! + real(kind = kreal) :: r(1), theta(1), phi(1) + real(kind = kreal) :: a_r(1), rs(1), a_rs(1) + real(kind = kreal) :: c_xyz(9) + integer(kind = kint) :: istack_single(0:1) = (/0, 1/) +! + integer(kind = kint) :: inum, ifield, ist, jst, nd +! + call position_2_sph(ione, xyz_surf(1), r, theta, phi, & + & a_r, rs, a_rs ) + do inum = 1, viz_fields%num_color_fields + ifield = viz_fields%ifleld_color_field(inum) + if(ifield .le. 0) then + jst = viz_fields%istack_color_field(inum-1) + c_tgt(jst+1) = zero + else + ist = nod_fld%istack_component(ifield-1) + jst = viz_fields%istack_color_field(inum-1) + do nd = 1, viz_fields%ncomp_org_color_field(inum) + call cal_field_on_surf_scalar(nod_fld%n_point, & + & surf%numsurf, surf%nnod_4_surf, surf%ie_surf, & + & isurf, xi_surf, nod_fld%d_fld(1,ist+nd), c_xyz(nd)) + end do + call convert_comps_4_viz & + & (ione, istack_single, xyz_surf(1), r, a_r, rs, a_rs, & + & viz_fields%ncomp_color_field(inum), & + & viz_fields%ncomp_org_color_field(inum), & + & viz_fields%icomp_color_field(inum), & + & c_xyz(1), c_tgt(jst+1)) + end if + end do +! + end subroutine cal_fields_on_line +! +! --------------------------------------------------------------------- +! + subroutine cal_fields_in_element(iele, xi_cube, xyz, ele, & + & nod_fld, viz_fields, c_tgt) +! + use coordinate_converter + use convert_components_4_viz + use sel_interpolate_scalar +! + integer(kind = kint), intent(in) :: iele(1) + real(kind = kreal), intent(in) :: xi_cube(3) + real(kind = kreal), intent(in) :: xyz(3) + type(element_data), intent(in) :: ele + type(phys_data), intent(in) :: nod_fld + type(ctl_params_viz_fields), intent(in) :: viz_fields +! + real(kind = kreal), intent(inout) & + & :: c_tgt(viz_fields%ntot_color_comp) +! + real(kind = kreal) :: r(1), theta(1), phi(1) + real(kind = kreal) :: a_r(1), rs(1), a_rs(1) + real(kind = kreal) :: c_xyz(9) + integer(kind = kint), parameter :: istack_single(0:1) = (/0,1/) +! + integer(kind = kint) :: inum, ifield, ist, jst, nd +! + call position_2_sph(ione, xyz(1), r, theta, phi, & + & a_r, rs, a_rs ) + do inum = 1, viz_fields%num_color_fields + ifield = viz_fields%ifleld_color_field(inum) + if(ifield .le. 0) then + jst = viz_fields%istack_color_field(inum-1) + c_tgt(jst+1) = zero + else + ist = nod_fld%istack_component(ifield-1) + jst = viz_fields%istack_color_field(inum-1) + do nd = 1, viz_fields%ncomp_org_color_field(inum) + call sel_sgl_interpolate_scalar_ele & + & (nod_fld%n_point, ele%numele, ele%nnod_4_ele, ele%ie, & + & nod_fld%d_fld(1,ist+nd), iele(1), xi_cube, c_xyz(nd)) + end do + call convert_comps_4_viz & + & (ione, istack_single, xyz(1), r, a_r, rs, a_rs, & + & viz_fields%ncomp_color_field(inum), & + & viz_fields%ncomp_org_color_field(inum), & + & viz_fields%icomp_color_field(inum), & + & c_xyz(1), c_tgt(jst+1)) + end if + end do +! + end subroutine cal_fields_in_element +! +! --------------------------------------------------------------------- +! + end module tracer_field_interpolate + diff --git a/src/Fortran_libraries/VIZ_src/fieldline/tracer_restart_file_IO.f90 b/src/Fortran_libraries/VIZ_src/fieldline/tracer_restart_file_IO.f90 new file mode 100644 index 00000000..c6c53abd --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/fieldline/tracer_restart_file_IO.f90 @@ -0,0 +1,152 @@ +!>@file tracer_restart_file_IO.f90 +!!@brief module tracer_restart_file_IO +!! +!!@author H.Matsui +!!@date Programmed by H.Matsui in Apr., 2006 +! +!>@brief Choose mesh file to read +!! +!!@verbatim +!! subroutine output_tracer_restart(tracer_file_prm, istep_rst, & +!! & time_d, rst_step, viz_fields, fline_lc) +!! integer(kind = kint), intent(in) :: istep_rst +!! type(field_IO_params), intent(in) :: tracer_file_prm +!! type(time_data), intent(in) :: time_d +!! type(IO_step_param), intent(in) :: rst_step +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! type(local_fieldline), intent(inout) :: fline_lc +!! subroutine input_tracer_restart(tracer_file_prm, init_d, & +!! & rst_step, viz_fields, fline_lc) +!! type(field_IO_params), intent(in) :: tracer_file_prm +!! type(time_data), intent(inout) :: init_d +!! type(IO_step_param), intent(inout) :: rst_step +!! type(ctl_params_viz_fields), intent(in) :: viz_fields +!! type(local_fieldline), intent(inout) :: fline_lc +!!@endverbatim +! + module tracer_restart_file_IO +! + use m_precision + use t_time_data + use t_file_IO_parameter + use t_IO_step_parameter + use t_ctl_params_viz_fields + use t_local_fline + use t_read_mesh_data + use t_field_data_IO +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine output_tracer_restart(tracer_file_prm, istep_rst, & + & time_d, viz_fields, fline_lc) +! + use set_sph_restart_IO + use field_IO_select + use local_fline_restart_IO + use particle_MPI_IO_select + use local_fline_restart_IO + use const_global_element_ids +! + integer(kind = kint), intent(in) :: istep_rst + type(field_IO_params), intent(in) :: tracer_file_prm + type(time_data), intent(in) :: time_d + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(local_fieldline), intent(inout) :: fline_lc +! + type(surf_edge_IO_file) :: particle_IO + type(field_IO) :: fld_IO + type(time_data) :: time_IO +! +! + call copy_time_step_size_data(time_d, time_IO) + call copy_local_tracer_to_IO(fline_lc, particle_IO) + + call sel_mpi_write_particle_file(tracer_file_prm, istep_rst, & + & time_IO, particle_IO) + call dealloc_neib_id(particle_IO%comm) + call dealloc_surf_geometry_data(particle_IO) + call dealloc_ele_connect(particle_IO%ele) +! +! + if(viz_fields%num_color_fields .le. 1) return +! + call field_on_local_tracer_to_IO(viz_fields, fline_lc, fld_IO) +! + call alloc_merged_field_stack(nprocs, fld_IO) + call count_number_of_node_stack & + & (fld_IO%nnod_IO, fld_IO%istack_numnod_IO) +! + call sel_write_step_FEM_field_file & + & (istep_rst, tracer_file_prm, time_IO, fld_IO) +! + call dealloc_merged_field_stack(fld_IO) + call dealloc_phys_data_IO(fld_IO) + call dealloc_phys_name_IO(fld_IO) +! + end subroutine output_tracer_restart +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine input_tracer_restart(tracer_file_prm, istep_rst, & + & init_d, viz_fields, fline_lc) +! + use set_sph_restart_IO + use field_IO_select + use local_fline_restart_IO + use particle_MPI_IO_select +! + type(field_IO_params), intent(in) :: tracer_file_prm +! + integer(kind = kint), intent(in) :: istep_rst + type(time_data), intent(in) :: init_d + type(ctl_params_viz_fields), intent(in) :: viz_fields + type(local_fieldline), intent(inout) :: fline_lc +! + type(surf_edge_IO_file) :: particle_IO + type(time_data) :: time_IO + type(field_IO) :: fld_IO +! +! + call sel_mpi_read_particle_file(tracer_file_prm, istep_rst, & + & time_IO, particle_IO) + call copy_local_tracer_from_IO(particle_IO, fline_lc) + call dealloc_neib_id(particle_IO%comm) + call dealloc_ele_connect(particle_IO%ele) + call dealloc_surf_geometry_data(particle_IO) +! + if(viz_fields%num_color_fields .le. 1) return +! + call sel_read_alloc_step_SPH_file(nprocs, my_rank, & + & istep_rst, tracer_file_prm, time_IO, fld_IO) + call field_on_local_tracer_from_IO(fld_IO, viz_fields, fline_lc) + +! call copy_time_step_data(time_IO, init_d) + call dealloc_phys_data_IO(fld_IO) + call dealloc_phys_name_IO(fld_IO) +! + if(my_rank .ne. 0) return + if(init_d%i_time_step .ne. time_IO%i_time_step) then + write(*,*) 'Time step in particle restart does not match ', & + & 'with field restaart data. But ignore.' + end if + if(init_d%time .ne. time_IO%time) then + write(*,*) 'Time in particle restart does not match ', & + & 'with field restaart data. But ignore.' + end if + if(init_d%dt .ne. time_IO%dt) then + write(*,*) 'Delta t in particle restart does not match ', & + & 'with field restaart data. But ignore.' + end if +! + end subroutine input_tracer_restart +! +! ----------------------------------------------------------------------- +! + end module tracer_restart_file_IO diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/Makefile b/src/Fortran_libraries/VIZ_src/map_rendering/Makefile new file mode 100644 index 00000000..ccd89cdb --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/Makefile @@ -0,0 +1,41 @@ +# +# +# + +MAP_RENDERING_DIR = $$(VIZ_SRCDIR)/map_rendering +SOURCES = $(shell ls *.f90) +MOD_MAP = $(addsuffix .o,$(basename $(SOURCES)) ) + +# +# -------------------------------------------------------------------- +# + +dir_list: + @echo 'MAP_RENDERING_DIR = $(MAP_RENDERING_DIR)' >> $(MAKENAME) + +lib_name: + +lib_tasks: lib_archve + @echo ' ''$$(RANLIB) $$@' >> $(MAKENAME) + +libtarget: + +lib_archve: libtarget + @echo ' ''$$(AR)' '$$(ARFLUGS)' rcsv '$$@' '$$(MOD_MAP)' \ + >> $(MAKENAME) + + +mod_list: + @echo MOD_MAP= \\ >> $(MAKENAME) + @echo $(MOD_MAP) >> $(MAKENAME) + @echo >> $(MAKENAME) + + +module: + @cat Makefile.depends >> $(MAKENAME) + +depends: + @$(MAKE_MOD_DEP) Makefile.depends '$$(MAP_RENDERING_DIR)' $(SOURCES) + +clean: + rm -f *.o *.mod *~ *.par *.diag *.a diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/Makefile.depends b/src/Fortran_libraries/VIZ_src/map_rendering/Makefile.depends new file mode 100644 index 00000000..3caa903b --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/Makefile.depends @@ -0,0 +1,45 @@ +bcast_maps_control_data.o: $(MAP_RENDERING_DIR)/bcast_maps_control_data.f90 m_precision.o m_constants.o m_machine_parameter.o calypso_mpi.o t_control_data_maps.o t_control_data_4_map.o calypso_mpi_int.o calypso_mpi_char.o transfer_to_long_integers.o bcast_control_arrays.o bcast_ctl_data_pvr_surfaces.o bcast_ctl_data_view_trans.o bcast_pvr_color_ctl.o t_ctl_data_map_section.o bcast_section_control_data.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_data_map_rendering_IO.o: $(MAP_RENDERING_DIR)/ctl_data_map_rendering_IO.f90 m_precision.o m_constants.o m_machine_parameter.o skip_comment_f.o t_read_control_elements.o t_control_array_real.o t_control_array_character.o t_control_array_charareal.o t_control_data_4_map.o t_ctl_data_pvr_section.o calypso_mpi.o t_ctl_data_pvr_colormap_bar.o ctl_file_pvr_modelview_IO.o ctl_data_map_section_IO.o ctl_data_view_transfer_IO.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_data_map_section_IO.o: $(MAP_RENDERING_DIR)/ctl_data_map_section_IO.f90 m_precision.o calypso_mpi.o m_machine_parameter.o t_read_control_elements.o t_control_data_4_psf_def.o t_control_array_real.o t_control_array_real2.o t_control_array_character.o t_ctl_data_map_section.o skip_comment_f.o ctl_file_section_def_IO.o write_control_elements.o ctl_data_section_def_IO.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_file_map_renderings_IO.o: $(MAP_RENDERING_DIR)/ctl_file_map_renderings_IO.f90 m_precision.o m_machine_parameter.o t_control_data_4_map.o t_control_data_maps.o t_read_control_elements.o ctl_data_section_IO.o skip_comment_f.o write_control_elements.o ctl_data_map_rendering_IO.o + $(F90) -c $(F90OPTFLAGS) $< +draw_aitoff_map.o: $(MAP_RENDERING_DIR)/draw_aitoff_map.f90 m_precision.o m_constants.o t_geometry_data.o t_phys_data.o t_pvr_image_array.o t_map_rendering_data.o t_map_patch_from_1patch.o map_patch_from_1patch.o draw_pixels_on_map.o set_color_4_pvr.o draw_isoline_in_triangle.o + $(F90) -c $(F90OPTFLAGS) $< +draw_isoline_in_triangle.o: $(MAP_RENDERING_DIR)/draw_isoline_in_triangle.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +draw_lines_on_map.o: $(MAP_RENDERING_DIR)/draw_lines_on_map.f90 m_precision.o m_constants.o t_geometry_data.o t_map_patch_from_1patch.o t_map_rendering_data.o t_pvr_image_array.o draw_xyz_plane_isolines.o draw_aitoff_map.o + $(F90) -c $(F90OPTFLAGS) $< +draw_pixels_on_map.o: $(MAP_RENDERING_DIR)/draw_pixels_on_map.f90 m_precision.o m_constants.o m_geometry_constants.o t_pvr_colormap_parameter.o set_color_4_pvr.o + $(F90) -c $(F90OPTFLAGS) $< +draw_xyz_plane_isolines.o: $(MAP_RENDERING_DIR)/draw_xyz_plane_isolines.f90 m_precision.o m_constants.o t_geometry_data.o t_phys_data.o t_map_rendering_data.o t_map_patch_from_1patch.o t_pvr_colormap_parameter.o t_pvr_image_array.o set_color_4_pvr.o draw_pixels_on_map.o set_xyz_plot_from_1patch.o draw_isoline_in_triangle.o + $(F90) -c $(F90OPTFLAGS) $< +map_patch_from_1patch.o: $(MAP_RENDERING_DIR)/map_patch_from_1patch.f90 m_precision.o m_constants.o m_phys_constants.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +map_projection.o: $(MAP_RENDERING_DIR)/map_projection.f90 m_precision.o m_work_time.o calypso_mpi.o t_map_projection.o m_geometry_constants.o set_map_control.o search_ele_list_for_psf.o set_const_4_sections.o find_node_and_patch_psf.o set_fields_for_psf.o multi_map_projections.o set_ucd_data_to_type.o + $(F90) -c $(F90OPTFLAGS) $< +multi_map_projections.o: $(MAP_RENDERING_DIR)/multi_map_projections.f90 calypso_mpi.o m_precision.o t_geometry_data.o t_phys_data.o t_solver_SR.o t_control_params_4_pvr.o t_pvr_colormap_parameter.o t_map_rendering_data.o m_work_time.o t_psf_patch_data.o t_psf_results.o t_pvr_image_array.o collect_psf_mesh_field.o xyz_plane_rendering.o write_PVR_image.o + $(F90) -c $(F90OPTFLAGS) $< +set_map_control.o: $(MAP_RENDERING_DIR)/set_map_control.f90 m_precision.o m_machine_parameter.o t_mesh_data.o t_phys_data.o t_control_data_maps.o t_control_data_4_map.o t_control_params_4_psf.o t_psf_patch_data.o t_control_params_4_pvr.o t_pvr_colormap_parameter.o t_map_rendering_data.o t_pvr_image_array.o calypso_mpi.o t_read_control_elements.o set_field_comp_for_viz.o mpi_abort_by_missing_zlib.o set_psf_control.o m_error_IDs.o m_file_format_switch.o set_area_4_viz.o set_sections_file_ctl.o delete_data_files.o skip_comment_f.o set_pvr_modelview_matrix.o set_control_pvr_color.o t_control_array_character.o output_image_sel_4_png.o + $(F90) -c $(F90OPTFLAGS) $< +set_scalar_on_xyz_plane.o: $(MAP_RENDERING_DIR)/set_scalar_on_xyz_plane.f90 m_precision.o m_constants.o t_geometry_data.o t_phys_data.o t_map_rendering_data.o t_map_patch_from_1patch.o t_pvr_colormap_parameter.o t_pvr_image_array.o draw_pixels_on_map.o set_xyz_plot_from_1patch.o map_patch_from_1patch.o + $(F90) -c $(F90OPTFLAGS) $< +set_xyz_plot_from_1patch.o: $(MAP_RENDERING_DIR)/set_xyz_plot_from_1patch.f90 m_precision.o m_constants.o t_geometry_data.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_data_4_map.o: $(MAP_RENDERING_DIR)/t_control_data_4_map.f90 m_precision.o m_constants.o m_machine_parameter.o skip_comment_f.o t_read_control_elements.o t_control_array_character.o t_ctl_data_map_section.o t_ctl_data_4_view_transfer.o t_ctl_data_pvr_colormap_bar.o t_control_array_character3.o add_nodal_fields_ctl.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_data_maps.o: $(MAP_RENDERING_DIR)/t_control_data_maps.f90 m_precision.o m_machine_parameter.o t_control_data_4_map.o ctl_data_map_rendering_IO.o t_control_array_character3.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_map_section.o: $(MAP_RENDERING_DIR)/t_ctl_data_map_section.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_data_4_psf_def.o t_control_array_real.o t_control_array_real2.o t_control_array_integer.o t_control_array_character.o t_control_array_chara2real.o skip_comment_f.o + $(F90) -c $(F90OPTFLAGS) $< +t_map_patch_from_1patch.o: $(MAP_RENDERING_DIR)/t_map_patch_from_1patch.f90 m_precision.o m_constants.o m_phys_constants.o m_geometry_constants.o coordinate_converter.o aitoff.o + $(F90) -c $(F90OPTFLAGS) $< +t_map_projection.o: $(MAP_RENDERING_DIR)/t_map_projection.f90 calypso_mpi.o m_precision.o t_cross_section.o t_psf_results.o t_control_data_maps.o t_control_params_4_pvr.o t_pvr_colormap_parameter.o t_pvr_image_array.o t_map_rendering_data.o m_field_file_format.o set_map_control.o set_psf_control.o set_fields_for_psf.o find_node_and_patch_psf.o + $(F90) -c $(F90OPTFLAGS) $< +t_map_rendering_data.o: $(MAP_RENDERING_DIR)/t_map_rendering_data.f90 calypso_mpi.o m_precision.o m_machine_parameter.o t_geometry_data.o t_phys_data.o t_control_params_4_pvr.o t_pvr_colormap_parameter.o t_control_array_character.o t_ctl_data_map_section.o t_ctl_data_4_projection.o skip_comment_f.o t_psf_patch_data.o t_pvr_image_array.o + $(F90) -c $(F90OPTFLAGS) $< +xyz_plane_rendering.o: $(MAP_RENDERING_DIR)/xyz_plane_rendering.f90 m_precision.o m_constants.o t_psf_patch_data.o t_time_data.o t_file_IO_parameter.o t_map_patch_from_1patch.o t_pvr_image_array.o t_map_rendering_data.o set_ucd_data_to_type.o ucd_IO_select.o draw_aitoff_map.o draw_lines_on_map.o draw_pvr_colorbar.o draw_pixels_on_map.o set_scalar_on_xyz_plane.o draw_xyz_plane_isolines.o cal_mesh_position.o + $(F90) -c $(F90OPTFLAGS) $< + diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/bcast_maps_control_data.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/bcast_maps_control_data.f90 new file mode 100644 index 00000000..ac3f9e23 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/bcast_maps_control_data.f90 @@ -0,0 +1,136 @@ +!>@file bcast_maps_control_data.f90 +!!@brief module bcast_maps_control_data +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief control ID data for surfacing module +!! +!!@verbatim +!! subroutine bcast_files_4_map_ctl(map_ctls) +!! type(map_rendering_controls), intent(inout) :: map_ctls +!!@endverbatim +! + module bcast_maps_control_data +! + use m_precision +! + use m_constants + use m_machine_parameter + use calypso_mpi +! + implicit none +! + private :: bcast_map_control_data, bcast_map_section_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine bcast_files_4_map_ctl(map_ctls) +! + use t_control_data_maps + use t_control_data_4_map + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(map_rendering_controls), intent(inout) :: map_ctls + integer (kind=kint) :: i_map +! +! + call calypso_mpi_bcast_character(map_ctls%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(map_ctls%num_map_ctl, 0) + if(map_ctls%num_map_ctl .le. 0) return +! + if(my_rank .gt. 0) call alloc_map_ctl_stract(map_ctls) +! + do i_map = 1, map_ctls%num_map_ctl + call bcast_map_control_data(map_ctls%map_ctl_struct(i_map)) + end do + call calypso_mpi_bcast_character(map_ctls%fname_map_ctl, & + & cast_long(map_ctls%num_map_ctl*kchara), 0) +! + end subroutine bcast_files_4_map_ctl +! +! -------------------------------------------------------------------- +! -------------------------------------------------------------------- +! + subroutine bcast_map_control_data(map_c) +! + use t_control_data_4_map + use calypso_mpi_int + use calypso_mpi_char + use bcast_control_arrays + use bcast_ctl_data_pvr_surfaces + use bcast_ctl_data_view_trans + use bcast_pvr_color_ctl + use transfer_to_long_integers +! + type(map_ctl), intent(inout) :: map_c +! +! + call calypso_mpi_bcast_character(map_c%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(map_c%i_map_ctl, 0) + call calypso_mpi_bcast_one_int(map_c%i_output_field, 0) + call calypso_mpi_bcast_character(map_c%fname_mat_ctl, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_character(map_c%fname_cmap_cbar_c, & + & cast_long(kchara), 0) +! + call bcast_view_transfer_ctl(map_c%mat) + call bcast_pvr_colorbar_ctl(map_c%cmap_cbar_c%cbar_ctl) + call bcast_pvr_colordef_ctl(map_c%cmap_cbar_c%color) + call bcast_map_section_ctl(map_c%map_define_ctl) +! + call bcast_ctl_type_c1(map_c%map_image_prefix_ctl) + call bcast_ctl_type_c1(map_c%map_image_fmt_ctl) + call bcast_ctl_type_c1(map_c%map_field_ctl) + call bcast_ctl_type_c1(map_c%map_comp_ctl) + call bcast_ctl_type_c1(map_c%isoline_field_ctl) + call bcast_ctl_type_c1(map_c%isoline_comp_ctl) +! + end subroutine bcast_map_control_data +! +! -------------------------------------------------------------------- +! + subroutine bcast_map_section_ctl(map_sect_ctl) +! + use t_ctl_data_map_section + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers + use bcast_control_arrays + use bcast_section_control_data +! + type(map_section_ctl), intent(inout) :: map_sect_ctl +! +! + call calypso_mpi_bcast_one_int(map_sect_ctl%i_map_sect_ctl, 0) + call calypso_mpi_bcast_character & + & (map_sect_ctl%block_name, cast_long(kchara), 0) + call calypso_mpi_bcast_character & + & (map_sect_ctl%fname_sect_ctl, cast_long(kchara), 0) +! + call bcast_section_def_control(map_sect_ctl%psf_def_c) +! + call bcast_ctl_type_c1(map_sect_ctl%zeroline_switch_ctl) + call bcast_ctl_type_c1(map_sect_ctl%isoline_color_mode) + call bcast_ctl_type_i1(map_sect_ctl%isoline_number_ctl) + call bcast_ctl_type_r2(map_sect_ctl%isoline_range_ctl) + call bcast_ctl_type_r1(map_sect_ctl%isoline_width_ctl) + call bcast_ctl_type_r1(map_sect_ctl%grid_width_ctl) +! + call bcast_ctl_type_c1(map_sect_ctl%tan_cyl_switch_ctl) + call bcast_ctl_type_r1(map_sect_ctl%tangent_cylinder_inner_ctl) + call bcast_ctl_type_r1(map_sect_ctl%tangent_cylinder_outer_ctl) +! + end subroutine bcast_map_section_ctl +! +! ----------------------------------------------------------------------- +! + end module bcast_maps_control_data diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/ctl_data_map_rendering_IO.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/ctl_data_map_rendering_IO.f90 new file mode 100644 index 00000000..bad96fd4 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/ctl_data_map_rendering_IO.f90 @@ -0,0 +1,344 @@ +!>@file ctl_data_map_rendering_IO.f90 +!!@brief module ctl_data_map_rendering_IO +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief control ID data for surfacing module +!! +!!@verbatim +!! subroutine init_map_control_label(hd_block, map_c) +!! subroutine s_read_map_control_data & +!! & (id_control, hd_block, map_c, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(map_ctl), intent(inout) :: map_c +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_map_control_data & +!! & (id_control, hd_block, map_c, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(map_ctl), intent(inout) :: map_c +!! integer(kind = kint), intent(inout) :: level +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! example of control for Kemo's surface rendering +!! +!! begin cross_section_ctl +!! map_image_prefix 'map' +!! map_image_format PNG +!! +!! output_field magnetic_field +!! output_component r +!! +!! isoline_field magnetic_field +!! isoline_component r +!! +!! begin section_ctl +!! file surface_define ctl_psf_eq +!! begin surface_define +!! ... +!! end surface_define +!! +!! zeroline_switch_ctl On +!! isoline_color_mode color, white, or black +!! isoline_number_ctl 20 +!! isoline_range_ctl -0.5 0.5 +!! isoline_width_ctl 1.5 +!! grid_width_ctl 1.0 +!! +!! tangent_cylinder_switch_ctl On +!! inner_radius_ctl 0.53846 +!! outer_radius_ctl 1.53846 +!! end section_ctl +!! +!! begin map_projection_ctl +!! begin image_size_ctl +!! x_pixel_ctl 640 +!! y_pixel_ctl 480 +!! end image_size_ctl +!! +!! begin projection_matrix_ctl +!! perspective_xy_ratio_ctl 1.0 +!! horizontal_range_ctl -2.4 2.4 +!! vertical_range_ctl -1.2 1.2 +!! end projection_matrix_ctl +!! end map_projection_ctl +!! +!! file map_color_ctl 'ctl_color_Br' +!! begin colormap_ctl +!! colormap_mode_ctl rainbow +!! background_color_ctl 0.0 0.0 0.0 +!! +!! data_mapping_ctl Colormap_list +!! array color_table_ctl +!! color_table_ctl 0.0 0.0 +!! color_table_ctl 0.5 0.5 +!! color_table_ctl 1.0 1.0 +!! end array color_table_ctl +!! end colormap_ctl +!! +!! begin colorbar_ctl +!! colorbar_switch_ctl ON +!! colorbar_position_ctl 'left' or 'bottom' +!! colorbar_scale_ctl ON +!! zeromarker_switch ON +!! colorbar_range 0.0 1.0 +!! font_size_ctl 3 +!! num_grid_ctl 4 +!!! +!! axis_label_switch ON +!! end colorbar_ctl +!! end cross_section_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! map_image_format: +!! BMP, png +!! +!! num_result_comp: number of fields +!! output_field: (Original name: color_comp and color_subcomp) +!! field and componenet name for output +!! x, y, z, radial, elevation, azimuth, cylinder_r, norm +!! vector, sym_tensor, asym_tensor +!! spherical_vector, cylindrical_vector +!! output_value: (Original name: specified_color) +!! +!! section_method: (original: method) +!! plane, sphere, ellipsoid, hyperboloid, paraboloid +!! equation, group +!! normal_vector: normal vector (for plane) +!! array normal_vector 3 +!! normal_vector x 0.0 +!! normal_vector y 0.0 +!! normal_vector z 1.0 +!! end array normal_vector +!! center_position: position of center (for sphere and plane) +!! array center_position 3 +!! center_position x 0.0 +!! center_position y 0.0 +!! center_position z 0.0 +!! end array center_position +!! radius: radius of sphere +!! axial_length: length of axis +!! (for ellipsoid, hyperboloid, paraboloid) +!! array axial_length 3 +!! axial_length x 1.0 +!! axial_length y 0.5 +!! axial_length z 0.0 +!! end array axial_length +!! coefficients: coefficients for equation +!! array coefs_ctl 10 +!! coefs_ctl x2 1.0 +!! coefs_ctl y2 0.5 +!! coefs_ctl z2 0.0 +!! coefs_ctl xy 1.0 +!! coefs_ctl yz 0.5 +!! coefs_ctl zx 0.0 +!! coefs_ctl x 1.0 +!! coefs_ctl y 0.5 +!! coefs_ctl z 0.0 +!! coefs_ctl const 1.0 +!! end array coefs_ctl +!! group_type: (Original: defined_style) +!! node_group or surface_group +!! group_name: name of group to plot +!! +!! field type: +!! scalar, vector, sym_tensor, asym_tensor +!! spherical_vector, spherical_sym_tensor +!! cylindrical_vector, cylindrical_sym_tensor +!! norm +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module ctl_data_map_rendering_IO +! + use m_precision +! + use m_constants + use m_machine_parameter + use skip_comment_f + use t_read_control_elements + use t_control_array_real + use t_control_array_character + use t_control_array_charareal + use t_control_data_4_map + use t_ctl_data_pvr_section + use calypso_mpi +! + implicit none +! +! 2nd level for cross_section_ctl + character(len=kchara), parameter, private & + & :: hd_map_image_prefix = 'map_image_prefix' + character(len=kchara), parameter, private & + & :: hd_map_image_format = 'map_image_format' + character(len=kchara), parameter, private & + & :: hd_section_ctl = 'section_ctl' +! + character(len=kchara), parameter, private & + & :: hd_map_output_field = 'output_field' + character(len=kchara), parameter, private & + & :: hd_map_output_comp = 'output_component' + character(len=kchara), parameter, private & + & :: hd_map_isoline_field = 'isoline_field' + character(len=kchara), parameter, private & + & :: hd_map_isoline_comp = 'isoline_component' +! + character(len=kchara), parameter, private & + & :: hd_map_projection = 'map_projection_ctl' + character(len=kchara), parameter, private & + & :: hd_map_colormap_file = 'map_color_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_read_map_control_data & + & (id_control, hd_block, map_c, c_buf) +! + use t_ctl_data_pvr_colormap_bar + use ctl_file_pvr_modelview_IO + use ctl_data_map_section_IO + use ctl_data_view_transfer_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(map_ctl), intent(inout) :: map_c + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(map_c%i_map_ctl .gt. 0) return + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call sel_read_ctl_modelview_file(id_control, hd_map_projection, & + & izero, map_c%fname_mat_ctl, map_c%mat, c_buf) + call sel_read_ctl_pvr_colormap_file & + & (id_control, hd_map_colormap_file, map_c%fname_cmap_cbar_c, & + & map_c%cmap_cbar_c, c_buf) +! + call read_map_section_ctl(id_control, hd_section_ctl, & + & izero, map_c%map_define_ctl, c_buf) +! + call read_chara_ctl_type(c_buf, hd_map_image_prefix, & + & map_c%map_image_prefix_ctl) + call read_chara_ctl_type(c_buf, hd_map_image_format, & + & map_c%map_image_fmt_ctl) +! + call read_chara_ctl_type(c_buf, hd_map_output_field, & + & map_c%map_field_ctl) + call read_chara_ctl_type(c_buf, hd_map_output_comp, & + & map_c%map_comp_ctl) +! + call read_chara_ctl_type(c_buf, hd_map_isoline_field, & + & map_c%isoline_field_ctl) + call read_chara_ctl_type(c_buf, hd_map_isoline_comp, & + & map_c%isoline_comp_ctl) + end do + map_c%i_map_ctl = 1 +! + end subroutine s_read_map_control_data +! +! -------------------------------------------------------------------- +! + subroutine write_map_control_data & + & (id_control, hd_block, map_c, level) +! + use t_ctl_data_pvr_colormap_bar + use ctl_file_pvr_modelview_IO + use ctl_data_map_section_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(map_ctl), intent(in) :: map_c +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(map_c%i_map_ctl .le. 0) return +! + maxlen = len_trim(hd_map_image_prefix) + maxlen = max(maxlen, len_trim(hd_map_image_format)) + maxlen = max(maxlen, len_trim(hd_map_output_field)) + maxlen = max(maxlen, len_trim(hd_map_output_comp)) + maxlen = max(maxlen, len_trim(hd_map_isoline_field)) + maxlen = max(maxlen, len_trim(hd_map_isoline_comp)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_chara_ctl_type(id_control, level, maxlen, & + & map_c%map_image_prefix_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & map_c%map_image_fmt_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & map_c%map_field_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & map_c%map_comp_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & map_c%isoline_field_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & map_c%isoline_comp_ctl) +! + call write_map_section_ctl(id_control, map_c%map_define_ctl, & + & level) +! + call sel_write_ctl_modelview_file(id_control, hd_map_projection, & + & map_c%fname_mat_ctl, map_c%mat, level) + call sel_write_ctl_pvr_colormap_file & + & (id_control, hd_map_colormap_file, map_c%fname_cmap_cbar_c, & + & map_c%cmap_cbar_c, level) +! + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_map_control_data +! +! -------------------------------------------------------------------- +! + subroutine init_map_control_label(hd_block, map_c) +! + use t_ctl_data_pvr_colormap_bar + use ctl_file_pvr_modelview_IO + use ctl_data_view_transfer_IO + use ctl_data_map_section_IO +! + character(len=kchara), intent(in) :: hd_block + type(map_ctl), intent(inout) :: map_c +! +! + map_c%block_name = hd_block + call init_map_section_ctl_label(hd_section_ctl, & + & map_c%map_define_ctl) + call init_pvr_cmap_cbar_label(hd_map_colormap_file, & + & map_c%cmap_cbar_c) + call init_view_transfer_ctl_label(hd_map_projection, map_c%mat) +! + call init_chara_ctl_item_label(hd_map_image_prefix, & + & map_c%map_image_prefix_ctl) + call init_chara_ctl_item_label(hd_map_image_format, & + & map_c%map_image_fmt_ctl) +! + call init_chara_ctl_item_label(hd_map_output_field, & + & map_c%map_field_ctl) + call init_chara_ctl_item_label(hd_map_output_comp, & + & map_c%map_comp_ctl) +! + call init_chara_ctl_item_label(hd_map_isoline_field, & + & map_c%isoline_field_ctl) + call init_chara_ctl_item_label(hd_map_isoline_comp, & + & map_c%isoline_comp_ctl) +! + end subroutine init_map_control_label +! +! -------------------------------------------------------------------- +! + end module ctl_data_map_rendering_IO diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/ctl_data_map_section_IO.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/ctl_data_map_section_IO.f90 new file mode 100644 index 00000000..d2d315d4 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/ctl_data_map_section_IO.f90 @@ -0,0 +1,234 @@ +!>@file ctl_data_map_section_IO.f90 +!!@brief module ctl_data_map_section_IO +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for parallel volume rendering +!! +!!@verbatim +!! subroutine init_map_section_ctl_label(hd_block, map_sect_ctl) +!! subroutine read_map_section_ctl & +!! & (id_control, hd_block, icou, map_sect_ctl, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(map_section_ctl), intent(inout) :: map_sect_ctl +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_map_section_ctl & +!! & (id_control, map_sect_ctl, level) +!! integer(kind = kint), intent(in) :: id_control +!! type(map_section_ctl), intent(inout) :: map_sect_ctl +!! integer(kind = kint), intent(inout) :: level +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! begin section_ctl +!! file surface_define ctl_psf_eq +!! begin surface_define +!! ... +!! end surface_define +!! +!! zeroline_switch_ctl On +!! isoline_color_mode color, white, or black +!! isoline_number_ctl 20 +!! isoline_range_ctl -0.5 0.5 +!! isoline_width_ctl 1.5 +!! grid_width_ctl 1.0 +!! +!! tangent_cylinder_switch_ctl On +!! inner_radius_ctl 0.53846 +!! outer_radius_ctl 1.53846 +!! end section_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module ctl_data_map_section_IO +! + use m_precision + use calypso_mpi +! + use m_machine_parameter + use t_read_control_elements + use t_control_data_4_psf_def + use t_control_array_real + use t_control_array_real2 + use t_control_array_character + use t_ctl_data_map_section + use skip_comment_f +! + implicit none +! +! Labels + character(len=kchara), parameter, private & + & :: hd_surface_define = 'surface_define' +! + character(len=kchara), parameter, private & + & :: hd_pvr_sec_zeroline = 'zeroline_switch_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_isoline_color = 'isoline_color_mode' + character(len=kchara), parameter, private & + & :: hd_isoline_number = 'isoline_number_ctl' + character(len=kchara), parameter, private & + & :: hd_isoline_range = 'isoline_range_ctl' + character(len=kchara), parameter, private & + & :: hd_isoline_width = 'isoline_width_ctl' + character(len=kchara), parameter, private & + & :: hd_grid_width = 'grid_width_ctl' +! + character(len=kchara), parameter, private & + & :: hd_tangent_cylinder = 'tangent_cylinder_switch_ctl' + character(len=kchara), parameter, private & + & :: hd_tcyl_inner = 'inner_radius_ctl' + character(len=kchara), parameter, private & + & :: hd_tcyl_outer = 'outer_radius_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine read_map_section_ctl & + & (id_control, hd_block, icou, map_sect_ctl, c_buf) +! + use ctl_file_section_def_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control, icou + character(len=kchara), intent(in) :: hd_block + type(map_section_ctl), intent(inout) :: map_sect_ctl + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(map_sect_ctl%i_map_sect_ctl .gt. 0) return + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + if(check_file_flag(c_buf, hd_surface_define) & + & .or. check_begin_flag(c_buf, hd_surface_define)) then + call write_multi_ctl_file_message & + & (hd_block, icou, c_buf%level) + call sel_read_ctl_pvr_section_def(id_control, & + & hd_surface_define, map_sect_ctl%fname_sect_ctl, & + & map_sect_ctl%psf_def_c, c_buf) + end if +! + call read_chara_ctl_type(c_buf, hd_pvr_sec_zeroline, & + & map_sect_ctl%zeroline_switch_ctl) + call read_chara_ctl_type(c_buf, hd_pvr_isoline_color, & + & map_sect_ctl%isoline_color_mode) + call read_integer_ctl_type(c_buf, hd_isoline_number, & + & map_sect_ctl%isoline_number_ctl) + call read_real2_ctl_type(c_buf, hd_isoline_range, & + & map_sect_ctl%isoline_range_ctl) + call read_real_ctl_type(c_buf, hd_isoline_width, & + & map_sect_ctl%isoline_width_ctl) + call read_real_ctl_type(c_buf, hd_grid_width, & + & map_sect_ctl%grid_width_ctl) +! + call read_chara_ctl_type(c_buf, hd_tangent_cylinder, & + & map_sect_ctl%tan_cyl_switch_ctl) + call read_real_ctl_type(c_buf, hd_tcyl_inner, & + & map_sect_ctl%tangent_cylinder_inner_ctl) + call read_real_ctl_type(c_buf, hd_tcyl_outer, & + & map_sect_ctl%tangent_cylinder_outer_ctl) + end do + map_sect_ctl%i_map_sect_ctl = 1 +! + end subroutine read_map_section_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_map_section_ctl & + & (id_control, map_sect_ctl, level) +! + use ctl_file_section_def_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + type(map_section_ctl), intent(in) :: map_sect_ctl + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(map_sect_ctl%i_map_sect_ctl .le. 0) return + maxlen = len_trim(hd_pvr_sec_zeroline) + maxlen = max(maxlen,len_trim(hd_pvr_isoline_color)) + maxlen = max(maxlen,len_trim(hd_isoline_number)) + maxlen = max(maxlen,len_trim(hd_isoline_range)) + maxlen = max(maxlen,len_trim(hd_isoline_width)) + maxlen = max(maxlen,len_trim(hd_grid_width)) + maxlen = max(maxlen,len_trim(hd_tangent_cylinder)) + maxlen = max(maxlen,len_trim(hd_tcyl_inner)) + maxlen = max(maxlen,len_trim(hd_tcyl_outer)) +! + level = write_begin_flag_for_ctl(id_control, level, & + & map_sect_ctl%block_name) + call sel_write_ctl_pvr_section_def(id_control, hd_surface_define, & + & map_sect_ctl%fname_sect_ctl, map_sect_ctl%psf_def_c, level) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & map_sect_ctl%zeroline_switch_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & map_sect_ctl%isoline_color_mode) + call write_integer_ctl_type(id_control, level, maxlen, & + & map_sect_ctl%isoline_number_ctl) + call write_real2_ctl_type(id_control, level, maxlen, & + & map_sect_ctl%isoline_range_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & map_sect_ctl%isoline_width_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & map_sect_ctl%grid_width_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & map_sect_ctl%tan_cyl_switch_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & map_sect_ctl%tangent_cylinder_inner_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & map_sect_ctl%tangent_cylinder_outer_ctl) + level = write_end_flag_for_ctl(id_control, level, & + & map_sect_ctl%block_name) +! + end subroutine write_map_section_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_map_section_ctl_label(hd_block, map_sect_ctl) +! + use ctl_data_section_def_IO +! + character(len=kchara), intent(in) :: hd_block + type(map_section_ctl), intent(inout) :: map_sect_ctl +! + map_sect_ctl%block_name = hd_block + call init_psf_def_ctl_stract & + & (hd_surface_define, map_sect_ctl%psf_def_c) +! + call init_chara_ctl_item_label(hd_pvr_sec_zeroline, & + & map_sect_ctl%zeroline_switch_ctl) + call init_chara_ctl_item_label(hd_pvr_isoline_color, & + & map_sect_ctl%isoline_color_mode) + call init_int_ctl_item_label(hd_isoline_number, & + & map_sect_ctl%isoline_number_ctl) + call init_real2_ctl_item_label(hd_isoline_range, & + & map_sect_ctl%isoline_range_ctl) + call init_real_ctl_item_label(hd_isoline_width, & + & map_sect_ctl%isoline_width_ctl) + call init_real_ctl_item_label(hd_grid_width, & + & map_sect_ctl%grid_width_ctl) +! + call init_chara_ctl_item_label(hd_tangent_cylinder, & + & map_sect_ctl%tan_cyl_switch_ctl) + call init_real_ctl_item_label(hd_tcyl_inner, & + & map_sect_ctl%tangent_cylinder_inner_ctl) + call init_real_ctl_item_label(hd_tcyl_outer, & + & map_sect_ctl%tangent_cylinder_outer_ctl) +! + end subroutine init_map_section_ctl_label +! +! --------------------------------------------------------------------- +! + end module ctl_data_map_section_IO diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/ctl_file_map_renderings_IO.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/ctl_file_map_renderings_IO.f90 new file mode 100644 index 00000000..68c27001 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/ctl_file_map_renderings_IO.f90 @@ -0,0 +1,259 @@ +!>@file ctl_file_map_renderings_IO.f90 +!!@brief module ctl_file_map_renderings_IO +!! +!!@date Programmed by H.Matsui in May, 2006 +! +!>@brief control data for cross sections +!! +!!@verbatim +!! subroutine read_files_4_map_ctl & +!! & (id_control, hd_block, map_ctls, c_buf) +!! subroutine sel_read_control_4_map_file(id_control, hd_block, & +!! & file_name, map_ctl_struct, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! character(len = kchara), intent(inout) :: file_name +!! type(map_rendering_controls), intent(inout) :: map_ctls +!! type(map_ctl), intent(inout) :: map_ctl_struct +!! type(buffer_for_control), intent(inout) :: c_buf +!! +!! subroutine write_files_4_map_ctl & +!! & (id_control, hd_block, map_ctls, level) +!! subroutine sel_write_control_4_map_file(id_control, hd_block, & +!! & file_name, map_ctl_struct, level) +!! subroutine write_control_4_map_file(id_control, file_name, & +!! & hd_block, map_ctl_struct) +!! integer(kind = kint), intent(in) :: id_control +!! character(len = kchara), intent(in) :: file_name +!! character(len=kchara), intent(in) :: hd_block +!! type(map_rendering_controls), intent(in) :: map_ctls +!! type(map_ctl), intent(in) :: map_ctl_struct +!! integer(kind = kint), intent(inout) :: level +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array map_rendering_ctl +!! file map_rendering_ctl 'ctl_map_cmb' +!! end array map_rendering_ctl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module ctl_file_map_renderings_IO +! + use m_precision +! + use m_machine_parameter + use t_control_data_4_map + use t_control_data_maps +! + implicit none +! +! + character(len=kchara), parameter, private & + & :: hd_map_rendering = 'map_rendering_ctl' +! + private :: read_control_4_map_file +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_files_4_map_ctl & + & (id_control, hd_block, map_ctls, c_buf) +! + use t_read_control_elements + use ctl_data_section_IO + use skip_comment_f + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(map_rendering_controls), intent(inout) :: map_ctls + type(buffer_for_control), intent(inout) :: c_buf +! + integer(kind = kint) :: n_append +! + if(check_array_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(allocated(map_ctls%map_ctl_struct)) return + map_ctls%num_map_ctl = 0 + call alloc_map_ctl_stract(map_ctls) +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_array_flag(c_buf, hd_block)) exit +! + if(check_file_flag(c_buf, hd_block) & + & .or. check_begin_flag(c_buf, hd_block)) then + n_append = map_ctls%num_map_ctl + call append_map_render_control(n_append, hd_block, map_ctls) +! + call write_multi_ctl_file_message & + & (hd_block, map_ctls%num_map_ctl, c_buf%level) + call sel_read_control_4_map_file(id_control, hd_block, & + & map_ctls%fname_map_ctl(map_ctls%num_map_ctl), & + & map_ctls%map_ctl_struct(map_ctls%num_map_ctl), c_buf) + end if + end do +! + end subroutine read_files_4_map_ctl +! +! -------------------------------------------------------------------- +! + subroutine sel_read_control_4_map_file(id_control, hd_block, & + & file_name, map_ctl_struct, c_buf) +! + use t_read_control_elements + use ctl_data_map_rendering_IO + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + character(len = kchara), intent(inout) :: file_name + type(map_ctl), intent(inout) :: map_ctl_struct + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_file_flag(c_buf, hd_block)) then + file_name = third_word(c_buf) +! + write(*,'(2a)') ' is read file from ... ', trim(file_name) + call read_control_4_map_file((id_control+2), file_name, & + & hd_block, map_ctl_struct, c_buf) + else if(check_begin_flag(c_buf, hd_block)) then + file_name = 'NO_FILE' +! + write(*,'(a)') ' is included.' + call s_read_map_control_data(id_control, hd_block, & + & map_ctl_struct, c_buf) + end if +! + end subroutine sel_read_control_4_map_file +! +! -------------------------------------------------------------------- +! + subroutine read_control_4_map_file(id_control, file_name, & + & hd_block, map_ctl_struct, c_buf) +! + use t_read_control_elements + use t_control_data_4_map + use ctl_data_map_rendering_IO +! +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(map_ctl), intent(inout) :: map_ctl_struct + type(buffer_for_control), intent(inout) :: c_buf +! +! + c_buf%level = c_buf%level + 1 + open(id_control, file=file_name, status='old') +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit +! + call s_read_map_control_data(id_control, hd_block, & + & map_ctl_struct, c_buf) + call s_read_map_control_data(id_control, hd_map_rendering, & + & map_ctl_struct, c_buf) + if(map_ctl_struct%i_map_ctl .gt. 0) exit + end do + close(id_control) + c_buf%level = c_buf%level - 1 +! + end subroutine read_control_4_map_file +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine write_files_4_map_ctl & + & (id_control, hd_block, map_ctls, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(map_rendering_controls), intent(in) :: map_ctls + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: i +! +! + if(map_ctls%num_map_ctl .le. 0) return + level = write_array_flag_for_ctl(id_control, level, hd_block) + do i = 1, map_ctls%num_map_ctl + write(*,'(3a,i4)', ADVANCE='NO') '! ', trim(hd_block), & + & ' No. ', i + call sel_write_control_4_map_file(id_control, hd_block, & + & map_ctls%fname_map_ctl(i), map_ctls%map_ctl_struct(i), & + & level) + end do + level = write_end_array_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_files_4_map_ctl +! +! -------------------------------------------------------------------- +! + subroutine sel_write_control_4_map_file(id_control, hd_block, & + & file_name, map_ctl_struct, level) +! + use t_read_control_elements + use write_control_elements + use ctl_data_map_rendering_IO + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(map_ctl), intent(in) :: map_ctl_struct + integer(kind = kint), intent(inout) :: level +! +! + if(no_file_flag(file_name)) then + call write_map_control_data(id_control, hd_block, & + & map_ctl_struct, level) + else if(id_control .eq. id_monitor) then + write(*,'(2a)') ' should be written to ... ', trim(file_name) + call write_map_control_data(id_control, hd_block, & + & map_ctl_struct, level) + else + write(*,'(2a)') ' is written to ... ', trim(file_name) + call write_file_name_for_ctl_line(id_control, level, & + & hd_block, file_name) + call write_control_4_map_file((id_control+2), file_name, & + & hd_block, map_ctl_struct) + end if +! + end subroutine sel_write_control_4_map_file +! +! -------------------------------------------------------------------- +! + subroutine write_control_4_map_file(id_control, file_name, & + & hd_block, map_ctl_struct) +! + use t_read_control_elements + use t_control_data_4_map + use ctl_data_map_rendering_IO +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(map_ctl), intent(in) :: map_ctl_struct +! + integer(kind = kint) :: level +! +! + level = 0 + open(id_control, file=file_name) + call write_map_control_data(id_control, hd_block, & + & map_ctl_struct, level) + close(id_control) +! + end subroutine write_control_4_map_file +! +! --------------------------------------------------------------------- +! + end module ctl_file_map_renderings_IO diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/draw_aitoff_map.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/draw_aitoff_map.f90 new file mode 100644 index 00000000..44470c66 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/draw_aitoff_map.f90 @@ -0,0 +1,232 @@ +!>@file draw_aitoff_map.f90 +!!@brief module draw_aitoff_map +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +!!@n modified in July, 2014 +! +!>@brief Structure for cross sectioning +!! +!!@verbatim +!! subroutine set_scalar_on_map_image(color_param, & +!! & psf_nod, psf_ele, d_scalar, map_data, pvr_rgb, map_e) +!! type(pvr_colormap_parameter), intent(in) :: color_param +!! type(node_data), intent(in) :: psf_nod +!! type(element_data), intent(in) :: psf_ele +!! type(map_rendering_data), intent(in) :: map_data +!! real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!! type(map_patches_for_1patch), intent(inout) :: map_e +!! subroutine draw_aitoff_map_isolines(psf_nod, psf_ele, d_scalar, & +!! & map_data, color_param, pvr_rgb, map_e) +!! subroutine draw_aitoff_map_zeroline(psf_nod, psf_ele, d_scalar, & +!! & map_data, color_ref, pvr_rgb, map_e) +!! subroutine draw_isoline_on_map_image & +!! & (psf_nod, psf_ele, d_scalar, map_data, nwidth, idots, & +!! & d_ref, color_ref, pvr_rgb, map_e) +!! type(node_data), intent(in) :: psf_nod +!! type(element_data), intent(in) :: psf_ele +!! type(map_rendering_data), intent(in) :: map_data +!! real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +!! integer(kind = kint), intent(in) :: nwidth, idots +!! real(kind = kreal), intent(in) :: d_ref +!! real(kind = kreal), intent(in) :: color_ref(4) +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!! type(map_patches_for_1patch), intent(inout) :: map_e +!!@endverbatim + module draw_aitoff_map +! + use m_precision + use m_constants +! + use t_geometry_data + use t_phys_data + use t_pvr_image_array + use t_map_rendering_data + use t_map_patch_from_1patch +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_scalar_on_map_image(color_param, & + & psf_nod, psf_ele, d_scalar, map_data, pvr_rgb, map_e) +! + use map_patch_from_1patch + use draw_pixels_on_map +! + type(pvr_colormap_parameter), intent(in) :: color_param + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: iele, i +! +! + do iele = 1, psf_ele%numele + call s_set_map_patch_from_1patch(iele, & + & psf_nod%numnod, psf_ele%numele, psf_nod%xx, psf_ele%ie, & + & ione, d_scalar, map_e%n_map_patch, & + & map_e%x_map_patch, map_e%d_map_patch(1,1)) +! + do i = 1, map_e%n_map_patch + call set_sph_position_4_map_patch & + & (map_e%x_map_patch(1,1,i), map_e%rtp_map_patch(1,1,i)) + call patch_to_aitoff(map_e%rtp_map_patch(1,1,i), & + & map_e%xy_map(1,1,i)) + call fill_triangle_data_on_image(color_param, & + & map_data%xmin_frame, map_data%xmax_frame, & + & map_data%ymin_frame, map_data%ymax_frame, & + & pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & map_e%xy_map(1,1,i), map_e%d_map_patch(1,i), & + & pvr_rgb%rgba_real_gl) + end do + end do +! + end subroutine set_scalar_on_map_image +! +! --------------------------------------------------------------------- +! + subroutine draw_aitoff_map_isolines(psf_nod, psf_ele, d_scalar, & + & map_data, color_param, pvr_rgb, map_e) +! + use set_color_4_pvr +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +! + type(map_rendering_data), intent(in) :: map_data + type(pvr_colormap_parameter), intent(in) :: color_param +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: idots + integer(kind = kint) :: iline + real(kind = kreal) :: color_ref(4) + real(kind = kreal) :: d_min, d_max, d_ref +! +! + if(map_data%flag_fixed_isoline_range) then + d_min = map_data%dmin_isoline + d_max = map_data%dmax_isoline + else + d_min = minval(d_scalar) + d_max = maxval(d_scalar) + end if +! + do iline = 0, map_data%num_line-1 + d_ref = d_min + (d_max - d_min) & + & * dble(iline) / dble(map_data%num_line-1) + if(d_ref .ge. zero) then + idots = 0 + else + idots = int(2 * map_data%width_isoline) + end if +! + if(map_data%iflag_isoline_color .eq. iflag_white) then + color_ref(1:4) = one + else if(map_data%iflag_isoline_color .eq. iflag_black) then + color_ref(1:4) = zero + else + call value_to_rgb(color_param%id_pvr_color(2), & + & color_param%id_pvr_color(1), & + & color_param%num_pvr_datamap_pnt, & + & color_param%pvr_datamap_param, & + & d_ref, color_ref(1)) + end if +! + color_ref(4) = one + call draw_isoline_on_map_image(psf_nod, psf_ele, d_scalar, & + & map_data, int(map_data%width_isoline), idots, & + & d_ref, color_ref, pvr_rgb, map_e) + end do +! + end subroutine draw_aitoff_map_isolines +! +! --------------------------------------------------------------------- +! + subroutine draw_aitoff_map_zeroline(psf_nod, psf_ele, d_scalar, & + & map_data, color_ref, pvr_rgb, map_e) +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +! + type(map_rendering_data), intent(in) :: map_data + real(kind = kreal), intent(in) :: color_ref(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: nwidth +! + nwidth = int(2 * map_data%width_isoline) + call draw_isoline_on_map_image(psf_nod, psf_ele, d_scalar, & + & map_data, nwidth, izero, zero, color_ref, pvr_rgb, map_e) +! + end subroutine draw_aitoff_map_zeroline +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine draw_isoline_on_map_image & + & (psf_nod, psf_ele, d_scalar, map_data, nwidth, idots, & + & d_ref, color_ref, pvr_rgb, map_e) +! + use map_patch_from_1patch + use draw_isoline_in_triangle +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +! + integer(kind = kint), intent(in) :: nwidth, idots + real(kind = kreal), intent(in) :: d_ref + real(kind = kreal), intent(in) :: color_ref(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: iele, i +! + real(kind=kreal) :: xy_map(2,3,3) + real(kind=kreal) :: d_map_patch(3,3) +! +! + do iele = 1, psf_ele%numele + call s_set_map_patch_from_1patch(iele, & + & psf_nod%numnod, psf_ele%numele, psf_nod%xx, psf_ele%ie, & + & ione, d_scalar(1), map_e%n_map_patch, & + & xy_map(1,1,1), d_map_patch(1,1)) +! + do i = 1, map_e%n_map_patch + call set_sph_position_4_map_patch & + & (xy_map(1,1,i), map_e%rtp_map_patch(1,1,i)) + call patch_to_aitoff(map_e%rtp_map_patch(1,1,i), & + & map_e%xy_map(1,1,i)) +! + call s_draw_isoline_in_triangle(nwidth, idots, & + & map_data%xmin_frame, map_data%xmax_frame, & + & map_data%ymin_frame, map_data%ymax_frame, & + & pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & map_e%xy_map(1,1,i), d_map_patch(1,i), d_ref, color_ref, & + & pvr_rgb%rgba_real_gl) + end do + end do +! + end subroutine draw_isoline_on_map_image +! +! --------------------------------------------------------------------- +! + end module draw_aitoff_map diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/draw_isoline_in_triangle.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/draw_isoline_in_triangle.f90 new file mode 100644 index 00000000..af799cf0 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/draw_isoline_in_triangle.f90 @@ -0,0 +1,189 @@ +!>@file draw_isoline_in_triangle.f90 +!!@brief module draw_isoline_in_triangle +!! +!!@author H. Matsui +!!@date Programmed in June, 2023 +! +!>@brief Fraw pixels on projected image +!! +!!@verbatim +!! subroutine s_draw_isoline_in_triangle(nwidth, idots, & +!! & xmin_frame, xmax_frame, ymin_frame, ymax_frame, & +!! & nxpixel, nypixel, xy_patch, d_patch, d_ref, color_ref,& +!! & rgba) +!! real(kind= kreal), intent(in) :: xmin_frame, xmax_frame +!! real(kind= kreal), intent(in) :: ymin_frame, ymax_frame +!! integer(kind = kint), intent(in) :: nwidth, idots +!! integer(kind = kint), intent(in) :: nxpixel, nypixel +!! real(kind = kreal), intent(in) :: xy_patch(2,3) +!! real(kind = kreal), intent(in) :: d_patch(3) +!! real(kind = kreal), intent(in) :: d_ref +!! real(kind = kreal), intent(in) :: color_ref(4) +!! real(kind = kreal), intent(inout) :: rgba(4,nxpixel*nypixel) +!!@endverbatim + module draw_isoline_in_triangle +! + use m_precision + use m_constants +! + implicit none +! + private :: find_isoline_in_triangle, draw_pixel_on_isoline +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_draw_isoline_in_triangle(nwidth, idots, & + & xmin_frame, xmax_frame, ymin_frame, ymax_frame, & + & nxpixel, nypixel, xy_patch, d_patch, d_ref, color_ref, & + & rgba) +! + real(kind= kreal), intent(in) :: xmin_frame, xmax_frame + real(kind= kreal), intent(in) :: ymin_frame, ymax_frame + integer(kind = kint), intent(in) :: nwidth, idots + integer(kind = kint), intent(in) :: nxpixel, nypixel + real(kind = kreal), intent(in) :: xy_patch(2,3) + real(kind = kreal), intent(in) :: d_patch(3) + real(kind = kreal), intent(in) :: d_ref + real(kind = kreal), intent(in) :: color_ref(4) +! + real(kind = kreal), intent(inout) :: rgba(4,nxpixel*nypixel) +! + integer(kind = kint) :: iflag_count + real(kind = kreal) :: xy_edge(2,2) +! +! + call find_isoline_in_triangle & + & (xy_patch, d_patch, d_ref, iflag_count, xy_edge) + if(iflag_count .eq. 2) then + call draw_pixel_on_isoline(nwidth, idots, & + & xmin_frame, xmax_frame, ymin_frame, ymax_frame, & + & nxpixel, nypixel, xy_edge, color_ref, rgba) + end if +! + end subroutine s_draw_isoline_in_triangle +! +! --------------------------------------------------------------------- +! + subroutine draw_pixel_on_isoline(nwidth, idots, & + & xmin_frame, xmax_frame, ymin_frame, ymax_frame, & + & nxpixel, nypixel, xy_edge, color_ref, rgba) +! + real(kind= kreal), intent(in) :: xmin_frame, xmax_frame + real(kind= kreal), intent(in) :: ymin_frame, ymax_frame + integer(kind = kint), intent(in) :: nwidth, idots + integer(kind = kint), intent(in) :: nxpixel, nypixel + real(kind = kreal), intent(in) :: xy_edge(2,2) + real(kind = kreal), intent(in) :: color_ref(4) +! + real(kind = kreal), intent(inout) :: rgba(4,nxpixel*nypixel) +! + integer(kind = kint) :: ix1, ix2, iy1, iy2, ix, iy + integer(kind = kint) :: ist, ied, jst, jed, i, j, i_img + integer(kind = kint) :: ilen, nlen, isq +! +! + isq = 2*idots + ix1 = int(1 + dble(nxpixel-1) * (xy_edge(1,1) - xmin_frame) & + & / (xmax_frame - xmin_frame)) + ix2 = int(1 + dble(nxpixel-1) * (xy_edge(1,2) - xmin_frame) & + & / (xmax_frame - xmin_frame)) + iy1 = int(1 + dble(nypixel-1) * (xy_edge(2,1) - ymin_frame) & + & / (ymax_frame - ymin_frame)) + iy2 = int(1 + dble(nypixel-1) * (xy_edge(2,2) - ymin_frame) & + & / (ymax_frame - ymin_frame)) + nlen = max(abs(ix2-ix1),abs(iy2-iy1)) + do ilen = 0, nlen + ix = ix1 + int(dble((ix2-ix1)*ilen) / dble(nlen)) + iy = iy1 + int(dble((iy2-iy1)*ilen) / dble(nlen)) + ist = ix - (nwidth-1) / 2 + ied = ix + nwidth / 2 + jst = iy - (nwidth-1) / 2 + jed = iy + nwidth / 2 + ist = max(ist,1) + ied = max(ied,0) + jst = max(jst,1) + jed = max(jed,0) + ist = min(ist,nxpixel+1) + ied = min(ied,nxpixel) + jst = min(jst,nypixel+1) + jed = min(jed,nypixel) + do j = jst, jed + do i = ist, ied + if(isq .gt. 0) then + if(mod(j,isq).ge.idots .and. mod(i,isq).lt.idots) cycle + if(mod(j,isq).lt.idots .and. mod(i,isq).ge.idots) cycle + end if +! + i_img = i + (j-1) * nxpixel + rgba(1:4,i_img) = color_ref(1:4) + rgba(4,i_img) = one + end do + end do + end do +! + end subroutine draw_pixel_on_isoline +! +! --------------------------------------------------------------------- +! + subroutine find_isoline_in_triangle & + & (xy_patch, d_patch, d_ref, iflag_count, xy_edge) +! + real(kind = kreal), intent(in) :: xy_patch(2,3) + real(kind = kreal), intent(in) :: d_patch(3) + real(kind = kreal), intent(in) :: d_ref +! + integer(kind = kint), intent(inout) :: iflag_count + real(kind = kreal), intent(inout) :: xy_edge(2,2) +! + real(kind = kreal) :: ratio +! + iflag_count = 0 + if((d_patch(2)-d_ref)*(d_patch(3)-d_ref) .le. zero) then + if(d_patch(2) .eq. d_patch(3)) then + xy_edge(1:2,1) = xy_patch(1:2,2) + xy_edge(1:2,2) = xy_patch(1:2,3) + iflag_count = 2 + return + else + iflag_count = iflag_count + 1 + ratio = (d_ref - d_patch(2)) / (d_patch(3) - d_patch(2)) + xy_edge(1:2,iflag_count) = (one - ratio) * xy_patch(1:2,2) & + & + ratio * xy_patch(1:2,3) + end if + end if + if((d_patch(3)-d_ref)*(d_patch(1)-d_ref) .le. zero) then + if(d_patch(3) .eq. d_patch(1)) then + xy_edge(1:2,1) = xy_patch(1:2,3) + xy_edge(1:2,2) = xy_patch(1:2,1) + iflag_count = 2 + return + else + iflag_count = iflag_count + 1 + ratio = (d_ref - d_patch(3)) / (d_patch(1) - d_patch(3)) + xy_edge(1:2,iflag_count) = (one - ratio) * xy_patch(1:2,3) & + & + ratio * xy_patch(1:2,1) + end if + end if + if(iflag_count .eq. 2) return + if((d_patch(1)-d_ref)*(d_patch(2)-d_ref) .le. zero) then + if(d_patch(1) .eq. d_patch(2)) then + xy_edge(1:2,1) = xy_patch(1:2,1) + xy_edge(1:2,2) = xy_patch(1:2,2) + iflag_count = 2 + else + iflag_count = iflag_count + 1 + ratio = (d_ref - d_patch(1)) / (d_patch(2) - d_patch(1)) + xy_edge(1:2,iflag_count) = (one - ratio) * xy_patch(1:2,1) & + & + ratio * xy_patch(1:2,2) + end if + end if +! + end subroutine find_isoline_in_triangle +! +! --------------------------------------------------------------------- +! + end module draw_isoline_in_triangle diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/draw_lines_on_map.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/draw_lines_on_map.f90 new file mode 100644 index 00000000..293c195f --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/draw_lines_on_map.f90 @@ -0,0 +1,265 @@ +!>@file draw_lines_on_map.f90 +!!@brief module draw_lines_on_map +!! +!!@author H. Matsui +!!@date Programmed in July, 2023 +! +!>@brief Subroutines to draw lines on map +!! +!!@verbatim +!! subroutine draw_radius_grid(psf_nod, psf_ele, map_data, & +!! & bg_color, ref_r, pvr_rgb, map_e) +!! subroutine draw_mapflame(psf_nod, psf_ele, phi_shift, map_data, & +!! & bg_color, pvr_rgb, map_e) +!! subroutine draw_longitude_grid(psf_nod, psf_ele, phi_shift, & +!! & map_data, bg_color, pvr_rgb, map_e) +!! subroutine draw_latitude_grid(psf_nod, psf_ele, map_data, & +!! & bg_color, pvr_rgb, map_e) +!! subroutine draw_map_tangent_cyl_grid(psf_nod, psf_ele, map_data,& +!! & bg_color, theta_ref, pvr_rgb, map_e) +!! subroutine draw_med_tangent_cyl_grid(psf_nod, psf_ele, map_data,& +!! & bg_color, radius_ICB, pvr_rgb, map_e) +!! type(node_data), intent(in) :: psf_nod +!! type(element_data), intent(in) :: psf_ele +!! type(map_rendering_data), intent(in) :: map_data +!! real(kind = kreal), intent(in) :: ref_r +!! real(kind = kreal), intent(in) :: theta_ref(2) +!! real(kind = kreal), intent(in) :: radius_ICB +!! real(kind = kreal), intent(in) :: bg_color(4) +!! real(kind = kreal), intent(in) :: phi_shift(psf_nod%numnod) +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!! type(map_patches_for_1patch), intent(inout) :: map_e +!! +!! subroutine set_flame_color(flag_fill, bg_color, flame_color) +!! logical, intent(in) :: flag_fill +!! real(kind = kreal), intent(in) :: bg_color(4) +!! real(kind = kreal), intent(inout) :: flame_color(4) +!!@endverbatim + module draw_lines_on_map +! + use m_precision + use m_constants + use t_geometry_data + use t_map_patch_from_1patch + use t_map_rendering_data + use t_pvr_image_array +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine draw_radius_grid(psf_nod, psf_ele, map_data, & + & bg_color, ref_r, pvr_rgb, map_e) +! + use draw_xyz_plane_isolines +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data + real(kind = kreal), intent(in) :: ref_r + real(kind = kreal), intent(in) :: bg_color(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: nwidth + real(kind = kreal) :: color_ref(4) +! + nwidth = int(2 * map_data%width_grid) + call set_flame_color(map_data%fill_flag, bg_color, color_ref) + call sel_draw_isoline_on_xyz_plane & + & (psf_nod, psf_ele, psf_nod%rr(1), nwidth, izero, & + & map_data, ref_r, color_ref, pvr_rgb, map_e) +! + end subroutine draw_radius_grid +! +! --------------------------------------------------------------------- +! + subroutine draw_mapflame(psf_nod, psf_ele, phi_shift, map_data, & + & bg_color, pvr_rgb, map_e) +! + use draw_aitoff_map +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data + real(kind = kreal), intent(in) :: phi_shift(psf_nod%numnod) + real(kind = kreal), intent(in) :: bg_color(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: nwidth + real(kind = kreal) :: pi + real(kind = kreal) :: color_ref(4) +! +! + nwidth = int(2 * map_data%width_grid) + call set_flame_color(map_data%fill_flag, bg_color, color_ref) +! + pi = four * atan(one) + call draw_isoline_on_map_image & + & (psf_nod, psf_ele, phi_shift(1), map_data, nwidth, izero, & + & (-pi), color_ref, pvr_rgb, map_e) + call draw_isoline_on_map_image & + & (psf_nod, psf_ele, phi_shift(1), map_data, nwidth, izero, & + & pi, color_ref, pvr_rgb, map_e) +! + end subroutine draw_mapflame +! +! --------------------------------------------------------------------- +! + subroutine draw_longitude_grid(psf_nod, psf_ele, phi_shift, & + & map_data, bg_color, pvr_rgb, map_e) +! + use draw_aitoff_map +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data + real(kind = kreal), intent(in) :: phi_shift(psf_nod%numnod) + real(kind = kreal), intent(in) :: bg_color(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: idots + integer(kind = kint) :: ii + real(kind = kreal) :: phi_ref, pi + real(kind = kreal) :: color_ref(4) +! +! + idots = int(2 * map_data%width_grid) + call set_flame_color(map_data%fill_flag, bg_color, color_ref) +! + pi = four * atan(one) + do ii = 1, 5 + phi_ref = pi * dble(ii-3) / 3.0d0 + call draw_isoline_on_map_image & + & (psf_nod, psf_ele, phi_shift(1), map_data, & + & int(map_data%width_grid), idots, phi_ref, color_ref, & + & pvr_rgb, map_e) + end do +! + end subroutine draw_longitude_grid +! +! --------------------------------------------------------------------- +! + subroutine draw_latitude_grid(psf_nod, psf_ele, map_data, & + & bg_color, pvr_rgb, map_e) +! + use draw_aitoff_map +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data + real(kind = kreal), intent(in) :: bg_color(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: idots + integer(kind = kint) :: jj + real(kind = kreal) :: theta_ref, pi + real(kind = kreal) :: color_ref(4) +! + idots = int(2* map_data%width_grid) + call set_flame_color(map_data%fill_flag, bg_color, color_ref) +! + pi = four * atan(one) + do jj = 1, 5 + theta_ref = pi * dble(jj) / 6.0d0 + call draw_isoline_on_map_image & + & (psf_nod, psf_ele, psf_nod%theta(1), map_data, & + & int(map_data%width_grid), idots, theta_ref, color_ref, & + & pvr_rgb, map_e) + end do +! + end subroutine draw_latitude_grid +! +! --------------------------------------------------------------------- +! + subroutine draw_map_tangent_cyl_grid(psf_nod, psf_ele, map_data, & + & bg_color, theta_ref, pvr_rgb, map_e) +! + use draw_aitoff_map +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data + real(kind = kreal), intent(in) :: theta_ref(2) + real(kind = kreal), intent(in) :: bg_color(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: idots, nwidth + real(kind = kreal) :: color_ref(4) +! + call set_flame_color(map_data%fill_flag, bg_color, color_ref) +! + nwidth = int(2 * map_data%width_grid) + idots = int(4 * map_data%width_grid) + call draw_isoline_on_map_image & + & (psf_nod, psf_ele, psf_nod%theta(1), map_data, nwidth, idots, & + & theta_ref(1), color_ref, pvr_rgb, map_e) + call draw_isoline_on_map_image & + & (psf_nod, psf_ele, psf_nod%theta(1), map_data, nwidth, idots, & + & theta_ref(2), color_ref, pvr_rgb, map_e) +! + end subroutine draw_map_tangent_cyl_grid +! +! --------------------------------------------------------------------- +! + subroutine draw_med_tangent_cyl_grid(psf_nod, psf_ele, map_data, & + & bg_color, radius_ICB, pvr_rgb, map_e) +! + use draw_xyz_plane_isolines +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data + real(kind = kreal), intent(in) :: radius_ICB + real(kind = kreal), intent(in) :: bg_color(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: idots, nwidth + real(kind = kreal) :: color_ref(4) +! + nwidth = int(2 * map_data%width_grid) + idots = int(4 * map_data%width_grid) + call set_flame_color(map_data%fill_flag, bg_color, color_ref) + call sel_draw_isoline_on_xyz_plane & + & (psf_nod, psf_ele, psf_nod%xx(1,1), nwidth, idots, & + & map_data, radius_ICB, color_ref, pvr_rgb, map_e) +! + end subroutine draw_med_tangent_cyl_grid +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_flame_color(flag_fill, bg_color, flame_color) +! + logical, intent(in) :: flag_fill + real(kind = kreal), intent(in) :: bg_color(4) + real(kind = kreal), intent(inout) :: flame_color(4) +! + if(flag_fill) then + flame_color(1:3) = zero + flame_color(4) = one + else + flame_color(1:3) = bg_color(1:3) + (one - two*bg_color(1:3)) + flame_color(4) = one + end if +! + end subroutine set_flame_color +! +! --------------------------------------------------------------------- +! + end module draw_lines_on_map diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/draw_pixels_on_map.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/draw_pixels_on_map.f90 new file mode 100644 index 00000000..893f12dd --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/draw_pixels_on_map.f90 @@ -0,0 +1,294 @@ +!>@file draw_pixels_on_map.f90 +!!@brief module draw_pixels_on_map +!! +!!@author H. Matsui +!!@date Programmed in June, 2023 +! +!>@brief Fraw pixels on projected image +!! +!!@verbatim +!! subroutine fill_triangle_data_on_image(color_param, & +!! & xmin_frame, xmax_frame, ymin_frame, ymax_frame, & +!! & nxpixel, nypixel, k_ymin, k_ymid, k_ymax, & +!! & xy_patch, d_patch, rgba) +!! type(pvr_colormap_parameter), intent(in) :: color_param +!! real(kind= kreal), intent(in) :: xmin_frame, xmax_frame +!! real(kind= kreal), intent(in) :: ymin_frame, ymax_frame +!! integer(kind = kint), intent(in) :: nxpixel, nypixel +!! integer(kind = kint), intent(in) :: k_ymin, k_ymid, k_ymax +!! real(kind = kreal), intent(in) :: xy_patch(2,3) +!! real(kind = kreal), intent(in) :: d_patch(3) +!! real(kind = kreal), intent(inout) :: rgba(4,nxpixel*nypixel) +!! subroutine fill_map_one_color(nxpixel, nypixel, bg_rgba, rgba) +!! subroutine fill_background(nxpixel, nypixel, bg_rgba, rgba) +!! integer(kind = kint), intent(in) :: nxpixel, nypixel +!! real(kind = kreal), intent(in) :: bg_rgba(4) +!! real(kind = kreal), intent(inout) :: rgba(4,nxpixel*nypixel) +!!@endverbatim + module draw_pixels_on_map +! + use m_precision + use m_constants + use m_geometry_constants +! + implicit none +! + private :: find_map_path_orientation +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine fill_triangle_data_on_image(color_param, & + & xmin_frame, xmax_frame, ymin_frame, ymax_frame, & + & nxpixel, nypixel, xy_patch, d_patch, rgba) +! + use t_pvr_colormap_parameter + use set_color_4_pvr +! + type(pvr_colormap_parameter), intent(in) :: color_param + real(kind= kreal), intent(in) :: xmin_frame, xmax_frame + real(kind= kreal), intent(in) :: ymin_frame, ymax_frame + integer(kind = kint), intent(in) :: nxpixel, nypixel + real(kind = kreal), intent(in) :: xy_patch(2,3) + real(kind = kreal), intent(in) :: d_patch(3) +! + real(kind = kreal), intent(inout) :: rgba(4,nxpixel*nypixel) +! + integer(kind = kint) :: k_ymin, k_ymid, k_ymax + integer(kind = kint) :: ix, iy, i_img + integer(kind = kint) :: ix_min, ix_max + integer(kind = kint) :: iy_min, iy_mid, iy_max + integer(kind = kint) :: kmin, kmax + real(kind = kreal) :: x(2), d(2), d_map + real(kind = kreal) :: ratio_ymid, ratio_ymax, ratio_x +! +! + call find_map_path_orientation(xy_patch, k_ymin, k_ymid, k_ymax) +! + iy_min = int(1 + dble(nypixel-1) & + & * (xy_patch(2,k_ymin) - ymin_frame) & + & / (ymax_frame - ymin_frame)) + iy_mid = int(1 + dble(nypixel-1) & + & * (xy_patch(2,k_ymid) - ymin_frame) & + & / (ymax_frame - ymin_frame)) + iy_max = int(1 + dble(nypixel-1) & + & * (xy_patch(2,k_ymax) - ymin_frame) & + & / (ymax_frame - ymin_frame)) +! + iy_min = max(iy_min,1) + iy_mid = max(iy_mid,0) + iy_max = max(iy_max,0) + do iy = iy_min, iy_mid + if(iy_max.eq.iy_min .or. iy_mid.eq.iy_min) then + x(1) = xy_patch(1,k_ymin) + x(2) = xy_patch(1,k_ymid) + d(1) = d_patch(k_ymin) + d(2) = d_patch(k_ymid) + else + ratio_ymid = dble(iy-iy_min) / dble(iy_mid-iy_min) + ratio_ymax = dble(iy-iy_min) / dble(iy_max-iy_min) + x(1) = (one-ratio_ymid) * xy_patch(1,k_ymin) & + & + ratio_ymid * xy_patch(1,k_ymid) + x(2) = (one-ratio_ymax) * xy_patch(1,k_ymin) & + & + ratio_ymax * xy_patch(1,k_ymax) + d(1) = (one-ratio_ymid) * d_patch(k_ymin) & + & + ratio_ymid * d_patch(k_ymid) + d(2) = (one-ratio_ymax) * d_patch(k_ymin) & + & + ratio_ymax * d_patch(k_ymax) + end if + if(x(1) .le. x(2)) then + kmin = 1 + kmax = 2 + else + kmin = 2 + kmax = 1 + end if + ix_min = int(1 + dble(nxpixel-1)*(x(kmin) - xmin_frame) & + & / (xmax_frame - xmin_frame)) + ix_max = int(1 + dble(nxpixel-1)*(x(kmax) - xmin_frame) & + & / (xmax_frame - xmin_frame)) + ix_min = max(ix_min,1) + ix_max = max(ix_max,0) +! + if(ix_max .gt. 0) then + i_img = ix_min + (iy-1) * nxpixel + call value_to_rgb(color_param%id_pvr_color(2), & + & color_param%id_pvr_color(1), & + & color_param%num_pvr_datamap_pnt, & + & color_param%pvr_datamap_param, & + & d(kmin), rgba(1,i_img)) + rgba(4,i_img) = one + end if +! + do ix = ix_min+1, ix_max + i_img = ix + (iy-1) * nxpixel + ratio_x = dble(ix-ix_min) / dble(ix_max-ix_min) + d_map = (one - ratio_x) * d(kmin) + ratio_x * d(kmax) + call value_to_rgb(color_param%id_pvr_color(2), & + & color_param%id_pvr_color(1), & + & color_param%num_pvr_datamap_pnt, & + & color_param%pvr_datamap_param, & + & d_map, rgba(1,i_img)) + rgba(4,i_img) = one + end do + end do +! + do iy = iy_mid+1, iy_max + if(iy_max.eq.iy_min) then + x(1) = xy_patch(1,k_ymid) + x(2) = xy_patch(1,k_ymax) + d(1) = d_patch(k_ymid) + d(2) = d_patch(k_ymax) + else + ratio_ymid = dble(iy-iy_mid) / dble(iy_max-iy_mid) + ratio_ymax = dble(iy-iy_min) / dble(iy_max-iy_min) + x(1) = (one-ratio_ymid) * xy_patch(1,k_ymid) & + & + ratio_ymid * xy_patch(1,k_ymax) + x(2) = (one-ratio_ymax) * xy_patch(1,k_ymin) & + & + ratio_ymax * xy_patch(1,k_ymax) + d(1) = (one-ratio_ymid) * d_patch(k_ymid) & + & + ratio_ymid * d_patch(k_ymax) + d(2) = (one-ratio_ymax) * d_patch(k_ymin) & + & + ratio_ymax * d_patch(k_ymax) + end if + if(x(1) .le. x(2)) then + kmin = 1 + kmax = 2 + else + kmin = 2 + kmax = 1 + end if + ix_min = int(1 + dble(nxpixel-1)*(x(kmin) - xmin_frame) & + & / (xmax_frame - xmin_frame)) + ix_max = int(1 + dble(nxpixel-1)*(x(kmax) - xmin_frame) & + & / (xmax_frame - xmin_frame)) + ix_min = max(ix_min,1) + ix_max = max(ix_max,0) +! + if(ix_max .gt. 0) then + i_img = ix_min + (iy-1) * nxpixel + call value_to_rgb(color_param%id_pvr_color(2), & + & color_param%id_pvr_color(1), & + & color_param%num_pvr_datamap_pnt, & + & color_param%pvr_datamap_param, & + & d(kmin), rgba(1,i_img)) + rgba(4,i_img) = one + end if +! + do ix = ix_min+1, ix_max + i_img = ix + (iy-1) * nxpixel + ratio_x = dble(ix-ix_min) / dble(ix_max-ix_min) + d_map = (one - ratio_x) * d(kmin) + ratio_x * d(kmax) + call value_to_rgb(color_param%id_pvr_color(2), & + & color_param%id_pvr_color(1), & + & color_param%num_pvr_datamap_pnt, & + & color_param%pvr_datamap_param, & + & d_map, rgba(1,i_img)) + rgba(4,i_img) = one + end do + end do +! + end subroutine fill_triangle_data_on_image +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine fill_map_one_color(nxpixel, nypixel, bg_rgba, rgba) +! + use t_pvr_colormap_parameter + use set_color_4_pvr +! + integer(kind = kint), intent(in) :: nxpixel, nypixel + real(kind = kreal), intent(in) :: bg_rgba(4) +! + real(kind = kreal), intent(inout) :: rgba(4,nxpixel*nypixel) +! + integer(kind = kint) :: i_img, i, j +! +! +!$omp parallel do private(i,j,i_img) + do j = 1, nypixel + do i = 1, nxpixel + i_img = i + (j-1) * nxpixel + if(rgba(4,i_img) .gt. zero) rgba(1:4,i_img) = bg_rgba(1:4) + end do + end do +!$omp end parallel do +! + end subroutine fill_map_one_color +! +! --------------------------------------------------------------------- +! + subroutine fill_background(nxpixel, nypixel, bg_rgba, rgba) +! + use t_pvr_colormap_parameter + use set_color_4_pvr +! + integer(kind = kint), intent(in) :: nxpixel, nypixel + real(kind = kreal), intent(in) :: bg_rgba(4) +! + real(kind = kreal), intent(inout) :: rgba(4,nxpixel*nypixel) +! + integer(kind = kint) :: i_img, i, j +! +! +!$omp parallel do private(i,j,i_img) + do j = 1, nypixel + do i = 1, nxpixel + i_img = i + (j-1) * nxpixel + if(rgba(4,i_img) .eq. zero) rgba(1:4,i_img) = bg_rgba(1:4) + end do + end do +!$omp end parallel do +! + end subroutine fill_background +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine find_map_path_orientation & + & (xy_map, k_ymin, k_ymid, k_ymax) +! + real(kind = kreal), intent(in) :: xy_map(2,num_triangle) + integer(kind = kint), intent(inout) :: k_ymin, k_ymid, k_ymax +! +! + if( xy_map(2,1) .le. xy_map(2,2) & + & .and. xy_map(2,1) .le. xy_map(2,3)) then + k_ymin = 1 + if(xy_map(2,2) .le. xy_map(2,3)) then + k_ymid = 2 + k_ymax = 3 + else + k_ymid = 3 + k_ymax = 2 + end if + else if( xy_map(2,2) .le. xy_map(2,3) & + & .and. xy_map(2,2) .le. xy_map(2,1)) then + k_ymin = 2 + if(xy_map(2,3) .le. xy_map(2,1)) then + k_ymid = 3 + k_ymax = 1 + else + k_ymid = 1 + k_ymax = 3 + end if + else + k_ymin = 3 + if(xy_map(2,1) .le. xy_map(2,2)) then + k_ymid = 1 + k_ymax = 2 + else + k_ymid = 2 + k_ymax = 1 + end if + end if +! + end subroutine find_map_path_orientation +! +!----------------------------------------------------------------------- +! + end module draw_pixels_on_map diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/draw_xyz_plane_isolines.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/draw_xyz_plane_isolines.f90 new file mode 100644 index 00000000..967ced5e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/draw_xyz_plane_isolines.f90 @@ -0,0 +1,288 @@ +!>@file draw_xyz_plane_isolines.f90 +!!@brief module draw_xyz_plane_isolines +!! +!!@author H. Matsui +!!@date Programmed in June, 2023 +! +!>@brief Subroutines for plane projection +!!@verbatim +!! subroutine s_draw_xyz_plane_isolines(psf_nod, psf_ele, d_scalar,& +!! & map_data, color_param, pvr_rgb, map_e) +!! subroutine draw_xyz_plane_zeroline(psf_nod, psf_ele, d_scalar, & +!! & map_data, color_ref, pvr_rgb, map_e) +!! subroutine sel_draw_isoline_on_xyz_plane & +!! & (psf_nod, psf_ele, d_scalar, nwidth, idots, & +!! & map_data, d_ref, color_ref, pvr_rgb, map_e) +!! type(pvr_colormap_parameter), intent(in) :: color_param +!! type(node_data), intent(in) :: psf_nod +!! type(element_data), intent(in) :: psf_ele +!! real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +!! integer(kind = kint), intent(in) :: nwidth, idots +!! real(kind = kreal), intent(in) :: d_ref +!! real(kind = kreal), intent(in) :: color_ref(4) +!! type(map_rendering_data), intent(in) :: map_data +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!! type(map_patches_for_1patch), intent(inout) :: map_e +!!@endverbatim + module draw_xyz_plane_isolines +! + use m_precision + use m_constants +! + use t_geometry_data + use t_phys_data + use t_map_rendering_data + use t_map_patch_from_1patch + use t_pvr_colormap_parameter + use t_pvr_image_array +! + implicit none +! + private :: draw_isoline_on_xy_plane, draw_isoline_on_xz_plane + private :: draw_isoline_on_yz_plane +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_draw_xyz_plane_isolines(psf_nod, psf_ele, d_scalar, & + & map_data, color_param, pvr_rgb, map_e) +! + use set_color_4_pvr + use draw_pixels_on_map +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +! + type(map_rendering_data), intent(in) :: map_data + type(pvr_colormap_parameter), intent(in) :: color_param +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: idots + integer(kind = kint) :: iline + real(kind = kreal) :: color_ref(4) + real(kind = kreal) :: d_min, d_max, d_ref +! +! + if(map_data%flag_fixed_isoline_range) then + d_min = map_data%dmin_isoline + d_max = map_data%dmax_isoline + else + d_min = minval(d_scalar) + d_max = maxval(d_scalar) + end if +! + do iline = 0, map_data%num_line-1 + d_ref = d_min + (d_max - d_min) & + & * dble(iline) / dble(map_data%num_line-1) + if(d_ref .ge. zero) then + idots = 0 + else + idots = int(2 * map_data%width_isoline) + end if +! + if(map_data%iflag_isoline_color .eq. iflag_white) then + color_ref(1:4) = one + else if(map_data%iflag_isoline_color .eq. iflag_black) then + color_ref(1:4) = zero + else + call value_to_rgb(color_param%id_pvr_color(2), & + & color_param%id_pvr_color(1), & + & color_param%num_pvr_datamap_pnt, & + & color_param%pvr_datamap_param, & + & d_ref, color_ref(1)) + end if + color_ref(4) = one +! + call sel_draw_isoline_on_xyz_plane & + & (psf_nod, psf_ele, d_scalar, int(map_data%width_isoline), & + & idots, map_data, d_ref, color_ref, pvr_rgb, map_e) + end do +! + end subroutine s_draw_xyz_plane_isolines +! +! --------------------------------------------------------------------- +! + subroutine draw_xyz_plane_zeroline(psf_nod, psf_ele, d_scalar, & + & map_data, color_ref, pvr_rgb, map_e) +! + use set_color_4_pvr + use draw_pixels_on_map +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +! + type(map_rendering_data), intent(in) :: map_data + real(kind = kreal), intent(in) :: color_ref(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: nwidth +! + nwidth = int(2 * map_data%width_isoline) + call sel_draw_isoline_on_xyz_plane & + & (psf_nod, psf_ele, d_scalar, nwidth, izero, map_data, & + & zero, color_ref, pvr_rgb, map_e) +! + end subroutine draw_xyz_plane_zeroline +! +! --------------------------------------------------------------------- +! + subroutine sel_draw_isoline_on_xyz_plane & + & (psf_nod, psf_ele, d_scalar, nwidth, idots, & + & map_data, d_ref, color_ref, pvr_rgb, map_e) +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) + integer(kind = kint), intent(in) :: nwidth, idots + real(kind = kreal), intent(in) :: d_ref + real(kind = kreal), intent(in) :: color_ref(4) + type(map_rendering_data), intent(in) :: map_data +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! +! + if(map_data%iflag_2d_projection_mode .eq. iflag_xy_plane) then + call draw_isoline_on_xy_plane & + & (psf_nod, psf_ele, d_scalar, nwidth, idots, map_data, & + & d_ref, color_ref, pvr_rgb, map_e) + else if(map_data%iflag_2d_projection_mode .eq. iflag_xz_plane) & + & then + call draw_isoline_on_xz_plane & + & (psf_nod, psf_ele, d_scalar, nwidth, idots, map_data, & + & d_ref, color_ref, pvr_rgb, map_e) + else if(map_data%iflag_2d_projection_mode .eq. iflag_yz_plane) & + & then + call draw_isoline_on_yz_plane & + & (psf_nod, psf_ele, d_scalar, nwidth, idots, map_data, & + & d_ref, color_ref, pvr_rgb, map_e) + end if +! + end subroutine sel_draw_isoline_on_xyz_plane +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine draw_isoline_on_xy_plane & + & (psf_nod, psf_ele, d_scalar, nwidth, idots, map_data, & + & d_ref, color_ref, pvr_rgb, map_e) +! + use set_xyz_plot_from_1patch + use draw_isoline_in_triangle +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data +! + integer(kind = kint), intent(in) :: nwidth, idots + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) + real(kind = kreal), intent(in) :: d_ref + real(kind = kreal), intent(in) :: color_ref(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: iele +! +! + do iele = 1, psf_ele%numele + call set_xy_plot_from_1patch(psf_nod, psf_ele, d_scalar, iele, & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1)) + call s_draw_isoline_in_triangle(nwidth, idots, & + & map_data%xmin_frame, map_data%xmax_frame, & + & map_data%ymin_frame, map_data%ymax_frame, & + & pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1), & + & d_ref, color_ref, pvr_rgb%rgba_real_gl) + end do +! + end subroutine draw_isoline_on_xy_plane +! +! --------------------------------------------------------------------- +! + subroutine draw_isoline_on_xz_plane & + & (psf_nod, psf_ele, d_scalar, nwidth, idots, map_data, & + & d_ref, color_ref, pvr_rgb, map_e) +! + use t_map_patch_from_1patch + use set_xyz_plot_from_1patch + use draw_isoline_in_triangle +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data +! + integer(kind = kint), intent(in) :: nwidth, idots + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) + real(kind = kreal), intent(in) :: d_ref + real(kind = kreal), intent(in) :: color_ref(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: iele +! +! + do iele = 1, psf_ele%numele + call set_xz_plot_from_1patch(psf_nod, psf_ele, d_scalar, iele, & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1)) + call s_draw_isoline_in_triangle(nwidth, idots, & + & map_data%xmin_frame, map_data%xmax_frame, & + & map_data%ymin_frame, map_data%ymax_frame, & + & pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1), & + & d_ref, color_ref, pvr_rgb%rgba_real_gl) + end do +! + end subroutine draw_isoline_on_xz_plane +! +! --------------------------------------------------------------------- +! + subroutine draw_isoline_on_yz_plane & + & (psf_nod, psf_ele, d_scalar, nwidth, idots, map_data, & + & d_ref, color_ref, pvr_rgb, map_e) +! + use t_map_patch_from_1patch + use set_xyz_plot_from_1patch + use draw_isoline_in_triangle +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data +! + integer(kind = kint), intent(in) :: nwidth, idots + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) + real(kind = kreal), intent(in) :: d_ref + real(kind = kreal), intent(in) :: color_ref(4) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: iele +! +! + do iele = 1, psf_ele%numele + call set_yz_plot_from_1patch(psf_nod, psf_ele, d_scalar, iele, & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1)) + call s_draw_isoline_in_triangle(nwidth, idots, & + & map_data%xmin_frame, map_data%xmax_frame, & + & map_data%ymin_frame, map_data%ymax_frame, & + & pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1), & + & d_ref, color_ref, pvr_rgb%rgba_real_gl) + end do +! + end subroutine draw_isoline_on_yz_plane +! +! --------------------------------------------------------------------- +! + end module draw_xyz_plane_isolines diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/map_patch_from_1patch.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/map_patch_from_1patch.f90 new file mode 100644 index 00000000..b4135e23 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/map_patch_from_1patch.f90 @@ -0,0 +1,247 @@ +!>@file map_patch_from_1patch.f90 +!!@brief module map_patch_from_1patch +!! +!!@author H. Matsui +!!@date Programmed in May, 2023 +! +!>@brief Divided triangle patch for map projection +!! +!!@verbatim +!! subroutine s_set_map_patch_from_1patch(iele, nnod_psf, nele_psf,& +!! & xx_psf, ie_psf, ntot_comp, field_psf, & +!! & n_map_patch, x_map_patch, d_map_patch) +!! integer(kind = kint), intent(in) :: iele +!! integer(kind = kint), intent(in) :: nnod_psf, nele_psf +!! integer(kind = kint), intent(in) :: ie_psf(nele_psf,3) +!! real(kind = kreal), intent(in) :: xx_psf(nnod_psf,3) +!! real(kind = kreal), intent(in) :: field_psf(nnod_psf,ntot_comp) +!! integer(kind = kint), intent(inout) :: n_map_patch +!! real(kind = kreal), intent(inout) & +!! & :: x_map_patch(num_triangle,n_vector,n_map_patch) +!! real(kind = kreal), intent(inout) & +!! & :: d_map_patch(num_triangle,ntot_comp,n_map_patch) +!!@endverbatim + module map_patch_from_1patch +! + use m_precision +! + use m_constants + use m_phys_constants + use m_geometry_constants +! + implicit none +! + integer(kind = kint), parameter, private :: ipatch_map_12_23(9) & + & = (/ 1, 4, 5, 1, 5, 3, 4, 2, 3/) + integer(kind = kint), parameter, private :: ipatch_map_12_31(9) & + & = (/ 5, 2, 3, 5, 3, 4, 1, 5, 4/) + integer(kind = kint), parameter, private :: ipatch_map_23_31(9) & + & = (/ 1, 2, 4, 1, 4, 5, 5, 4, 3/) + integer(kind = kint), parameter, private :: ipatch_map_12_3(6) & + & = (/ 1, 4, 3, 4, 2, 3/) + integer(kind = kint), parameter, private :: ipatch_map_23_1(6) & + & = (/ 4, 1, 2, 1, 4, 3/) + integer(kind = kint), parameter, private :: ipatch_map_31_2(6) & + & = (/ 1, 2, 4, 4, 2, 3/) +! + real(kind = kreal), parameter, private :: EPSILON = 1.0d-9 +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine s_set_map_patch_from_1patch(iele, nnod_psf, nele_psf, & + & xx_psf, ie_psf, ntot_comp, field_psf, & + & n_map_patch, x_map_patch, d_map_patch) +! + integer(kind = kint), intent(in) :: iele + integer(kind = kint), intent(in) :: nnod_psf, nele_psf + integer(kind = kint), intent(in) :: ntot_comp + integer(kind = kint), intent(in) :: ie_psf(nele_psf,3) + real(kind = kreal), intent(in) :: xx_psf(nnod_psf,3) + real(kind = kreal), intent(in) :: field_psf(nnod_psf,ntot_comp) +! + integer(kind = kint), intent(inout) :: n_map_patch + real(kind = kreal), intent(inout) & + & :: x_map_patch(num_triangle,n_vector,n_map_patch) + real(kind = kreal), intent(inout) & + & :: d_map_patch(num_triangle,ntot_comp,n_map_patch) +! + real(kind = kreal) :: x_map(5,3) + real(kind = kreal), allocatable :: d_map(:,:) +! + integer(kind = kint) :: inod, i, j, jj, k + real(kind = kreal) :: y1, y2, y3 +! +! + allocate(d_map(9,ntot_comp)) + d_map(1:9,1:ntot_comp) = 0.0d0 +! + do i = 1, 3 + inod = ie_psf(iele,i) + d_map(i,1:ntot_comp) = real(field_psf(inod,1:ntot_comp)) +! + do j = 1, 3 + if(abs(xx_psf(inod,j)) .lt. EPSILON) then + x_map(i,j) = 0.0d0 + else + x_map(i,j) = xx_psf(inod,j) + end if + end do + end do + y1 = x_map(1,2) + y2 = x_map(2,2) + y3 = x_map(3,2) +! +! + if ( ((y1*y2).lt.zero) .and. ((y2*y3).lt.zero) )then + x_map(4,1) = (y2*x_map(1,1) - y1*x_map(2,1)) / (y2- y1) + x_map(4,2) = zero + x_map(4,3) = (y2*x_map(1,3) - y1*x_map(2,3)) / (y2- y1) + d_map(4,1:ntot_comp) = (y2*d_map(1,1:ntot_comp) & + & - y1*d_map(2,1:ntot_comp)) / (y2- y1) +! + x_map(5,1) = (y3*x_map(2,1) - y2*x_map(3,1)) / (y3- y2) + x_map(5,2) = zero + x_map(5,3) = (y3*x_map(2,3) - y2*x_map(3,3)) / (y3- y2) + d_map(5,1:ntot_comp) = (y3*d_map(2,1:ntot_comp) & + & - y2*d_map(3,1:ntot_comp)) / (y3- y2) +! + n_map_patch = 3 + do i = 1, n_map_patch + do j = 1, num_triangle + jj = j + (i-1)*num_triangle + k = ipatch_map_12_23(jj) + x_map_patch(j,1,i) = x_map(k,1) + x_map_patch(j,2,i) = x_map(k,2) + x_map_patch(j,3,i) = x_map(k,3) + d_map_patch(j,1:ntot_comp,i) = d_map(k,1:ntot_comp) + end do + end do +! + else if( ((y1*y2).lt.zero) .and. (y3.eq.zero) )then + x_map(4,1) = (y2*x_map(1,1) - y1*x_map(2,1)) / (y2- y1) + x_map(4,2) = zero + x_map(4,3) = (y2*x_map(1,3) - y1*x_map(2,3)) / (y2- y1) + d_map(4,1:ntot_comp) = (y2*d_map(1,1:ntot_comp) & + & - y1*d_map(2,1:ntot_comp)) / (y2- y1) +! + n_map_patch = 2 + do i = 1, n_map_patch + do j = 1, num_triangle + jj = j + (i-1)*num_triangle + k = ipatch_map_12_3(jj) + x_map_patch(j,1,i) = x_map(k,1) + x_map_patch(j,2,i) = x_map(k,2) + x_map_patch(j,3,i) = x_map(k,3) + d_map_patch(j,1:ntot_comp,i) = d_map(k,1:ntot_comp) + end do + end do +! +! + else if( ((y1*y2).lt.zero) .and. ((y3*y1).lt.zero) ) then + x_map(4,1) = (y2*x_map(1,1) - y1*x_map(2,1)) / (y2- y1) + x_map(4,2) = zero + x_map(4,3) = (y2*x_map(1,3) - y1*x_map(2,3)) / (y2- y1) + d_map(4,1:ntot_comp) = (y2*d_map(1,1:ntot_comp) & + & - y1*d_map(2,1:ntot_comp)) / (y2- y1) +! + x_map(5,1) = (y1*x_map(3,1) - y3*x_map(1,1)) / (y1- y3) + x_map(5,2) = zero + x_map(5,3) = (y1*x_map(3,3) - y3*x_map(1,3)) / (y1- y3) + d_map(5,1:ntot_comp) = (y1*d_map(3,1:ntot_comp) & + & - y3*d_map(1,1:ntot_comp)) / (y1- y3) +! + n_map_patch = 3 + do i = 1, n_map_patch + do j = 1, num_triangle + jj = j + (i-1)*num_triangle + k = ipatch_map_12_31(jj) + x_map_patch(j,1,i) = x_map(k,1) + x_map_patch(j,2,i) = x_map(k,2) + x_map_patch(j,3,i) = x_map(k,3) + d_map_patch(j,1:ntot_comp,i) = d_map(k,1:ntot_comp) + end do + end do +! + else if( ((y2*y3).lt.zero) .and. (y1.eq.zero) )then + x_map(4,1) = (y3*x_map(2,1) - y2*x_map(3,1)) / (y3- y2) + x_map(4,2) = zero + x_map(4,3) = (y3*x_map(2,3) - y2*x_map(3,3)) / (y3- y2) + d_map(4,1:ntot_comp) = (y3*d_map(2,1:ntot_comp) & + & - y2*d_map(3,1:ntot_comp)) / (y3- y2) +! + n_map_patch = 2 + do i = 1, n_map_patch + do j = 1, num_triangle + jj = j + (i-1)*num_triangle + k = ipatch_map_23_1(jj) + x_map_patch(j,1,i) = x_map(k,1) + x_map_patch(j,2,i) = x_map(k,2) + x_map_patch(j,3,i) = x_map(k,3) + d_map_patch(j,1:ntot_comp,i) = d_map(k,1:ntot_comp) + end do + end do +! + else if( ((y2*y3).lt.zero) .and. ((y3*y1).lt.zero) ) then + x_map(4,1) = (y3*x_map(2,1) - y2*x_map(3,1)) / (y3- y2) + x_map(4,2) = zero + x_map(4,3) = (y3*x_map(2,3) - y2*x_map(3,3)) / (y3- y2) + d_map(4,1:ntot_comp) = (y3*d_map(2,1:ntot_comp) & + & - y2*d_map(3,1:ntot_comp)) / (y3- y2) +! + x_map(5,1) = (y1*x_map(3,1) - y3*x_map(1,1)) / (y1- y3) + x_map(5,2) = zero + x_map(5,3) = (y1*x_map(3,3) - y3*x_map(1,3)) / (y1- y3) + d_map(5,1:ntot_comp) = (y1*d_map(3,1:ntot_comp) & + & - y3*d_map(1,1:ntot_comp)) / (y1- y3) +! + n_map_patch = 3 + do i = 1, n_map_patch + do j = 1, num_triangle + jj = j + (i-1)*num_triangle + k = ipatch_map_23_31(jj) + x_map_patch(j,1,i) = x_map(k,1) + x_map_patch(j,2,i) = x_map(k,2) + x_map_patch(j,3,i) = x_map(k,3) + d_map_patch(j,1:ntot_comp,i) = d_map(k,1:ntot_comp) + end do + end do +! + else if( ((y3*y1).lt.zero) .and. (y2.eq.zero) )then + x_map(4,1) = (y1*x_map(3,1) - y3*x_map(1,1)) / (y1- y3) + x_map(4,2) = zero + x_map(4,3) = (y1*x_map(3,3) - y3*x_map(1,3)) / (y1- y3) + d_map(4,1:ntot_comp) = (y1*d_map(3,1:ntot_comp) & + & - y3*d_map(1,1:ntot_comp)) / (y1- y3) +! + n_map_patch = 2 + do i = 1, n_map_patch + do j = 1, num_triangle + jj = j + (i-1)*num_triangle + k = ipatch_map_31_2(jj) + x_map_patch(j,1,i) = x_map(k,1) + x_map_patch(j,2,i) = x_map(k,2) + x_map_patch(j,3,i) = x_map(k,3) + d_map_patch(j,1:ntot_comp,i) = d_map(k,1:ntot_comp) + end do + end do +! + else + n_map_patch = 1 + do j = 1, 3 + x_map_patch(j,1,1) = x_map(j,1) + x_map_patch(j,2,1) = x_map(j,2) + x_map_patch(j,3,1) = x_map(j,3) + d_map_patch(j,1:ntot_comp,1) = d_map(j,1:ntot_comp) + end do + end if + deallocate(d_map) +! + end subroutine s_set_map_patch_from_1patch +! +!----------------------------------------------------------------------- +! + end module map_patch_from_1patch diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/map_projection.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/map_projection.f90 new file mode 100644 index 00000000..c70a2ee0 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/map_projection.f90 @@ -0,0 +1,178 @@ +!>@file map_projection.f90 +!!@brief module map_projection +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +!!@n modified in July, 2014 +! +!>@brief Structure for cross sectioning +!! +!!@verbatim +!! subroutine MAP_PROJECTION_initialize & +!! & (increment_psf, elps_PSF, elps_MAP, geofem, edge_comm, & +!! & nod_fld, map_ctls, map, SR_sig, SR_il) +!! type(elapsed_lables), intent(in) :: elps_PSF, elps_MAP +!! type(mesh_data), intent(in) :: geofem +!! type(communication_table), intent(in) :: edge_comm +!! type(phys_data), intent(in) :: nod_fld +!! type(map_rendering_controls), intent(inout) :: map_ctls +!! type(map_rendering_module), intent(inout) :: map +!! type(send_recv_status), intent(inout) :: SR_sig +!! type(send_recv_int8_buffer), intent(inout) :: SR_il +!! subroutine MAP_PROJECTION_visualize & +!! & (istep_psf, elps_PSF, elps_MAP, time_d, & +!! & geofem, nod_fld, map, SR_sig) +!! type(elapsed_lables), intent(in) :: elps_PSF, elps_MAP +!! type(time_data), intent(in) :: time_d +!! type(mesh_data), intent(in) :: geofem +!! type(phys_data), intent(in) :: nod_fld +!! subroutine MAP_PROJECTION_finalize(map) +!! type(map_rendering_module), intent(inout) :: map +!!@endverbatim + module map_projection +! + use m_precision + use m_work_time +! + use calypso_mpi + use t_map_projection +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine MAP_PROJECTION_initialize & + & (increment_psf, elps_PSF, elps_MAP, geofem, edge_comm, & + & nod_fld, map_ctls, map, SR_sig, SR_il) +! + use m_geometry_constants +! + use calypso_mpi + use set_map_control + use search_ele_list_for_psf + use set_const_4_sections + use find_node_and_patch_psf + use set_fields_for_psf + use multi_map_projections +! + integer(kind = kint), intent(in) :: increment_psf + type(elapsed_lables), intent(in) :: elps_PSF, elps_MAP + type(mesh_data), intent(in) :: geofem + type(communication_table), intent(in) :: edge_comm + type(phys_data), intent(in) :: nod_fld +! + type(map_rendering_controls), intent(inout) :: map_ctls + type(map_rendering_module), intent(inout) :: map + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_int8_buffer), intent(inout) :: SR_il +! + integer(kind = kint) :: i_psf +! +! + map%num_map = map_ctls%num_map_ctl + if(increment_psf .le. 0) map%num_map = 0 + if(map%num_map .le. 0) return +! + if(elps_PSF%flag_elapsed) & + & call start_elapsed_time(elps_PSF%ist_elapsed+1) + call init_psf_case_tables(map%psf_case_tbls) +! + if (iflag_debug.eq.1) write(*,*) 'alloc_map_rendering_module' + call alloc_map_rendering_module(map) +! + call s_set_map_control(map%num_map, geofem%group, nod_fld, & + & map_ctls, map%map_param, map%map_def, map%map_mesh, & + & map%view_param, map%color_param, map%cbar_param, & + & map%map_data, map%map_rgb) +! + if (iflag_debug.eq.1) write(*,*) 'set_search_mesh_list_4_psf' + call set_search_mesh_list_4_psf & + & (map%num_map, geofem%mesh, geofem%group, & + & map%map_param, map%psf_search) +! +! + do i_psf = 1, map%num_map + call alloc_node_param_smp(map%map_mesh(i_psf)%node) + call alloc_ele_param_smp(map%map_mesh(i_psf)%patch) +! + call alloc_ref_field_4_psf & + & (geofem%mesh%node, map%map_list(i_psf)) + end do +! + if (iflag_debug.eq.1) write(*,*) 'set_const_4_crossections' + call set_const_4_crossections & + & (map%num_map, map%map_def, geofem%mesh%node, map%map_list) +! + if (iflag_debug.eq.1) write(*,*) 'set_node_and_patch_psf' + call set_node_and_patch_psf & + & (map%num_map, geofem%mesh, geofem%group, edge_comm, & + & map%psf_case_tbls, map%map_def, map%psf_search, map%map_list, & + & map%map_grp_list, map%map_mesh, SR_sig, SR_il) +! + call alloc_psf_field_data(map%num_map, map%map_mesh) + if(elps_PSF%flag_elapsed) & + & call end_elapsed_time(elps_PSF%ist_elapsed+1) +! + if (iflag_debug.eq.1) write(*,*) 'output_section_mesh' + call init_multi_map_projections & + & (elps_MAP, map%num_map, map%view_param, map%map_mesh, & + & map%map_psf_dat, map%map_data, map%map_rgb, SR_sig) +! + end subroutine MAP_PROJECTION_initialize +! +! --------------------------------------------------------------------- +! + subroutine MAP_PROJECTION_visualize & + & (istep_psf, elps_PSF, elps_MAP, time_d, & + & geofem, nod_fld, map, SR_sig) +! + use set_fields_for_psf + use set_ucd_data_to_type + use multi_map_projections +! + integer(kind = kint), intent(in) :: istep_psf + type(elapsed_lables), intent(in) :: elps_PSF, elps_MAP + type(time_data), intent(in) :: time_d + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld +! + type(map_rendering_module), intent(inout) :: map + type(send_recv_status), intent(inout) :: SR_sig +! +! + if(map%num_map.le.0 .or. istep_psf.le.0) return +! + if(elps_PSF%flag_elapsed) & + & call start_elapsed_time(elps_PSF%ist_elapsed+2) + call set_field_4_psf(map%num_map, geofem%mesh%edge, nod_fld, & + & map%map_def, map%map_param, map%map_list, map%map_grp_list, & + & map%map_mesh) + if(elps_PSF%flag_elapsed) & + & call end_elapsed_time(elps_PSF%ist_elapsed+2) +! + if(iflag_debug.eq.1) write(*,*) 'output_section_data' + call s_multi_map_projections(map%num_map, istep_psf, elps_MAP, & + & time_d, map%map_mesh, map%color_param, map%cbar_param, & + & map%map_psf_dat, map%map_data, map%map_rgb, SR_sig) +! + end subroutine MAP_PROJECTION_visualize +! +! --------------------------------------------------------------------- +! + subroutine MAP_PROJECTION_finalize(map) +! + type(map_rendering_module), intent(inout) :: map +! +! + if(map%num_map .le. 0) return + call dealloc_map_rendering_module(map) +! + end subroutine MAP_PROJECTION_finalize +! +! --------------------------------------------------------------------- +! + end module map_projection diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/multi_map_projections.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/multi_map_projections.f90 new file mode 100644 index 00000000..887315cf --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/multi_map_projections.f90 @@ -0,0 +1,179 @@ +!>@file multi_map_projections.f90 +!!@brief module multi_map_projections +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +!!@n modified in July, 2014 +! +!>@brief loop for map projections +!! +!!@verbatim +!! subroutine init_multi_map_projections & +!! & (elps_MAP, num_map, view_param, psf_mesh, psf_dat, & +!! & map_data, map_rgb, SR_sig) +!! type(elapsed_lables), intent(in) :: elps_MAP +!! integer(kind= kint), intent(in) :: num_map +!! type(psf_local_data), intent(in) :: psf_mesh(num_map) +!! type(pvr_view_parameter), intent(in):: view_param(num_map) +!! type(psf_results), intent(inout) :: psf_dat(num_map) +!! type(map_rendering_data), intent(inout) :: map_data(num_map) +!! type(pvr_image_type), intent(inout) :: map_rgb(num_map) +!! type(send_recv_status), intent(inout) :: SR_sig +!! subroutine s_multi_map_projections(num_map, istep_psf, elps_MAP,& +!! & time_d, psf_mesh, color_param, cbar_param, psf_dat, & +!! & map_data, map_rgb, SR_sig) +!! integer(kind= kint), intent(in) :: num_map +!! integer(kind= kint), intent(in) :: istep_psf +!! type(elapsed_lables), intent(in) :: elps_MAP +!! type(time_data), intent(in) :: time_d +!! type(psf_local_data), intent(in) :: psf_mesh(num_map) +!! type(pvr_colormap_parameter), intent(in) & +!! & :: color_param(num_map) +!! type(pvr_colorbar_parameter), intent(in) :: cbar_param(num_map) +!! type(psf_results), intent(inout) :: psf_dat(num_map) +!! type(map_rendering_data), intent(inout) :: map_data(num_map) +!! type(pvr_image_type), intent(inout) :: map_rgb(num_map) +!! type(send_recv_status), intent(inout) :: SR_sig +!!@endverbatim + module multi_map_projections +! + use calypso_mpi + use m_precision +! + use t_geometry_data + use t_phys_data + use t_solver_SR + use t_control_params_4_pvr + use t_pvr_colormap_parameter + use t_map_rendering_data +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine init_multi_map_projections & + & (elps_MAP, num_map, view_param, psf_mesh, psf_dat, & + & map_data, map_rgb, SR_sig) +! + use m_work_time + use t_psf_patch_data + use t_psf_results + use t_pvr_image_array +! + use collect_psf_mesh_field +! + integer(kind= kint), intent(in) :: num_map + type(elapsed_lables), intent(in) :: elps_MAP + type(psf_local_data), intent(in) :: psf_mesh(num_map) + type(pvr_view_parameter), intent(in):: view_param(num_map) +! + type(psf_results), intent(inout) :: psf_dat(num_map) + type(map_rendering_data), intent(inout) :: map_data(num_map) + type(pvr_image_type), intent(inout) :: map_rgb(num_map) + type(send_recv_status), intent(inout) :: SR_sig +! + integer(kind= kint) :: i_map +! +! + if(elps_MAP%flag_elapsed) & + & call start_elapsed_time(elps_MAP%ist_elapsed+1) + do i_map = 1, num_map + map_rgb(i_map)%irank_image_file = mod(i_map,nprocs) + call alloc_pvr_image_array(view_param(i_map)%n_pvr_pixel, & + & map_rgb(i_map)) + call init_map_rendering_data(view_param(i_map), & + & map_rgb(i_map), map_data(i_map)) + end do +! + do i_map = 1, num_map + call init_merge_psf_mesh & + & (map_rgb(i_map)%irank_image_file, psf_mesh(i_map), & + & psf_dat(i_map)%psf_nod, psf_dat(i_map)%psf_ele, & + & psf_dat(i_map)%psf_phys, SR_sig) + end do + if(elps_MAP%flag_elapsed) & + & call end_elapsed_time(elps_MAP%ist_elapsed+1) +! + end subroutine init_multi_map_projections +! +! --------------------------------------------------------------------- +! + subroutine s_multi_map_projections(num_map, istep_psf, elps_MAP, & + & time_d, psf_mesh, color_param, cbar_param, psf_dat, & + & map_data, map_rgb, SR_sig) +! + use m_work_time + use t_psf_patch_data + use t_psf_results + use t_pvr_image_array +! + use collect_psf_mesh_field + use xyz_plane_rendering + use write_PVR_image +! + integer(kind= kint), intent(in) :: num_map + integer(kind= kint), intent(in) :: istep_psf + type(elapsed_lables), intent(in) :: elps_MAP + type(time_data), intent(in) :: time_d + type(psf_local_data), intent(in) :: psf_mesh(num_map) + type(pvr_colormap_parameter), intent(in) & + & :: color_param(num_map) + type(pvr_colorbar_parameter), intent(in) :: cbar_param(num_map) +! + type(psf_results), intent(inout) :: psf_dat(num_map) + type(map_rendering_data), intent(inout) :: map_data(num_map) + type(pvr_image_type), intent(inout) :: map_rgb(num_map) + type(send_recv_status), intent(inout) :: SR_sig +! + integer(kind= kint) :: i_map +! +! + if(elps_MAP%flag_elapsed) & + & call start_elapsed_time(elps_MAP%ist_elapsed+1) + do i_map = 1, num_map + call collect_psf_scalar(map_rgb(i_map)%irank_image_file, ione, & + & psf_mesh(i_map)%node, psf_mesh(i_map)%field, & + & psf_dat(i_map)%psf_phys%d_fld(1,1), SR_sig) + call collect_psf_scalar(map_rgb(i_map)%irank_image_file, itwo, & + & psf_mesh(i_map)%node, psf_mesh(i_map)%field, & + & psf_dat(i_map)%psf_phys%d_fld(1,2), SR_sig) + end do + if(elps_MAP%flag_elapsed) & + & call end_elapsed_time(elps_MAP%ist_elapsed+1) +! + if(elps_MAP%flag_elapsed) & + & call start_elapsed_time(elps_MAP%ist_elapsed+2) + do i_map = 1, num_map + if(map_data(i_map)%iflag_2d_projection_mode & + & .eq. iflag_aitoff) then + call aitoff_projection_rendering & + & (time_d, psf_dat(i_map)%psf_nod, psf_dat(i_map)%psf_ele, & + & psf_dat(i_map)%psf_phys, color_param(i_map), & + & cbar_param(i_map), map_data(i_map), map_rgb(i_map)) + else + call s_xyz_plane_rendering & + & (time_d, psf_dat(i_map)%psf_nod, psf_dat(i_map)%psf_ele, & + & psf_dat(i_map)%psf_phys, color_param(i_map), & + & cbar_param(i_map), map_data(i_map), map_rgb(i_map)) + end if + end do + if(elps_MAP%flag_elapsed) & + & call end_elapsed_time(elps_MAP%ist_elapsed+2) +! + if(elps_MAP%flag_elapsed) & + & call start_elapsed_time(elps_MAP%ist_elapsed+3) + do i_map = 1, num_map + call sel_write_pvr_image_file(istep_psf, -1, map_rgb(i_map)) + end do + if(elps_MAP%flag_elapsed) & + & call end_elapsed_time(elps_MAP%ist_elapsed+3) +! + end subroutine s_multi_map_projections +! +! --------------------------------------------------------------------- +! + end module multi_map_projections diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/set_map_control.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/set_map_control.f90 new file mode 100644 index 00000000..dc66dea8 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/set_map_control.f90 @@ -0,0 +1,290 @@ +!>@file set_map_control.f90 +!!@brief module set_map_control +!! +!!@author H. Matsui +!!@date Programmed in May., 2006 +!!@n Modified in June, 1015 +! +!>@brief Structure for parallel sectioned data +!! +!!@verbatim +!! subroutine s_set_map_control(num_map, group, nod_fld, map_ctls, & +!! & psf_param, psf_def, psf_mesh, view_param, color_param,& +!! & cbar_param, map_data, map_rgb) +!! type(mesh_groups), intent(in) :: group +!! type(phys_data), intent(in) :: nod_fld +!! type(map_rendering_controls), intent(inout) :: map_ctls +!! type(psf_parameters), intent(inout) :: psf_param(num_map) +!! type(section_define), intent(inout) :: psf_def(num_map) +!! type(psf_local_data), intent(inout) :: psf_mesh(num_map) +!! type(pvr_view_parameter), intent(inout) :: view_param(num_map) +!! type(pvr_colormap_parameter), intent(inout) & +!! & :: color_param(num_map) +!! type(pvr_colorbar_parameter), intent(inout) & +!! & :: cbar_param(num_map) +!! type(map_rendering_data), intent(inout) :: map_data(num_map) +!! type(pvr_image_type), intent(inout) :: map_rgb(num_map) +!!@endverbatim +! + module set_map_control +! + use m_precision + use m_machine_parameter +! + use t_mesh_data + use t_phys_data + use t_control_data_maps + use t_control_data_4_map + use t_control_params_4_psf + use t_psf_patch_data + use t_control_params_4_pvr + use t_pvr_colormap_parameter + use t_map_rendering_data + use t_pvr_image_array +! + implicit none +! + character(len=kchara), parameter, private & + & :: default_map_prefix = 'map' +! + private :: count_control_4_map, set_control_4_map +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_set_map_control(num_map, group, nod_fld, map_ctls, & + & psf_param, psf_def, psf_mesh, view_param, color_param, & + & cbar_param, map_data, map_rgb) +! + use calypso_mpi + use t_read_control_elements + use t_psf_patch_data +! + use set_field_comp_for_viz + use mpi_abort_by_missing_zlib +! + use set_psf_control +! + integer(kind= kint), intent(in) :: num_map + type(mesh_groups), intent(in) :: group + type(phys_data), intent(in) :: nod_fld +! + type(map_rendering_controls), intent(inout) :: map_ctls + type(psf_parameters), intent(inout) :: psf_param(num_map) + type(section_define), intent(inout) :: psf_def(num_map) + type(psf_local_data), intent(inout) :: psf_mesh(num_map) + type(pvr_view_parameter), intent(inout) :: view_param(num_map) + type(pvr_colormap_parameter), intent(inout) & + & :: color_param(num_map) + type(pvr_colorbar_parameter), intent(inout) & + & :: cbar_param(num_map) + type(map_rendering_data), intent(inout) :: map_data(num_map) + type(pvr_image_type), intent(inout) :: map_rgb(num_map) +! + integer(kind = kint) :: i, ierr +! +! + do i = 1, num_map + call count_control_4_map(my_rank, map_ctls%map_ctl_struct(i), & + & group%ele_grp, psf_param(i), map_rgb(i), ierr) +! + if(ierr.gt.0) call calypso_MPI_abort(ierr, e_message) + call mpi_abort_by_no_zlib_in_fld(map_rgb(i)%pvr_prefix, & + & map_rgb(i)%id_pvr_file_type) + end do +! + do i = 1, num_map + psf_mesh(i)%field%num_phys = 2 + call alloc_phys_name(psf_mesh(i)%field) + call set_control_4_map & + & (map_ctls%map_ctl_struct(i), group%ele_grp, group%surf_grp, & + & nod_fld%num_phys, nod_fld%phys_name, psf_mesh(i)%field, & + & psf_param(i), psf_def(i), view_param(i), color_param(i), & + & cbar_param(i), map_data(i), ierr) + if(ierr.gt.0) call calypso_MPI_abort(ierr, e_message) +! + call dealloc_cont_dat_4_map(map_ctls%map_ctl_struct(i)) +! + call count_total_comps_4_viz(psf_mesh(i)%field) + end do +! + call dealloc_map_ctl_stract(map_ctls) +! + end subroutine s_set_map_control +! +! -------------------------------------------------------------------- +! -------------------------------------------------------------------- +! + subroutine count_control_4_map(id_rank, map_c, ele_grp, & + & psf_param, map_rgb, ierr) +! + use m_error_IDs + use m_file_format_switch + use set_area_4_viz + use set_sections_file_ctl + use set_field_comp_for_viz + use set_sections_file_ctl + use delete_data_files +! + type(group_data), intent(in) :: ele_grp +! + integer, intent(in) :: id_rank +! + type(map_ctl), intent(in) :: map_c + type(psf_parameters), intent(inout) :: psf_param + type(pvr_image_type), intent(inout) :: map_rgb + integer(kind = kint), intent(inout) :: ierr +! +! + ierr = 0 + call set_image_file_control(map_c%map_image_fmt_ctl, & + & map_rgb%id_pvr_file_type) +! + if(map_c%map_image_prefix_ctl%iflag .le. 0) then + map_rgb%pvr_prefix = default_map_prefix + else + map_rgb%pvr_prefix = map_c%map_image_prefix_ctl%charavalue + end if +! + if(check_file_writable(id_rank, map_rgb%pvr_prefix) & + & .eqv. .FALSE.) then + ierr = ierr_VIZ + return + end if +! + call count_control_4_psf_define & + & (map_c%map_define_ctl%psf_def_c, ele_grp, psf_param, ierr) +! + end subroutine count_control_4_map +! +! --------------------------------------------------------------------- +! + subroutine set_control_4_map(map_c, ele_grp, sf_grp, & + & num_nod_phys, phys_nod_name, psf_fld, psf_param, & + & psf_def, view_param, color_param, cbar_param, & + & map_data, ierr) +! + use calypso_mpi + use m_error_IDs + use skip_comment_f + use set_field_comp_for_viz + use set_pvr_modelview_matrix + use set_control_pvr_color +! + type(group_data), intent(in) :: ele_grp + type(surface_group_data), intent(in) :: sf_grp + type(map_ctl), intent(in) :: map_c +! + integer(kind = kint), intent(in) :: num_nod_phys + character(len=kchara), intent(in) :: phys_nod_name(num_nod_phys) +! + type(phys_data), intent(inout) :: psf_fld + type(psf_parameters), intent(inout) :: psf_param + type(section_define), intent(inout) :: psf_def + type(pvr_view_parameter), intent(inout) :: view_param + type(pvr_colormap_parameter), intent(inout) :: color_param + type(pvr_colorbar_parameter), intent(inout) :: cbar_param + type(map_rendering_data), intent(inout) :: map_data + integer(kind = kint), intent(inout) :: ierr +! +! + call alloc_area_group_psf(psf_param) + call set_control_psf_define(map_c%map_define_ctl%psf_def_c, & + & ele_grp, sf_grp, psf_param, psf_def, ierr) +! + if(ierr .gt. 0) call calypso_MPI_abort(ierr_VIZ, & + & 'Check surface parameter') +! + call alloc_output_comps_psf(itwo, psf_param) + map_data%fill_flag = .FALSE. + if((map_c%map_field_ctl%iflag*map_c%map_comp_ctl%iflag) & + & .gt. 0) then + map_data%fill_flag = .TRUE. + call set_one_component_4_viz(num_nod_phys, phys_nod_name, & + & map_c%map_field_ctl%charavalue, & + & map_c%map_comp_ctl%charavalue, & + & psf_param%id_output(1), psf_param%icomp_output(1), & + & psf_fld%num_component(1), psf_param%ncomp_org(1), & + & psf_fld%phys_name(1)) + if(psf_fld%num_component(1) .gt. 1) & + & call calypso_MPI_abort(ierr_VIZ, 'set scalar for rendering') + end if +! + if((map_c%isoline_field_ctl%iflag*map_c%isoline_comp_ctl%iflag) & + & .gt. 0) then + call set_one_component_4_viz(num_nod_phys, phys_nod_name, & + & map_c%isoline_field_ctl%charavalue, & + & map_c%isoline_comp_ctl%charavalue, & + & psf_param%id_output(2), psf_param%icomp_output(2), & + & psf_fld%num_component(2), psf_param%ncomp_org(2), & + & psf_fld%phys_name(2)) + if(psf_fld%num_component(2) .gt. 1) & + & call calypso_MPI_abort(ierr_VIZ, 'set scalar for isolines') + end if +! + if(psf_param%id_output(1) .le. 0 & + & .and. psf_param%id_output(2) .le. 0) then + call calypso_MPI_abort(ierr_VIZ, & + & 'set either field for rendering or isolines') + else if(psf_param%id_output(1) .gt. 0 & + & .and. psf_param%id_output(2) .le. 0) then + psf_param%id_output(2) = psf_param%id_output(1) + psf_param%icomp_output(2) = psf_param%icomp_output(1) + psf_param%ncomp_org(2) = psf_param%ncomp_org(1) + psf_fld%num_component(2) = psf_fld%num_component(1) + psf_fld%phys_name(2) = psf_fld%phys_name(1) + else if(psf_param%id_output(2) .gt. 0 & + & .and. psf_param%id_output(1) .le. 0) then + psf_param%id_output(1) = psf_param%id_output(2) + psf_param%icomp_output(1) = psf_param%icomp_output(2) + psf_param%ncomp_org(1) = psf_param%ncomp_org(2) + psf_fld%num_component(1) = psf_fld%num_component(2) + psf_fld%phys_name(1) = psf_fld%phys_name(2) + end if +! + call copy_pvr_image_size(map_c%mat%pixel, view_param) + call copy_pvr_perspective_matrix(map_c%mat%proj, view_param) +! + call set_control_pvr_colormap(map_c%cmap_cbar_c%color, & + & color_param) + call set_control_pvr_colorbar(map_c%cmap_cbar_c%cbar_ctl, & + & cbar_param) + cbar_param%iflag_opacity = 0 +! + call set_ctl_map_rendering_param & + & (map_c%mat%projection_type_ctl, map_c%mat%proj, & + & map_c%map_define_ctl, map_data) +! + end subroutine set_control_4_map +! +! --------------------------------------------------------------------- +! + subroutine set_image_file_control(file_fmt_ctl, id_pvr_file_type) +! + use skip_comment_f + use t_control_array_character + use output_image_sel_4_png +! + type(read_character_item), intent(in) :: file_fmt_ctl + integer(kind = kint), intent(inout) :: id_pvr_file_type +! + character(len = kchara) :: tmpchara +! +! + tmpchara = file_fmt_ctl%charavalue + if(cmp_no_case(tmpchara, hd_PNG)) then + id_pvr_file_type = iflag_PNG + else if(cmp_no_case(tmpchara, hd_BMP)) then + id_pvr_file_type = iflag_BMP + else + id_pvr_file_type = iflag_BMP + end if +! + end subroutine set_image_file_control +! +! --------------------------------------------------------------------- +! + end module set_map_control diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/set_scalar_on_xyz_plane.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/set_scalar_on_xyz_plane.f90 new file mode 100644 index 00000000..4aa73333 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/set_scalar_on_xyz_plane.f90 @@ -0,0 +1,181 @@ +!>@file set_scalar_on_xyz_plane.f90 +!!@brief module set_scalar_on_xyz_plane +!! +!!@author H. Matsui +!!@date Programmed in June, 2023 +! +!>@brief Subroutines for plane projection +!!@verbatim +!! subroutine sel_scalar_on_xyz_plane(psf_nod, psf_ele, d_scalar, & +!! & map_data, pvr_rgb, map_e) +!! type(node_data), intent(in) :: psf_nod +!! type(element_data), intent(in) :: psf_ele +!! real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +!! type(map_rendering_data), intent(inout) :: map_data +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!! type(map_patches_for_1patch), intent(inout) :: map_e +!!@endverbatim + module set_scalar_on_xyz_plane +! + use m_precision + use m_constants +! + use t_geometry_data + use t_phys_data + use t_map_rendering_data + use t_map_patch_from_1patch + use t_pvr_colormap_parameter + use t_pvr_image_array +! + implicit none +! + private :: set_scalar_on_xy_plane, set_scalar_on_xz_plane + private :: set_scalar_on_yz_plane +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine sel_scalar_on_xyz_plane(color_param, & + & psf_nod, psf_ele, d_scalar, map_data, pvr_rgb, map_e) +! + use draw_pixels_on_map +! + type(pvr_colormap_parameter), intent(in) :: color_param + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +! + type(map_rendering_data), intent(inout) :: map_data + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! +! + if(map_data%iflag_2d_projection_mode .eq. iflag_xy_plane) then + call set_scalar_on_xy_plane(color_param, psf_nod, psf_ele, & + & d_scalar, map_data, pvr_rgb, map_e) + else if(map_data%iflag_2d_projection_mode .eq. iflag_xz_plane) & + & then + call set_scalar_on_xz_plane(color_param, psf_nod, psf_ele, & + & d_scalar, map_data, pvr_rgb, map_e) + else if(map_data%iflag_2d_projection_mode .eq. iflag_yz_plane) & + & then + call set_scalar_on_yz_plane(color_param, psf_nod, psf_ele, & + & d_scalar, map_data, pvr_rgb, map_e) + end if +! + end subroutine sel_scalar_on_xyz_plane +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_scalar_on_xy_plane(color_param, psf_nod, psf_ele, & + & d_scalar, map_data, pvr_rgb, map_e) +! + use set_xyz_plot_from_1patch + use map_patch_from_1patch + use draw_pixels_on_map +! + type(pvr_colormap_parameter), intent(in) :: color_param + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data +! + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: iele +! +! + do iele = 1, psf_ele%numele + call set_xy_plot_from_1patch(psf_nod, psf_ele, d_scalar, iele, & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1)) + call fill_triangle_data_on_image(color_param, & + & map_data%xmin_frame, map_data%xmax_frame, & + & map_data%ymin_frame, map_data%ymax_frame, & + & pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1), & + & pvr_rgb%rgba_real_gl) + end do +! + end subroutine set_scalar_on_xy_plane +! +! --------------------------------------------------------------------- +! + subroutine set_scalar_on_xz_plane(color_param, psf_nod, psf_ele, & + & d_scalar, map_data, pvr_rgb, map_e) +! + use t_map_patch_from_1patch + use set_xyz_plot_from_1patch + use map_patch_from_1patch + use draw_pixels_on_map +! + type(pvr_colormap_parameter), intent(in) :: color_param + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data +! + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: iele +! +! + do iele = 1, psf_ele%numele + call set_xz_plot_from_1patch(psf_nod, psf_ele, d_scalar, iele, & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1)) + call fill_triangle_data_on_image(color_param, & + & map_data%xmin_frame, map_data%xmax_frame, & + & map_data%ymin_frame, map_data%ymax_frame, & + & pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1), & + & pvr_rgb%rgba_real_gl) + end do +! + end subroutine set_scalar_on_xz_plane +! +! --------------------------------------------------------------------- +! + subroutine set_scalar_on_yz_plane(color_param, psf_nod, psf_ele, & + & d_scalar, map_data, pvr_rgb, map_e) +! + use t_map_patch_from_1patch + use set_xyz_plot_from_1patch + use map_patch_from_1patch + use draw_pixels_on_map +! + type(pvr_colormap_parameter), intent(in) :: color_param + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + type(map_rendering_data), intent(in) :: map_data +! + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +! + type(pvr_image_type), intent(inout) :: pvr_rgb + type(map_patches_for_1patch), intent(inout) :: map_e +! + integer(kind = kint) :: iele +! +! + do iele = 1, psf_ele%numele + call set_yz_plot_from_1patch(psf_nod, psf_ele, d_scalar, iele, & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1)) + call fill_triangle_data_on_image(color_param, & + & map_data%xmin_frame, map_data%xmax_frame, & + & map_data%ymin_frame, map_data%ymax_frame, & + & pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & map_e%xy_map(1,1,1), map_e%d_map_patch(1,1), & + & pvr_rgb%rgba_real_gl) + end do +! + end subroutine set_scalar_on_yz_plane +! +! --------------------------------------------------------------------- +! + end module set_scalar_on_xyz_plane diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/set_xyz_plot_from_1patch.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/set_xyz_plot_from_1patch.f90 new file mode 100644 index 00000000..2ff9826a --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/set_xyz_plot_from_1patch.f90 @@ -0,0 +1,113 @@ +!>@file set_xyz_plot_from_1patch.f90 +!!@brief module set_xyz_plot_from_1patch +!! +!!@author H. Matsui +!!@date Programmed in June, 2023 +! +!>@brief Subroutines for plane projection +!!@verbatim +!! subroutine set_xy_plot_from_1patch(psf_nod, psf_ele, d_scalar, & +!! & iele, xy_patch, d_patch) +!! subroutine set_xz_plot_from_1patch(psf_nod, psf_ele, d_scalar, & +!! & iele, xy_patch, d_patch) +!! subroutine set_yz_plot_from_1patch(psf_nod, psf_ele, d_scalar, & +!! & iele, xy_patch, d_patch) +!! type(node_data), intent(in) :: psf_nod +!! type(element_data), intent(in) :: psf_ele +!! real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) +!! integer(kind = kint), intent(in) :: iele +!! real(kind = kreal), intent(inout) :: xy_patch(2,3) +!! real(kind = kreal), intent(inout) :: d_patch(3) +!!@endverbatim + module set_xyz_plot_from_1patch +! + use m_precision + use m_constants +! + use t_geometry_data +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_xy_plot_from_1patch(psf_nod, psf_ele, d_scalar, & + & iele, xy_patch, d_patch) +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) + integer(kind = kint), intent(in) :: iele +! + real(kind = kreal), intent(inout) :: xy_patch(2,3) + real(kind = kreal), intent(inout) :: d_patch(3) +! + integer(kind = kint) :: k1, inod +! +! + do k1 = 1, 3 + inod = psf_ele%ie(iele,k1) +! + xy_patch(1,k1) = psf_nod%xx(inod,1) + xy_patch(2,k1) = psf_nod%xx(inod,2) + d_patch(k1) = d_scalar(inod) + end do +! + end subroutine set_xy_plot_from_1patch +! +! --------------------------------------------------------------------- +! + subroutine set_xz_plot_from_1patch(psf_nod, psf_ele, d_scalar, & + & iele, xy_patch, d_patch) +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) + integer(kind = kint), intent(in) :: iele +! + real(kind = kreal), intent(inout) :: xy_patch(2,3) + real(kind = kreal), intent(inout) :: d_patch(3) +! + integer(kind = kint) :: k1, inod +! + do k1 = 1, 3 + inod = psf_ele%ie(iele,k1) + xy_patch(1,k1) = psf_nod%xx(inod,1) + xy_patch(2,k1) = psf_nod%xx(inod,3) + d_patch(k1) = d_scalar(inod) + end do +! + end subroutine set_xz_plot_from_1patch +! +! --------------------------------------------------------------------- +! + subroutine set_yz_plot_from_1patch(psf_nod, psf_ele, d_scalar, & + & iele, xy_patch, d_patch) +! + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele + real(kind= kreal), intent(in) :: d_scalar(psf_nod%numnod) + integer(kind = kint), intent(in) :: iele +! + real(kind = kreal), intent(inout) :: xy_patch(2,3) + real(kind = kreal), intent(inout) :: d_patch(3) +! + integer(kind = kint) :: k1, inod +! +! + do k1 = 1, 3 + inod = psf_ele%ie(iele,k1) +! + xy_patch(1,k1) = psf_nod%xx(inod,1) + xy_patch(2,k1) = psf_nod%xx(inod,2) + d_patch(k1) = d_scalar(inod) + end do +! + end subroutine set_yz_plot_from_1patch +! +! --------------------------------------------------------------------- +! + end module set_xyz_plot_from_1patch diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/t_control_data_4_map.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/t_control_data_4_map.f90 new file mode 100644 index 00000000..4c3c7afa --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/t_control_data_4_map.f90 @@ -0,0 +1,305 @@ +!>@file t_control_data_4_map.f90 +!!@brief module t_control_data_4_map +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief control ID data for surfacing module +!! +!!@verbatim +!! subroutine dealloc_cont_dat_4_map(map_c) +!! type(map_ctl), intent(inout) :: map_c +!! subroutine dup_control_4_map(org_map_c, new_map_c) +!! type(map_ctl), intent(in) :: org_map_c +!! type(map_ctl), intent(inout) :: new_map_c +!! +!! subroutine add_fields_4_map_to_fld_ctl(map_c, field_ctl) +!! type(map_ctl), intent(in) :: map_c +!! type(ctl_array_c3), intent(inout) :: field_ctl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! example of control for Kemo's surface rendering +!! +!! begin cross_section_ctl +!! map_image_prefix 'map' +!! map_image_format PNG +!! +!! output_field magnetic_field +!! output_component r +!! +!! isoline_field magnetic_field +!! isoline_component r +!! +!! begin section_ctl +!! file surface_define ctl_psf_eq +!! begin surface_define +!! section_method equation +!! +!! array coefs_ctl 10 +!! coefs_ctl x2 1.0 +!! coefs_ctl y2 1.0 +!! coefs_ctl z2 0.0 +!! coefs_ctl xy 0.0 +!! coefs_ctl yz 0.0 +!! coefs_ctl zx 0.0 +!! coefs_ctl x 0.0 +!! coefs_ctl y 0.0 +!! coefs_ctl z 0.0 +!! coefs_ctl const 1.0 +!! end array coefs_ctl +!! +!! array section_area_ctl 1 +!! section_area_ctl outer_core end +!! end array section_area_ctl +!! end surface_define +!! +!! zeroline_switch_ctl On +!! isoline_color_mode color, white, or black +!! isoline_number_ctl 20 +!! isoline_range_ctl -0.5 0.5 +!! isoline_width_ctl 1.5 +!! grid_width_ctl 1.0 +!! +!! tangent_cylinder_switch_ctl On +!! inner_radius_ctl 0.53846 +!! outer_radius_ctl 1.53846 +!! end section_ctl +!! +!! begin map_projection_ctl +!! begin image_size_ctl +!! x_pixel_ctl 640 +!! y_pixel_ctl 480 +!! end image_size_ctl +!! +!! projection_type_ctl Aitoff, xy_plane, xz_plane, yz_plane +!! begin projection_matrix_ctl +!! perspective_xy_ratio_ctl 1.0 +!! horizontal_range_ctl -2.4 2.4 +!! vertical_range_ctl -1.2 1.2 +!! end projection_matrix_ctl +!! end map_projection_ctl +!! +!! begin colormap_ctl +!! colormap_mode_ctl rainbow +!! background_color_ctl 0.0 0.0 0.0 +!! +!! data_mapping_ctl Colormap_list +!! array color_table_ctl +!! color_table_ctl 0.0 0.0 +!! color_table_ctl 0.5 0.5 +!! color_table_ctl 1.0 1.0 +!! end array color_table_ctl +!! end colormap_ctl +!! +!! begin colorbar_ctl +!! colorbar_switch_ctl ON +!! colorbar_position_ctl 'left' or 'bottom' +!! colorbar_scale_ctl ON +!! zeromarker_switch ON +!! colorbar_range 0.0 1.0 +!! font_size_ctl 3 +!! num_grid_ctl 4 +!!! +!! axis_label_switch ON +!! end colorbar_ctl +!! end cross_section_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! map_image_format: +!! ucd, VTK +!! +!! num_result_comp: number of fields +!! output_field: (Original name: color_comp and color_subcomp) +!! field and componenet name for output +!! x, y, z, radial, elevation, azimuth, cylinder_r, norm +!! vector, sym_tensor, asym_tensor +!! spherical_vector, cylindrical_vector +!! output_value: (Original name: specified_color) +!! +!! section_method: (original: method) +!! sphere, ellipsoid, equation, group +!! center_position: position of center (for sphere and plane) +!! array center_position 3 +!! center_position x 0.0 +!! center_position y 0.0 +!! center_position z 0.0 +!! end array center_position +!! radius: radius of sphere +!! axial_length: length of axis +!! (for ellipsoid, hyperboloid, paraboloid) +!! array axial_length 3 +!! axial_length x 1.0 +!! axial_length y 0.5 +!! axial_length z 0.0 +!! end array axial_length +!! coefficients: coefficients for equation +!! array coefs_ctl 10 +!! coefs_ctl x2 1.0 +!! coefs_ctl y2 0.5 +!! coefs_ctl z2 0.0 +!! coefs_ctl xy 1.0 +!! coefs_ctl yz 0.5 +!! coefs_ctl zx 0.0 +!! coefs_ctl x 1.0 +!! coefs_ctl y 0.5 +!! coefs_ctl z 0.0 +!! coefs_ctl const 1.0 +!! end array coefs_ctl +!! group_type: (Original: defined_style) +!! node_group or surface_group +!! group_name: name of group to plot +!! +!! field type: +!! scalar, vector, sym_tensor, asym_tensor +!! spherical_vector, spherical_sym_tensor +!! cylindrical_vector, cylindrical_sym_tensor +!! norm +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_control_data_4_map +! + use m_precision +! + use m_constants + use m_machine_parameter + use skip_comment_f + use t_read_control_elements + use t_control_array_character + use t_ctl_data_map_section + use t_ctl_data_4_view_transfer + use t_ctl_data_pvr_colormap_bar +! + implicit none +! +! + type map_ctl +!> Control block name + character(len = kchara) :: block_name = 'cross_section_ctl' +! +!> Structure of cross section definition + type(map_section_ctl) :: map_define_ctl +! +!> Structure for file prefix + type(read_character_item) :: map_image_prefix_ctl +!> Structure for data field format + type(read_character_item) :: map_image_fmt_ctl +! +!> Structure of field name for rendering + type(read_character_item) :: map_field_ctl +!> Structure of component name for rendering + type(read_character_item) :: map_comp_ctl +! +!> Structure of isoline field name for rendering + type(read_character_item) :: isoline_field_ctl +!> Structure of isoline component name for rendering + type(read_character_item) :: isoline_comp_ctl +! +!> file name for modelview matrix + character(len=kchara) :: fname_mat_ctl = 'NO_FILE' +!> Structure for modelview marices + type(modeview_ctl) :: mat +! +!> file name for colormap and colorbar + character(len=kchara) :: fname_cmap_cbar_c = 'NO_FILE' +!> Structure for colormap and colorbar + type(pvr_colormap_bar_ctl) :: cmap_cbar_c +! +! Top level + integer (kind=kint) :: i_map_ctl = 0 +! 2nd level for cross_section_ctl + integer (kind=kint) :: i_output_field = 0 + end type map_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine dealloc_cont_dat_4_map(map_c) +! + type(map_ctl), intent(inout) :: map_c +! +! + call dealloc_map_section_ctl(map_c%map_define_ctl) + call dealloc_view_transfer_ctl(map_c%mat) + call deallocate_pvr_cmap_cbar(map_c%cmap_cbar_c) +! + map_c%map_image_prefix_ctl%iflag = 0 + map_c%map_image_fmt_ctl%iflag = 0 + map_c%map_field_ctl%iflag = 0 + map_c%map_comp_ctl%iflag = 0 + map_c%isoline_field_ctl%iflag = 0 + map_c%isoline_comp_ctl%iflag = 0 +! + map_c%fname_mat_ctl = 'NO_FILE' + map_c%fname_cmap_cbar_c = 'NO_FILE' +! + map_c%i_map_ctl = 0 + map_c%i_output_field = 0 +! + end subroutine dealloc_cont_dat_4_map +! +! --------------------------------------------------------------------- +! + subroutine dup_control_4_map(org_map_c, new_map_c) +! + type(map_ctl), intent(in) :: org_map_c + type(map_ctl), intent(inout) :: new_map_c +! +! + call dup_map_section_ctl(org_map_c%map_define_ctl, & + & new_map_c%map_define_ctl) + call dup_view_transfer_ctl(org_map_c%mat, new_map_c%mat) + call dup_pvr_cmap_cbar(org_map_c%cmap_cbar_c, & + & new_map_c%cmap_cbar_c) +! + call copy_chara_ctl(org_map_c%map_image_prefix_ctl, & + & new_map_c%map_image_prefix_ctl) + call copy_chara_ctl(org_map_c%map_image_fmt_ctl, & + & new_map_c%map_image_fmt_ctl) + call copy_chara_ctl(org_map_c%map_field_ctl, & + & new_map_c%map_field_ctl) + call copy_chara_ctl(org_map_c%map_comp_ctl, & + & new_map_c%map_comp_ctl) + call copy_chara_ctl(org_map_c%isoline_field_ctl, & + & new_map_c%isoline_field_ctl) + call copy_chara_ctl(org_map_c%isoline_comp_ctl, & + & new_map_c%isoline_comp_ctl) +! + new_map_c%fname_mat_ctl = org_map_c%fname_mat_ctl + new_map_c%fname_cmap_cbar_c = org_map_c%fname_cmap_cbar_c +! + new_map_c%block_name = org_map_c%block_name + new_map_c%i_map_ctl = org_map_c%i_map_ctl + new_map_c%i_output_field = org_map_c%i_output_field +! + end subroutine dup_control_4_map +! +! --------------------------------------------------------------------- +! -------------------------------------------------------------------- +! + subroutine add_fields_4_map_to_fld_ctl(map_c, field_ctl) +! + use t_control_array_character3 + use add_nodal_fields_ctl +! + type(map_ctl), intent(in) :: map_c + type(ctl_array_c3), intent(inout) :: field_ctl +! +! + if(map_c%map_field_ctl%iflag .gt. 0) then + call add_viz_name_ctl(map_c%map_field_ctl%charavalue, & + & field_ctl) + end if + if(map_c%isoline_field_ctl%iflag .gt. 0) then + call add_viz_name_ctl(map_c%isoline_field_ctl%charavalue, & + & field_ctl) + end if +! + end subroutine add_fields_4_map_to_fld_ctl +! +! --------------------------------------------------------------------- +! + end module t_control_data_4_map diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/t_control_data_maps.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/t_control_data_maps.f90 new file mode 100644 index 00000000..3ffa8021 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/t_control_data_maps.f90 @@ -0,0 +1,211 @@ +!>@file t_control_data_maps.f90 +!!@brief module t_control_data_maps +!! +!!@date Programmed by H.Matsui in May, 2006 +! +!>@brief control data for cross sections +!! +!!@verbatim +!! subroutine alloc_map_ctl_stract(map_ctls) +!! subroutine dealloc_map_ctl_stract(map_ctls) +!! subroutine init_map_ctls_labels(hd_block, map_ctls) +!! character(len=kchara), intent(in) :: hd_block +!! type(map_rendering_controls), intent(inout) :: map_ctls +!! +!! subroutine append_map_render_control(idx_in, hd_block, map_ctls) +!! subroutine delete_map_render_control(idx_in, map_ctls) +!! type(map_rendering_controls), intent(inout) :: map_ctls +!! +!! subroutine add_fields_4_maps_to_fld_ctl(map_ctls, field_ctl) +!! type(map_rendering_controls), intent(in) :: map_ctls +!! type(ctl_array_c3), intent(inout) :: field_ctl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array map_rendering_ctl +!! file map_rendering_ctl 'ctl_map_cmb' +!! end array map_rendering_ctl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_control_data_maps +! + use m_precision +! + use m_machine_parameter + use t_control_data_4_map +! + implicit none +! +! + type map_rendering_controls +!> Control block name + character(len = kchara) :: block_name = 'map_rendering_ctl' +!> # of structure of sections control + integer(kind = kint) :: num_map_ctl = 0 +!> External section control file names + character(len = kchara), allocatable :: fname_map_ctl(:) +!> Structure of sections control + type(map_ctl), allocatable :: map_ctl_struct(:) + end type map_rendering_controls +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_map_ctl_stract(map_ctls) +! + use ctl_data_map_rendering_IO +! + type(map_rendering_controls), intent(inout) :: map_ctls + integer(kind = kint) :: i +! +! + allocate(map_ctls%map_ctl_struct(map_ctls%num_map_ctl)) + allocate(map_ctls%fname_map_ctl(map_ctls%num_map_ctl)) +! + end subroutine alloc_map_ctl_stract +! +! --------------------------------------------------------------------- +! + subroutine dealloc_map_ctl_stract(map_ctls) +! + type(map_rendering_controls), intent(inout) :: map_ctls +! + integer(kind = kint) :: i +! + if(allocated(map_ctls%map_ctl_struct) .eqv. .FALSE.) return +! + do i = 1, map_ctls%num_map_ctl + call dealloc_cont_dat_4_map(map_ctls%map_ctl_struct(i)) + end do +! + deallocate(map_ctls%map_ctl_struct, map_ctls%fname_map_ctl) + map_ctls%num_map_ctl = 0 +! + end subroutine dealloc_map_ctl_stract +! +! --------------------------------------------------------------------- +! + subroutine init_map_ctls_labels(hd_block, map_ctls) +! + character(len=kchara), intent(in) :: hd_block + type(map_rendering_controls), intent(inout) :: map_ctls +! + map_ctls%num_map_ctl = 0 + map_ctls%block_name = hd_block +! + end subroutine init_map_ctls_labels +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine add_fields_4_maps_to_fld_ctl(map_ctls, field_ctl) +! + use t_control_array_character3 +! + type(map_rendering_controls), intent(in) :: map_ctls + type(ctl_array_c3), intent(inout) :: field_ctl +! + integer(kind = kint) :: i_psf +! +! + do i_psf = 1, map_ctls%num_map_ctl + call add_fields_4_map_to_fld_ctl & + & (map_ctls%map_ctl_struct(i_psf), field_ctl) + end do +! + end subroutine add_fields_4_maps_to_fld_ctl +! +! --------------------------------------------------------------------- +! -------------------------------------------------------------------- +! + subroutine append_map_render_control(idx_in, hd_block, map_ctls) +! + use ctl_data_map_rendering_IO +! + integer(kind = kint), intent(in) :: idx_in + character(len=kchara), intent(in) :: hd_block + type(map_rendering_controls), intent(inout) :: map_ctls +! + type(map_rendering_controls) :: tmp_map_c + integer(kind = kint) :: i +! +! + if(idx_in.lt.0 .or. idx_in.gt.map_ctls%num_map_ctl) return +! + tmp_map_c%num_map_ctl = map_ctls%num_map_ctl + call alloc_map_ctl_stract(tmp_map_c) + do i = 1, tmp_map_c%num_map_ctl + call dup_control_4_map(map_ctls%map_ctl_struct(i), & + & tmp_map_c%map_ctl_struct(i)) + tmp_map_c%fname_map_ctl(i) = map_ctls%fname_map_ctl(i) + end do +! + call dealloc_map_ctl_stract(map_ctls) + map_ctls%num_map_ctl = tmp_map_c%num_map_ctl + 1 + call alloc_map_ctl_stract(map_ctls) +! + do i = 1, idx_in + call dup_control_4_map(tmp_map_c%map_ctl_struct(i), & + & map_ctls%map_ctl_struct(i)) + map_ctls%fname_map_ctl(i) = tmp_map_c%fname_map_ctl(i) + end do + call init_map_control_label(hd_block, & + & map_ctls%map_ctl_struct(idx_in+1)) + map_ctls%fname_map_ctl(idx_in+1) = 'NO_FILE' + do i = idx_in+1, tmp_map_c%num_map_ctl + call dup_control_4_map(tmp_map_c%map_ctl_struct(i), & + & map_ctls%map_ctl_struct(i+1)) + map_ctls%fname_map_ctl(i+1) = tmp_map_c%fname_map_ctl(i) + end do +! + call dealloc_map_ctl_stract(tmp_map_c) +! + end subroutine append_map_render_control +! +! ----------------------------------------------------------------------- +! + subroutine delete_map_render_control(idx_in, map_ctls) +! + use ctl_data_map_rendering_IO +! + integer(kind = kint), intent(in) :: idx_in + type(map_rendering_controls), intent(inout) :: map_ctls +! + type(map_rendering_controls) :: tmp_map_c + integer(kind = kint) :: i +! +! + if(idx_in.le.0 .or. idx_in.gt.map_ctls%num_map_ctl) return +! + tmp_map_c%num_map_ctl = map_ctls%num_map_ctl + call alloc_map_ctl_stract(tmp_map_c) + do i = 1, tmp_map_c%num_map_ctl + call dup_control_4_map(map_ctls%map_ctl_struct(i), & + & tmp_map_c%map_ctl_struct(i)) + tmp_map_c%fname_map_ctl(i) = map_ctls%fname_map_ctl(i) + end do +! + call dealloc_map_ctl_stract(map_ctls) + map_ctls%num_map_ctl = tmp_map_c%num_map_ctl + 1 + call alloc_map_ctl_stract(map_ctls) +! + do i = 1, idx_in-1 + call dup_control_4_map(tmp_map_c%map_ctl_struct(i), & + & map_ctls%map_ctl_struct(i)) + map_ctls%fname_map_ctl(i) = tmp_map_c%fname_map_ctl(i) + end do + do i = idx_in, map_ctls%num_map_ctl + call dup_control_4_map(tmp_map_c%map_ctl_struct(i+1), & + & map_ctls%map_ctl_struct(i)) + map_ctls%fname_map_ctl(i) = tmp_map_c%fname_map_ctl(i+1) + end do +! + call dealloc_map_ctl_stract(tmp_map_c) +! + end subroutine delete_map_render_control +! +! ----------------------------------------------------------------------- +! + end module t_control_data_maps diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/t_ctl_data_map_section.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/t_ctl_data_map_section.f90 new file mode 100644 index 00000000..4e3ac830 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/t_ctl_data_map_section.f90 @@ -0,0 +1,151 @@ +!>@file t_ctl_data_map_section.f90 +!!@brief module t_ctl_data_map_section +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for parallel volume rendering +!! +!!@verbatim +!! subroutine dup_map_section_ctl(org_map_sect_c, new_map_sect_c) +!! type(map_section_ctl), intent(in) :: org_map_sect_c +!! type(map_section_ctl), intent(inout) :: new_map_sect_c +!! subroutine dealloc_map_section_ctl(map_sect_ctl) +!! type(map_section_ctl), intent(inout) :: map_sect_ctl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array section_ctl +!! file surface_define ctl_psf_eq +!! begin surface_define +!! ... +!! end surface_define +!! +!! zeroline_switch_ctl On +!! isoline_color_mode color, white, or black +!! isoline_number_ctl 20 +!! isoline_range_ctl -0.5 0.5 +!! isoline_width_ctl 1.5 +!! grid_width_ctl 1.0 +!! +!! tangent_cylinder_switch_ctl On +!! inner_radius_ctl 0.53846 +!! outer_radius_ctl 1.53846 +!! end array section_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_map_section +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_data_4_psf_def + use t_control_array_real + use t_control_array_real2 + use t_control_array_integer + use t_control_array_character + use t_control_array_chara2real + use skip_comment_f +! + implicit none +! + type map_section_ctl +!> Block name + character(len=kchara) :: block_name = 'surface_define' +! +!> File name of control file to define surface + character(len = kchara) :: fname_sect_ctl = 'NO_FILE' +!> Structure to define surface + type(psf_define_ctl) :: psf_def_c +! +!> Structure of zero line switch + type(read_character_item) :: zeroline_switch_ctl +!> Structure of isoline color mode + type(read_character_item) :: isoline_color_mode +!> Structure of number of isoline + type(read_integer_item) :: isoline_number_ctl +!> Structure of range of isoline + type(read_real2_item) :: isoline_range_ctl +!> Structure to isoline width + type(read_real_item) :: isoline_width_ctl +!> Structure to grid width + type(read_real_item) :: grid_width_ctl +! +!> Structure of tangent cylinder line switch + type(read_character_item) :: tan_cyl_switch_ctl +!> Structure to define outer bounday radius for tangent cylinder + type(read_real_item) :: tangent_cylinder_inner_ctl +!> Structure to define inner bounday radius for tangent cylinder + type(read_real_item) :: tangent_cylinder_outer_ctl +! + integer(kind = kint) :: i_map_sect_ctl = 0 + end type map_section_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine dup_map_section_ctl(org_map_sect_c, new_map_sect_c) +! + type(map_section_ctl), intent(in) :: org_map_sect_c + type(map_section_ctl), intent(inout) :: new_map_sect_c +! +! + new_map_sect_c%block_name = org_map_sect_c%block_name + new_map_sect_c%i_map_sect_ctl = org_map_sect_c%i_map_sect_ctl + new_map_sect_c%fname_sect_ctl = org_map_sect_c%fname_sect_ctl + call dup_control_4_psf_def & + & (org_map_sect_c%psf_def_c, new_map_sect_c%psf_def_c) +! + call copy_chara_ctl(org_map_sect_c%zeroline_switch_ctl, & + & new_map_sect_c%zeroline_switch_ctl) + call copy_chara_ctl(org_map_sect_c%isoline_color_mode, & + & new_map_sect_c%isoline_color_mode) + call copy_integer_ctl(org_map_sect_c%isoline_number_ctl, & + & new_map_sect_c%isoline_number_ctl) + call copy_real2_ctl(org_map_sect_c%isoline_range_ctl, & + & new_map_sect_c%isoline_range_ctl) + call copy_real_ctl(org_map_sect_c%isoline_width_ctl, & + & new_map_sect_c%isoline_width_ctl) + call copy_real_ctl(org_map_sect_c%grid_width_ctl, & + & new_map_sect_c%grid_width_ctl) +! + call copy_chara_ctl(org_map_sect_c%tan_cyl_switch_ctl, & + & new_map_sect_c%tan_cyl_switch_ctl) + call copy_real_ctl(org_map_sect_c%tangent_cylinder_inner_ctl, & + & new_map_sect_c%tangent_cylinder_inner_ctl) + call copy_real_ctl(org_map_sect_c%tangent_cylinder_outer_ctl, & + & new_map_sect_c%tangent_cylinder_outer_ctl) +! + end subroutine dup_map_section_ctl +! +! --------------------------------------------------------------------- +! + subroutine dealloc_map_section_ctl(map_sect_ctl) +! + type(map_section_ctl), intent(inout) :: map_sect_ctl +! +! + call dealloc_cont_dat_4_psf_def(map_sect_ctl%psf_def_c) +! + map_sect_ctl%zeroline_switch_ctl%iflag = 0 + map_sect_ctl%isoline_color_mode%iflag = 0 + map_sect_ctl%isoline_number_ctl%iflag = 0 + map_sect_ctl%isoline_range_ctl%iflag = 0 + map_sect_ctl%isoline_width_ctl%iflag = 0 + map_sect_ctl%grid_width_ctl%iflag = 0 +! + map_sect_ctl%tan_cyl_switch_ctl%iflag = 0 + map_sect_ctl%tangent_cylinder_inner_ctl%iflag = 0 + map_sect_ctl%tangent_cylinder_outer_ctl%iflag = 0 +! + map_sect_ctl%i_map_sect_ctl = 0 +! + end subroutine dealloc_map_section_ctl +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_map_section diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/t_map_patch_from_1patch.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/t_map_patch_from_1patch.f90 new file mode 100644 index 00000000..5a16ccbf --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/t_map_patch_from_1patch.f90 @@ -0,0 +1,165 @@ +!>@file t_map_patch_from_1patch.f90 +!!@brief module t_map_patch_from_1patch +!! +!!@author H. Matsui +!!@date Programmed in May, 2023 +! +!>@brief Divided triangle patch for map projection +!! +!!@verbatim +!! subroutine alloc_map_patch_from_1patch(map_e) +!! subroutine dealloc_map_patch_from_1patch(map_e) +!! type(map_patches_for_1patch), intent(inout) :: map_e +!! +!! subroutine set_sph_position_4_map_patch(x_map_patch, & +!! & rtp_map_patch) +!! real(kind = kreal), intent(inout) & +!! & :: x_map_patch(num_triangle,n_vector) +!! real(kind = kreal), intent(inout) & +!! & :: rtp_map_patch(num_triangle,n_vector) +!! subroutine patch_to_aitoff(rtp_map_patch, xy_map) +!! real(kind = kreal), intent(in) & +!! & :: rtp_map_patch(num_triangle,n_vector) +!! real(kind = kreal), intent(inout) :: xy_map(2,num_triangle) +!!@endverbatim + module t_map_patch_from_1patch +! + use m_precision +! + use m_constants + use m_phys_constants + use m_geometry_constants +! + implicit none +! + real(kind = kreal), parameter, private :: EPSILON = 1.0d-9 +! + integer(kind = kint), parameter :: nmax_map_p = 3 +! + type map_patches_for_1patch + integer(kind = kint) :: n_map_patch +! + real(kind=kreal), allocatable :: xy_map(:,:,:) + real(kind=kreal), allocatable :: d_map_patch(:,:) +! + real(kind=kreal), allocatable :: x_map_patch(:,:,:) + real(kind=kreal), allocatable :: rtp_map_patch(:,:,:) + end type map_patches_for_1patch +! +! private :: nmax_map_p, x_map_patch, rtp_map_patch +! +!----------------------------------------------------------------------- +! + contains +! +!----------------------------------------------------------------------- +! + subroutine alloc_map_patch_from_1patch(map_e) +! + type(map_patches_for_1patch), intent(inout) :: map_e +! + allocate(map_e%xy_map(2,num_triangle,nmax_map_p)) + allocate(map_e%d_map_patch(num_triangle,nmax_map_p)) + allocate(map_e%x_map_patch(num_triangle,n_vector,nmax_map_p)) + allocate(map_e%rtp_map_patch(num_triangle,n_vector,nmax_map_p)) +! + map_e%xy_map(1:2,1:num_triangle,1:nmax_map_p) = zero + map_e%d_map_patch(1:num_triangle,1:nmax_map_p) = zero + map_e%x_map_patch(1:num_triangle,1:n_vector,1:nmax_map_p) = zero + map_e%rtp_map_patch(1:num_triangle,1:n_vector,1:nmax_map_p)= zero +! + end subroutine alloc_map_patch_from_1patch +! +!----------------------------------------------------------------------- +! + subroutine dealloc_map_patch_from_1patch(map_e) +! + type(map_patches_for_1patch), intent(inout) :: map_e +! + deallocate(map_e%xy_map) + deallocate(map_e%d_map_patch, map_e%x_map_patch) + deallocate(map_e%rtp_map_patch) +! + end subroutine dealloc_map_patch_from_1patch +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine set_sph_position_4_map_patch(x_map_patch, & + & rtp_map_patch) +! + use coordinate_converter +! + real(kind = kreal), intent(inout) & + & :: x_map_patch(num_triangle,n_vector) + real(kind = kreal), intent(inout) & + & :: rtp_map_patch(num_triangle,n_vector) +! + integer(kind = kint) :: k1 + real(kind = kreal) :: x_center + real(kind = kreal) :: y_center + real(kind = kreal) :: ar_map(3), rs_map(3), as_map(3) + real(kind = kreal) :: pi, yflag +! +! + x_center = (x_map_patch(1,1) + x_map_patch(2,1) & + & + x_map_patch(3,1) ) / three + y_center = (x_map_patch(1,2) + x_map_patch(2,2) & + & + x_map_patch(3,2) ) / three +! + pi = four * atan(one) + call position_2_sph(ithree, x_map_patch, rtp_map_patch(1,1), & + & rtp_map_patch(1,2), rtp_map_patch(1,3), & + & ar_map(1), rs_map(1), as_map(1)) + rtp_map_patch(1:3,3) = mod((rtp_map_patch(1:3,3)+pi),(two*pi)) +! + yflag = x_map_patch(1,2) * x_map_patch(2,2) * x_map_patch(3,2) + if(yflag.eq.zero .and. x_center.le.zero) then + if(y_center .le. zero) then + if(abs(x_map_patch(1,2)) .lt. EPSILON & + & .and. x_map_patch(1,1).lt.zero) rtp_map_patch(1,3) = zero + if(abs(x_map_patch(2,2)) .lt. EPSILON & + & .and. x_map_patch(2,1).lt.zero) rtp_map_patch(2,3) = zero + if(abs(x_map_patch(3,2)) .lt. EPSILON & + & .and. x_map_patch(3,1).lt.zero) rtp_map_patch(3,3) = zero + else + if(abs(x_map_patch(1,2)) .lt. EPSILON & + & .and. x_map_patch(1,1).lt.zero) rtp_map_patch(1,3) = two*pi + if(abs(x_map_patch(2,2)) .lt. EPSILON & + & .and. x_map_patch(2,1).lt.zero) rtp_map_patch(2,3) = two*pi + if(abs(x_map_patch(3,2)) .lt. EPSILON & + & .and. x_map_patch(3,1).lt.zero) rtp_map_patch(3,3) = two*pi + end if +! + end if +! + end subroutine set_sph_position_4_map_patch +! +!----------------------------------------------------------------------- +! + subroutine patch_to_aitoff(rtp_map_patch, xy_map) +! + use aitoff +! + real(kind = kreal), intent(in) & + & :: rtp_map_patch(num_triangle,n_vector) + real(kind = kreal), intent(inout) :: xy_map(2,num_triangle) +! + integer(kind = kint) :: k1 + real(kind = kreal) :: s_theta, c_theta, pi, phi_map +! +! + pi = four * atan(one) + do k1 = 1, num_triangle + s_theta = sin(rtp_map_patch(k1,2)) + c_theta = cos(rtp_map_patch(k1,2)) +! phi_map = mod((rtp_map_patch(k1,3)+pi),(two*pi)) + call s_aitoff(s_theta, c_theta, rtp_map_patch(k1,3), & + & xy_map(1,k1), xy_map(2,k1)) + end do +! + end subroutine patch_to_aitoff +! +!----------------------------------------------------------------------- +! + end module t_map_patch_from_1patch diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/t_map_projection.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/t_map_projection.f90 new file mode 100644 index 00000000..5d21c116 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/t_map_projection.f90 @@ -0,0 +1,141 @@ +!>@file t_map_projection.f90 +!!@brief module t_map_projection +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +!!@n modified in July, 2014 +! +!>@brief Structure for cross sectioning +!! +!!@verbatim +!! subroutine alloc_map_rendering_module(map) +!! subroutine alloc_map_rendering_module(map) +!! type(map_rendering_module), intent(inout) :: map +!!@endverbatim + module t_map_projection +! + use calypso_mpi + use m_precision +! + use t_cross_section + use t_psf_results + use t_control_data_maps + use t_control_params_4_pvr + use t_pvr_colormap_parameter + use t_pvr_image_array + use t_map_rendering_data +! + implicit none +! + type map_rendering_module +!> Number of sections + integer(kind = kint) :: num_map = 0 +! +!> Structure of case table for isosurface + type(psf_cases) :: psf_case_tbls +! +!> Structure for table for sections + type(sectioning_list), allocatable :: map_list(:) +!> Structure for table for sections + type(grp_section_list), allocatable :: map_grp_list(:) +! +!> Structure for search table for sections + type(psf_search_lists), allocatable :: psf_search(:) +! +!> Structure of sectioning module parameter + type(psf_parameters), allocatable :: map_param(:) +!> Structure of cross sectioning parameter + type(section_define), allocatable :: map_def(:) +!> Structure of projection parameter + type(pvr_view_parameter), allocatable:: view_param(:) +!> Structure of color map parameter + type(pvr_colormap_parameter), allocatable :: color_param(:) +!> Structure of color bar parameter + type(pvr_colorbar_parameter), allocatable :: cbar_param(:) +! +!> Structure for psf patch data on local domain + type(psf_local_data), allocatable :: map_mesh(:) +! +!> Structure of color bar parameter + type(psf_results), allocatable :: map_psf_dat(:) +!> Structure of color bar parameter + type(map_rendering_data), allocatable :: map_data(:) +!> Structure of color bar parameter + type(pvr_image_type), allocatable :: map_rgb(:) + end type map_rendering_module +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_map_rendering_module(map) +! + use m_field_file_format +! + type(map_rendering_module), intent(inout) :: map + integer(kind = kint) :: i_psf +! +! + allocate(map%map_mesh(map%num_map)) + allocate(map%map_list(map%num_map)) + allocate(map%map_grp_list(map%num_map)) + allocate(map%psf_search(map%num_map)) + allocate(map%map_param(map%num_map)) + allocate(map%map_def(map%num_map)) +! + allocate(map%view_param(map%num_map)) + allocate(map%color_param(map%num_map)) + allocate(map%cbar_param(map%num_map)) + allocate(map%map_data(map%num_map)) + allocate(map%map_rgb(map%num_map)) + allocate(map%map_psf_dat(map%num_map)) +! + do i_psf = 1, map%num_map + call alloc_coefficients_4_psf(map%map_def(i_psf)) + end do +! + end subroutine alloc_map_rendering_module +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dealloc_map_rendering_module(map) +! + use set_map_control + use set_psf_control + use set_fields_for_psf + use find_node_and_patch_psf +! + type(map_rendering_module), intent(inout) :: map + integer(kind = kint) :: i_psf +! +! + if(map%num_map .le. 0) return +! + do i_psf = 1, map%num_map + call dealloc_node_param_smp(map%map_mesh(i_psf)%node) + call dealloc_ele_param_smp(map%map_mesh(i_psf)%patch) +! + call dealloc_inod_grp_psf(map%map_grp_list(i_psf)) + call dealloc_coefficients_4_psf(map%map_def(i_psf)) + call dealloc_pvr_image_array(map%map_rgb(i_psf)) + end do +! + call dealloc_psf_node_and_patch & + & (map%num_map, map%map_list, map%map_mesh) + call dealloc_psf_field_name(map%num_map, map%map_mesh) + call dealloc_psf_field_data(map%num_map, map%map_mesh) + call dealloc_psf_case_table(map%psf_case_tbls) +! + deallocate(map%map_mesh, map%map_list, map%map_grp_list) + deallocate(map%psf_search) + deallocate(map%map_param) + deallocate(map%map_rgb, map%map_data) +! + end subroutine dealloc_map_rendering_module +! +! --------------------------------------------------------------------- +! + end module t_map_projection diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/t_map_rendering_data.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/t_map_rendering_data.f90 new file mode 100644 index 00000000..b9635015 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/t_map_rendering_data.f90 @@ -0,0 +1,262 @@ +!>@file t_map_rendering_data.f90 +!!@brief module t_map_rendering_data +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +!!@n modified in July, 2014 +! +!>@brief Structure for cross sectioning +!! +!!@verbatim +!! subroutine set_ctl_map_rendering_param & +!! & (proj_type_c, proj_c, map_define_ctl, map_data) +!! type(read_character_item), intent(in) :: proj_type_c +!! type(projection_ctl), intent(in) :: proj_c +!! type(map_section_ctl), intent(in) :: map_define_ctl +!! type(map_rendering_data), intent(inout) :: map_data +!! subroutine init_map_rendering_data & +!! & (view_param, pvr_rgb, map_data) +!! type(pvr_view_parameter), intent(in):: view_param +!! type(pvr_image_type), intent(in) :: pvr_rgb +!! type(map_rendering_data), intent(inout) :: map_data +!!@endverbatim + module t_map_rendering_data +! + use calypso_mpi + use m_precision + use m_machine_parameter +! + use t_geometry_data + use t_phys_data + use t_control_params_4_pvr + use t_pvr_colormap_parameter +! + implicit none +! + real(kind= kreal), parameter, private :: xframe = 2.4 + real(kind= kreal), parameter, private :: yframe = 1.8 +! + character(len = kchara), parameter :: label_xy_plane = 'xy_plane' + character(len = kchara), parameter :: label_xz_plane = 'xz_plane' + character(len = kchara), parameter :: label_yz_plane = 'yz_plane' + character(len = kchara), parameter :: label_aitoff = 'aitoff' + integer(kind = kint), parameter :: iflag_xy_plane = 1 + integer(kind = kint), parameter :: iflag_xz_plane = 2 + integer(kind = kint), parameter :: iflag_yz_plane = 3 + integer(kind = kint), parameter :: iflag_aitoff = 101 +! + character(len = kchara), parameter :: label_colored = 'color' + character(len = kchara), parameter :: label_black = 'black' + character(len = kchara), parameter :: label_white = 'white' + integer(kind = kint), parameter :: iflag_colored = 1 + integer(kind = kint), parameter :: iflag_black = 2 + integer(kind = kint), parameter :: iflag_white = 3 +! + type map_rendering_data + logical :: fill_flag = .TRUE. + logical :: flag_zeroline = .FALSE. + integer(kind = kint) :: num_line = 0 +! + logical :: flag_fixed_isoline_range = .FALSE. + real(kind= kreal) :: dmin_isoline + real(kind= kreal) :: dmax_isoline +! + real(kind = kreal) :: width_isoline = 1.5d0 + real(kind = kreal) :: width_grid = 1.0d0 +! + integer(kind = kint) :: iflag_2d_projection_mode = 0 + integer(kind = kint) :: iflag_isoline_color = 0 +! + real(kind= kreal) :: xmin_frame = -xframe + real(kind= kreal) :: xmax_frame = xframe + real(kind= kreal) :: ymin_frame = -yframe + real(kind= kreal) :: ymax_frame = yframe +! + logical :: flag_tangent_cylinder = .FALSE. + real(kind = kreal) :: tangent_cylinder_radius(2) + real(kind = kreal) :: tangent_cylinder_theta(2) & + & = (/(20.0d0/13.0d0), (7.0d0/13.0d0)/) +!> Color of tangent cylinder + real(kind = kreal) :: tangent_cylinder_rgba(4) & + & = (/zero,zero,zero,one/) + end type map_rendering_data +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_ctl_map_rendering_param & + & (proj_type_c, proj_c, map_define_ctl, map_data) +! + use t_control_array_character + use t_ctl_data_map_section + use t_ctl_data_4_projection + use skip_comment_f +! + type(read_character_item), intent(in) :: proj_type_c + type(projection_ctl), intent(in) :: proj_c + type(map_section_ctl), intent(in) :: map_define_ctl + type(map_rendering_data), intent(inout) :: map_data +! + character(len = kchara) :: tmpchara + real(kind = kreal) :: pi +! +! + map_data%iflag_2d_projection_mode = iflag_aitoff + if(proj_type_c%iflag .gt. 0) then + tmpchara = proj_type_c%charavalue + if(cmp_no_case(tmpchara, label_xy_plane)) then + map_data%iflag_2d_projection_mode = iflag_xy_plane + else if(cmp_no_case(tmpchara, label_xz_plane)) then + map_data%iflag_2d_projection_mode = iflag_xz_plane + else if(cmp_no_case(tmpchara, label_yz_plane)) then + map_data%iflag_2d_projection_mode = iflag_yz_plane + else if(cmp_no_case(tmpchara, label_aitoff)) then + map_data%iflag_2d_projection_mode = iflag_aitoff + end if + end if +! + map_data%xmin_frame = -xframe + map_data%xmax_frame = xframe + if(proj_c%horizontal_range_ctl%iflag .gt. 0) then + map_data%xmin_frame = proj_c%horizontal_range_ctl%realvalue(1) + map_data%xmax_frame = proj_c%horizontal_range_ctl%realvalue(2) + end if +! + map_data%ymin_frame = -yframe + map_data%ymax_frame = yframe + if(proj_c%vertical_range_ctl%iflag .gt. 0) then + map_data%ymin_frame = proj_c%vertical_range_ctl%realvalue(1) + map_data%ymax_frame = proj_c%vertical_range_ctl%realvalue(2) + end if +! +! + map_data%flag_zeroline = .FALSE. + if(map_define_ctl%zeroline_switch_ctl%iflag .gt. 0) then + map_data%flag_zeroline & + & = yes_flag(map_define_ctl%zeroline_switch_ctl%charavalue) + end if +! + map_data%num_line = 0 + if(map_define_ctl%isoline_number_ctl%iflag .gt. 0) then + map_data%num_line = map_define_ctl%isoline_number_ctl%intvalue + end if +! + map_data%dmin_isoline = zero + map_data%dmax_isoline = zero + if(map_define_ctl%isoline_range_ctl%iflag .gt. 0) then + map_data%flag_fixed_isoline_range = .TRUE. + map_data%dmin_isoline & + & = map_define_ctl%isoline_range_ctl%realvalue(1) + map_data%dmax_isoline & + & = map_define_ctl%isoline_range_ctl%realvalue(2) + end if +! + map_data%width_isoline = 1.5d0 + if(map_define_ctl%isoline_width_ctl%iflag .gt. 0) then + map_data%width_isoline & + & = map_define_ctl%isoline_width_ctl%realvalue + end if +! + map_data%width_grid = 1.0d0 + if(map_define_ctl%grid_width_ctl%iflag .gt. 0) then + map_data%width_grid & + & = map_define_ctl%grid_width_ctl%realvalue + end if +! + map_data%iflag_isoline_color = iflag_black + if(map_data%num_line .gt. 0) then + if(map_define_ctl%isoline_color_mode%iflag .gt. 0) then + tmpchara = map_define_ctl%isoline_color_mode%charavalue + if(cmp_no_case(tmpchara, label_colored)) then + map_data%iflag_isoline_color = iflag_colored + else if(cmp_no_case(tmpchara, label_white)) then + map_data%iflag_isoline_color = iflag_white + else if(cmp_no_case(tmpchara, label_black)) then + map_data%iflag_isoline_color = iflag_black + end if + end if + end if +! +! + if(map_define_ctl%zeroline_switch_ctl%iflag .gt. 0) then + map_data%flag_zeroline & + & = yes_flag(map_define_ctl%zeroline_switch_ctl%charavalue) + end if +! + if(map_define_ctl%tan_cyl_switch_ctl%iflag.gt.0) then + map_data%flag_tangent_cylinder & + & = yes_flag(map_define_ctl%tan_cyl_switch_ctl%charavalue) + end if +! + if( (map_define_ctl%tangent_cylinder_inner_ctl%iflag & + & * map_define_ctl%tangent_cylinder_outer_ctl%iflag) .gt. 0) then + map_data%tangent_cylinder_radius(1) & + & = map_define_ctl%tangent_cylinder_outer_ctl%realvalue + map_data%tangent_cylinder_radius(2) & + & = map_define_ctl%tangent_cylinder_inner_ctl%realvalue + end if +! + pi = four*atan(one) + map_data%tangent_cylinder_theta(1) & + & = asin(map_data%tangent_cylinder_radius(2) & + & / map_data%tangent_cylinder_radius(1)) + map_data%tangent_cylinder_theta(2) & + & = pi - map_data%tangent_cylinder_theta(1) +! + end subroutine set_ctl_map_rendering_param +! +! --------------------------------------------------------------------- +! + subroutine init_map_rendering_data & + & (view_param, pvr_rgb, map_data) +! + use t_psf_patch_data + use t_pvr_image_array +! + type(pvr_view_parameter), intent(in):: view_param + type(pvr_image_type), intent(in) :: pvr_rgb +! + type(map_rendering_data), intent(inout) :: map_data +! + real(kind = kreal) :: x_tmp, y_tmp, width(2) + real(kind = kreal) :: aspect +! +! + if(my_rank .ne. pvr_rgb%irank_image_file) return +! +! + aspect = view_param%perspective_xy_ratio +! + width(1) = map_data%xmax_frame - map_data%xmin_frame + width(2) = map_data%ymax_frame - map_data%ymin_frame +! + y_tmp = width(1) * dble(view_param%n_pvr_pixel(2)) & + & / dble(view_param%n_pvr_pixel(1)) + x_tmp = width(2) * dble(view_param%n_pvr_pixel(1)) & + & / dble(view_param%n_pvr_pixel(2)) +! + if(x_tmp .gt. width(1)) then + map_data%xmin_frame = map_data%xmin_frame * x_tmp / width(1) + map_data%xmax_frame = map_data%xmax_frame * x_tmp / width(1) + end if + if(y_tmp .gt. width(2)) then + map_data%ymin_frame = map_data%ymin_frame * y_tmp / width(2) + map_data%ymax_frame = map_data%ymax_frame * y_tmp / width(2) + end if +! + if (iflag_debug .gt. 0) then + write(*,*) 'Orthogonal parameter for rendering ' + write(*,*) 'horizontal range:', & + & map_data%xmin_frame, map_data%xmax_frame + write(*,*) 'vertical range:', & + & map_data%ymin_frame, map_data%ymax_frame + end if +! + end subroutine init_map_rendering_data +! +! --------------------------------------------------------------------- +! + end module t_map_rendering_data diff --git a/src/Fortran_libraries/VIZ_src/map_rendering/xyz_plane_rendering.f90 b/src/Fortran_libraries/VIZ_src/map_rendering/xyz_plane_rendering.f90 new file mode 100644 index 00000000..b68c4fd2 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/map_rendering/xyz_plane_rendering.f90 @@ -0,0 +1,258 @@ +!>@file xyz_plane_rendering.f90 +!!@brief module xyz_plane_rendering +!! +!!@author H. Matsui +!!@date Programmed in July, 2023 +! +!>@brief Subroutines to draw lines on map +!! +!!@verbatim +!! subroutine aitoff_projection_rendering(time_d, psf_nod, psf_ele,& +!! & psf_phys, color_param, cbar_param, map_data, pvr_rgb) +!! subroutine s_xyz_plane_rendering(time_d, psf_nod, psf_ele, & +!! & psf_phys, color_param, cbar_param, map_data, pvr_rgb) +!! type(time_data), intent(in) :: time_d +!! type(pvr_colormap_parameter), intent(in) :: color_param +!! type(pvr_colorbar_parameter), intent(in) :: cbar_param +!! type(phys_data), intent(in) :: psf_phys +!! type(node_data), intent(in) :: psf_nod +!! type(element_data), intent(in) :: psf_ele +!! type(map_rendering_data), intent(inout) :: map_data +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!!@endverbatim + module xyz_plane_rendering +! + use m_precision + use m_constants +! + use t_psf_patch_data + use t_time_data + use t_file_IO_parameter + use t_map_patch_from_1patch + use t_pvr_image_array + use t_map_rendering_data +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine aitoff_projection_rendering(time_d, psf_nod, psf_ele, & + & psf_phys, color_param, cbar_param, map_data, pvr_rgb) +! + use set_ucd_data_to_type + use ucd_IO_select +! + use draw_aitoff_map + use draw_lines_on_map + use draw_pvr_colorbar + use draw_pixels_on_map + use draw_lines_on_map +! + type(time_data), intent(in) :: time_d + type(pvr_colormap_parameter), intent(in) :: color_param + type(pvr_colorbar_parameter), intent(in) :: cbar_param + type(phys_data), intent(in) :: psf_phys + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele +! + type(map_rendering_data), intent(inout) :: map_data + type(pvr_image_type), intent(inout) :: pvr_rgb +! + type(map_patches_for_1patch) :: map_e1 + real(kind = kreal), parameter & + & :: black(4) = (/zero,zero,zero,one/) + real(kind = kreal), parameter & + & :: white(4) = (/one,one,one,one/) + real(kind = kreal) :: color_ref(4) +! + real(kind = kreal), allocatable :: phi_shift(:) + real(kind = kreal) :: pi + integer(kind = kint) :: i +! +! + if(my_rank .ne. pvr_rgb%irank_image_file) return +!$omp parallel workshare + pvr_rgb%rgba_real_gl(1:4,1:pvr_rgb%num_pixel_actual) = 0.0d0 +!$omp end parallel workshare +! + pi = four*atan(one) + call alloc_map_patch_from_1patch(map_e1) + if(map_data%fill_flag) then + call set_scalar_on_map_image(color_param, psf_nod, psf_ele, & + & psf_phys%d_fld(1,1), map_data, pvr_rgb, map_e1) + if(map_data%flag_zeroline .and. (map_data%num_line.le.0)) then + call draw_aitoff_map_zeroline & + & (psf_nod, psf_ele, psf_phys%d_fld(1,1), map_data, & + & black, pvr_rgb, map_e1) + end if + else + call fill_map_one_color & + & (pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & color_param%bg_rgba_real, pvr_rgb%rgba_real_gl) + end if +! + if(map_data%num_line .gt. 0) then + call draw_aitoff_map_isolines & + & (psf_nod, psf_ele, psf_phys%d_fld(1,2), map_data, & + & color_param, pvr_rgb, map_e1) +! + if(map_data%flag_zeroline & + & .and. (map_data%fill_flag.eqv. .FALSE.)) then + call set_flame_color & + & (map_data%fill_flag, color_param%bg_rgba_real, color_ref) + call draw_aitoff_map_zeroline & + & (psf_nod, psf_ele, psf_phys%d_fld(1,2), map_data, & + & white, pvr_rgb, map_e1) + end if + end if +! + call draw_latitude_grid(psf_nod, psf_ele, map_data, & + & color_param%bg_rgba_real, pvr_rgb, map_e1) + if(map_data%flag_tangent_cylinder) then + call draw_map_tangent_cyl_grid(psf_nod, psf_ele, map_data, & + & color_param%bg_rgba_real, map_data%tangent_cylinder_theta, & + & pvr_rgb, map_e1) + end if +! + allocate(phi_shift(psf_nod%numnod)) + do i = 1, psf_nod%numnod + if(psf_nod%xx(i,2) .ge. 0) then + phi_shift(i) = psf_nod%phi(i) + else + phi_shift(i) = two*pi - psf_nod%phi(i) + end if + end do +! + call draw_longitude_grid(psf_nod, psf_ele, phi_shift, map_data, & + & color_param%bg_rgba_real, pvr_rgb, map_e1) + call draw_mapflame(psf_nod, psf_ele, phi_shift, map_data, & + & color_param%bg_rgba_real, pvr_rgb, map_e1) + deallocate(phi_shift) + call dealloc_map_patch_from_1patch(map_e1) +! + call fill_background & + & (pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & color_param%bg_rgba_real, pvr_rgb%rgba_real_gl) +! + if(cbar_param%flag_pvr_colorbar) then + call set_pvr_colorbar(pvr_rgb%num_pixel_xy, pvr_rgb%num_pixels, & + & color_param, cbar_param, pvr_rgb%rgba_real_gl(1,1)) + end if +! + if(cbar_param%flag_draw_time) then + call set_pvr_timelabel & + & (time_d%time, pvr_rgb%num_pixel_xy, pvr_rgb%num_pixels, & + & cbar_param, pvr_rgb%rgba_real_gl(1,1)) + end if +! + end subroutine aitoff_projection_rendering +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine s_xyz_plane_rendering(time_d, psf_nod, psf_ele, & + & psf_phys, color_param, cbar_param, map_data, pvr_rgb) +! + use set_scalar_on_xyz_plane + use draw_xyz_plane_isolines + use draw_pvr_colorbar + use draw_pixels_on_map + use draw_lines_on_map + use cal_mesh_position +! + type(time_data), intent(in) :: time_d + type(pvr_colormap_parameter), intent(in) :: color_param + type(pvr_colorbar_parameter), intent(in) :: cbar_param + type(phys_data), intent(in) :: psf_phys + type(node_data), intent(in) :: psf_nod + type(element_data), intent(in) :: psf_ele +! + type(map_rendering_data), intent(inout) :: map_data + type(pvr_image_type), intent(inout) :: pvr_rgb +! + type(map_patches_for_1patch) :: map_e1 + real(kind = kreal), parameter & + & :: black(4) = (/zero,zero,zero,one/) + real(kind = kreal), parameter & + & :: white(4) = (/one,one,one,one/) + real(kind = kreal) :: color_ref(4) +! +! + if(my_rank .ne. pvr_rgb%irank_image_file) return +!$omp parallel workshare + pvr_rgb%rgba_real_gl(1:4,1:pvr_rgb%num_pixel_actual) = 0.0d0 +!$omp end parallel workshare +! + call alloc_map_patch_from_1patch(map_e1) + if(map_data%fill_flag) then + call sel_scalar_on_xyz_plane & + & (color_param, psf_nod, psf_ele, psf_phys%d_fld(1,1), & + & map_data, pvr_rgb, map_e1) +! + if(map_data%flag_zeroline .and. (map_data%num_line.le.0)) then + call draw_xyz_plane_zeroline & + & (psf_nod, psf_ele, psf_phys%d_fld(1,1), map_data, & + & black, pvr_rgb, map_e1) + end if + else + call fill_map_one_color & + & (pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & color_param%bg_rgba_real, pvr_rgb%rgba_real_gl) + end if +! + if(map_data%num_line .gt. 0) then + call s_draw_xyz_plane_isolines & + & (psf_nod, psf_ele, psf_phys%d_fld(1,2), map_data, & + & color_param, pvr_rgb, map_e1) + if(map_data%flag_zeroline & + & .and. (map_data%fill_flag.eqv. .FALSE.)) then + call set_flame_color & + & (map_data%fill_flag, color_param%bg_rgba_real, color_ref) + call draw_xyz_plane_zeroline & + & (psf_nod, psf_ele, psf_phys%d_fld(1,2), map_data, & + & white, pvr_rgb, map_e1) + end if + end if +! + if(map_data%iflag_2d_projection_mode .eq. iflag_xz_plane & + & .or. map_data%iflag_2d_projection_mode .eq. iflag_xz_plane & + & ) then + if(map_data%flag_tangent_cylinder) then + call draw_med_tangent_cyl_grid & + & (psf_nod, psf_ele, map_data, color_param%bg_rgba_real, & + & map_data%tangent_cylinder_radius(2), pvr_rgb, map_e1) + end if + end if +! + call draw_radius_grid(psf_nod, psf_ele, map_data, & + & color_param%bg_rgba_real, map_data%tangent_cylinder_radius(2), & + & pvr_rgb, map_e1) + call draw_radius_grid(psf_nod, psf_ele, map_data, & + & color_param%bg_rgba_real, map_data%tangent_cylinder_radius(1), & + & pvr_rgb, map_e1) + call dealloc_map_patch_from_1patch(map_e1) +! + call fill_background & + & (pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & color_param%bg_rgba_real, pvr_rgb%rgba_real_gl) +! + if(cbar_param%flag_pvr_colorbar) then + call set_pvr_colorbar(pvr_rgb%num_pixel_xy, pvr_rgb%num_pixels, & + & color_param, cbar_param, pvr_rgb%rgba_real_gl(1,1)) + end if +! + if(cbar_param%flag_draw_time) then + call set_pvr_timelabel & + & (time_d%time, pvr_rgb%num_pixel_xy, pvr_rgb%num_pixels, & + & cbar_param, pvr_rgb%rgba_real_gl(1,1)) + end if +! + end subroutine s_xyz_plane_rendering +! +! --------------------------------------------------------------------- +! + end module xyz_plane_rendering diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/FEM_to_VIZ_bridge.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/FEM_to_VIZ_bridge.f90 new file mode 100644 index 00000000..3987e58e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/FEM_to_VIZ_bridge.f90 @@ -0,0 +1,161 @@ +!>@file FEM_to_VIZ_bridge.f90 +!!@brief module FEM_to_VIZ_bridge +!! +!!@author H. Matsui +!!@date Programmed in June, 2006 +! +!>@brief Data structuresa for visualizers +!! +!!@verbatim +!! subroutine init_FEM_to_VIZ_bridge & +!! & (elps_VIZ, viz_step, geofem, VIZ_DAT, m_SR) +!! type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ +!! type(VIZ_step_params), intent(in) :: viz_step +!! type(mesh_data), intent(inout) :: geofem +!! type(VIZ_mesh_field), intent(inout) :: VIZ_DAT +!! type(mesh_SR), intent(inout) :: m_SR +!! subroutine init_FEM_MHD_to_VIZ_bridge & +!! & (elps_VIZ, viz_step, next_tbl, jacobians, & +!! & geofem, VIZ_DAT, m_SR) +!! type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ +!! type(VIZ_step_params), intent(in) :: viz_step +!! type(next_nod_ele_table), intent(in), target :: next_tbl +!! type(jacobians_type), intent(in), target :: jacobians +!! type(mesh_data), intent(inout) :: geofem +!! type(VIZ_mesh_field), intent(inout) :: VIZ_DAT +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module FEM_to_VIZ_bridge +! + use m_precision + use m_machine_parameter + use m_work_time +! + use t_mesh_data + use t_comm_table + use t_next_node_ele_4_node + use t_shape_functions + use t_jacobians + use t_VIZ_step_parameter + use t_VIZ_mesh_field + use t_mesh_SR + use t_work_time + use t_elapsed_labels_4_VIZ +! + implicit none +! + private :: normals_and_jacobians_4_VIZ +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine init_FEM_to_VIZ_bridge & + & (elps_VIZ, viz_step, geofem, VIZ_DAT, m_SR) +! + use parallel_FEM_mesh_init +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(VIZ_step_params), intent(in) :: viz_step +! + type(mesh_data), intent(inout) :: geofem + type(VIZ_mesh_field), intent(inout) :: VIZ_DAT + type(mesh_SR), intent(inout) :: m_SR +! +! + call FEM_mesh_initialization(geofem%mesh, geofem%group, & + & m_SR%SR_sig, m_SR%SR_i) +! + if(iflag_debug.gt.0) write(*,*) 'normals_and_jacobians_VIZ_pre' + call link_jacobians_4_viz & + & (VIZ_DAT%next_tbl_v, VIZ_DAT%jacobians_v, VIZ_DAT) +! + if(iflag_debug.gt.0) write(*,*) 'normals_and_jacobians_4_VIZ' + call normals_and_jacobians_4_VIZ(elps_VIZ, viz_step, geofem, & + & VIZ_DAT%next_tbl, VIZ_DAT%jacobians) +! + call init_mesh_data_for_vizs(elps_VIZ, viz_step, geofem%mesh, & + & VIZ_DAT, m_SR) +! + end subroutine init_FEM_to_VIZ_bridge +! +! ---------------------------------------------------------------------- +! + subroutine init_FEM_MHD_to_VIZ_bridge & + & (elps_VIZ, viz_step, next_tbl, jacobians, & + & geofem, VIZ_DAT, m_SR) +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(VIZ_step_params), intent(in) :: viz_step + type(next_nod_ele_table), intent(in), target :: next_tbl + type(jacobians_type), intent(in), target :: jacobians +! + type(mesh_data), intent(inout) :: geofem + type(VIZ_mesh_field), intent(inout) :: VIZ_DAT + type(mesh_SR), intent(inout) :: m_SR +! +! + call link_jacobians_4_viz(next_tbl, jacobians, VIZ_DAT) + call init_mesh_data_for_vizs(elps_VIZ, viz_step, geofem%mesh, & + & VIZ_DAT, m_SR) +! + end subroutine init_FEM_MHD_to_VIZ_bridge +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine normals_and_jacobians_4_VIZ & + & (elps_VIZ, viz_step, geofem, next_tbl, jacobians) +! + use t_fem_gauss_int_coefs + use int_volume_of_domain + use set_element_id_4_node + use set_normal_vectors +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(VIZ_step_params), intent(in) :: viz_step + type(mesh_data), intent(inout) :: geofem + type(next_nod_ele_table), intent(inout) :: next_tbl + type(jacobians_type), intent(inout) :: jacobians +! + integer(kind = kint) :: iflag + type(shape_finctions_at_points) :: spfs +! +! +! ----- Const Neighboring information + if(viz_step%LIC_t%increment .gt. 0) then + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+16) + if(iflag_debug.gt.0) write(*,*) 'set_belonged_ele_and_next_nod' + call set_belonged_ele_and_next_nod & + & (geofem%mesh, next_tbl%neib_ele, next_tbl%neib_nod) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+16) + end if +! + iflag = viz_step%PVR_t%increment + viz_step%LIC_t%increment & + & + viz_step%FLINE_t%increment + viz_step%TRACER_t%increment + if(iflag .gt. 0) then + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+16) + if(iflag_debug.gt.0) write(*,*) 'jacobian_and_element_volume' +! call sel_max_int_point_by_etype & +! & (geofem%mesh%ele%nnod_4_ele, jacobians%g_FEM) + call set_max_integration_points(ione, jacobians%g_FEM) + call jacobian_and_element_volume(my_rank, nprocs, & + & geofem%mesh, geofem%group, spfs, jacobians) + if (iflag_debug.eq.1) write(*,*) 'surf_jacobian_sf_grp_normal' + call surf_jacobian_sf_grp_normal(my_rank, nprocs, & + & geofem%mesh, geofem%group, spfs, jacobians) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+16) + end if +! + end subroutine normals_and_jacobians_4_VIZ +! +! ---------------------------------------------------------------------- +! + end module FEM_to_VIZ_bridge diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/Makefile b/src/Fortran_libraries/VIZ_src/volume_rendering/Makefile new file mode 100644 index 00000000..a6abbdca --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/Makefile @@ -0,0 +1,41 @@ +# +# +# + +PVR_DIR = $$(VIZ_SRCDIR)/volume_rendering +SOURCES = $(shell ls *.f90 *.F90) +MOD_PVR = $(addsuffix .o,$(basename $(SOURCES)) ) + +# +# -------------------------------------------------------------------- +# + +dir_list: + @echo 'PVR_DIR = $(PVR_DIR)' >> $(MAKENAME) + +lib_name: + +lib_tasks: lib_archve + @echo ' ''$$(RANLIB) $$@' >> $(MAKENAME) + +libtarget: + +lib_archve: libtarget + @echo ' ''$$(AR)' '$$(ARFLUGS)' rcsv '$$@' '$$(MOD_PVR)' \ + >> $(MAKENAME) + + + +mod_list: + @echo MOD_PVR= \\ >> $(MAKENAME) + @echo $(MOD_PVR) >> $(MAKENAME) + @echo >> $(MAKENAME) + +module: + @cat Makefile.depends >> $(MAKENAME) + +depends: + @$(MAKE_MOD_DEP) Makefile.depends '$$(PVR_DIR)' $(SOURCES) + +clean: + rm -f *.o *.mod *~ *.par *.diag *.a diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/Makefile.depends b/src/Fortran_libraries/VIZ_src/volume_rendering/Makefile.depends new file mode 100644 index 00000000..39867c07 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/Makefile.depends @@ -0,0 +1,219 @@ +FEM_to_VIZ_bridge.o: $(PVR_DIR)/FEM_to_VIZ_bridge.f90 m_precision.o m_machine_parameter.o m_work_time.o t_mesh_data.o t_comm_table.o t_next_node_ele_4_node.o t_shape_functions.o t_jacobians.o t_VIZ_step_parameter.o t_VIZ_mesh_field.o t_mesh_SR.o t_work_time.o t_elapsed_labels_4_VIZ.o parallel_FEM_mesh_init.o t_fem_gauss_int_coefs.o int_volume_of_domain.o set_element_id_4_node.o set_normal_vectors.o + $(F90) -c $(F90OPTFLAGS) $< +anaglyph_volume_renderings.o: $(PVR_DIR)/anaglyph_volume_renderings.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o m_work_time.o t_mesh_data.o t_phys_data.o t_jacobians.o t_particle_trace.o t_fieldline.o t_volume_rendering.o t_surf_grp_list_each_surf.o t_rendering_vr_image.o t_control_params_4_pvr.o t_surf_grp_4_pvr_domain.o t_pvr_ray_startpoints.o t_pvr_image_array.o t_pvr_field_data.o t_geometries_in_pvr_screen.o t_control_data_pvrs.o t_mesh_SR.o set_PVR_view_and_image.o each_volume_rendering.o each_anaglyph_PVR.o write_multi_PVR_image.o + $(F90) -c $(F90OPTFLAGS) $< +bcast_control_data_4_pvr.o: $(PVR_DIR)/bcast_control_data_4_pvr.f90 m_precision.o calypso_mpi.o t_control_data_4_pvr.o calypso_mpi_int.o calypso_mpi_char.o bcast_control_arrays.o bcast_pvr_color_ctl.o bcast_ctl_data_view_trans.o bcast_ctl_data_pvr_surfaces.o transfer_to_long_integers.o + $(F90) -c $(F90OPTFLAGS) $< +bcast_control_data_pvrs.o: $(PVR_DIR)/bcast_control_data_pvrs.f90 m_precision.o m_machine_parameter.o t_control_data_pvrs.o calypso_mpi.o calypso_mpi_int.o calypso_mpi_char.o transfer_to_long_integers.o bcast_control_data_4_pvr.o + $(F90) -c $(F90OPTFLAGS) $< +bcast_ctl_data_pvr_surfaces.o: $(PVR_DIR)/bcast_ctl_data_pvr_surfaces.f90 m_precision.o m_machine_parameter.o calypso_mpi.o t_control_data_pvr_sections.o bcast_control_arrays.o calypso_mpi_int.o calypso_mpi_char.o transfer_to_long_integers.o t_control_data_pvr_isosurfs.o t_control_data_pvr_tracers.o t_ctl_data_pvr_section.o bcast_section_control_data.o t_ctl_data_pvr_isosurface.o t_ctl_data_pvr_tracer.o + $(F90) -c $(F90OPTFLAGS) $< +bcast_ctl_data_view_trans.o: $(PVR_DIR)/bcast_ctl_data_view_trans.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o t_ctl_data_pvr_movie.o calypso_mpi_int.o calypso_mpi_char.o transfer_to_long_integers.o bcast_control_arrays.o t_ctl_data_quilt_image.o t_ctl_data_view_transfers.o t_ctl_data_4_view_transfer.o t_ctl_data_4_screen_pixel.o t_ctl_data_4_projection.o t_ctl_data_4_streo_view.o + $(F90) -c $(F90OPTFLAGS) $< +bcast_ctl_data_viz4.o: $(PVR_DIR)/bcast_ctl_data_viz4.f90 m_precision.o m_machine_parameter.o calypso_mpi_int.o t_control_data_viz4.o calypso_mpi_char.o bcast_control_arrays.o bcast_section_control_data.o bcast_maps_control_data.o bcast_ctl_data_field_line.o bcast_control_data_pvrs.o transfer_to_long_integers.o + $(F90) -c $(F90OPTFLAGS) $< +bcast_pvr_color_ctl.o: $(PVR_DIR)/bcast_pvr_color_ctl.f90 m_precision.o m_machine_parameter.o calypso_mpi.o t_ctl_data_pvr_colormap.o bcast_control_arrays.o calypso_mpi_int.o calypso_mpi_char.o transfer_to_long_integers.o t_ctl_data_pvr_light.o t_ctl_data_pvr_colorbar.o t_ctl_data_pvr_area.o + $(F90) -c $(F90OPTFLAGS) $< +cal_pvr_modelview_mat.o: $(PVR_DIR)/cal_pvr_modelview_mat.f90 m_precision.o m_constants.o m_machine_parameter.o t_control_params_4_pvr.o t_geometries_in_pvr_screen.o t_control_params_stereo_pvr.o t_surf_grp_4_pvr_domain.o cal_inverse_small_matrix.o small_mat_mat_product.o transform_mat_operations.o mag_of_field_smp.o cal_products_smp.o + $(F90) -c $(F90OPTFLAGS) $< +cal_pvr_projection_mat.o: $(PVR_DIR)/cal_pvr_projection_mat.f90 m_precision.o m_constants.o m_machine_parameter.o t_control_params_4_pvr.o t_control_params_stereo_pvr.o set_projection_matrix.o + $(F90) -c $(F90OPTFLAGS) $< +colormap_grayscales.o: $(PVR_DIR)/colormap_grayscales.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +colormap_metal.o: $(PVR_DIR)/colormap_metal.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +colormap_rainbow.o: $(PVR_DIR)/colormap_rainbow.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +colormap_space.o: $(PVR_DIR)/colormap_space.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +colormap_two_colors.o: $(PVR_DIR)/colormap_two_colors.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +comm_tbl_4_img_composit.o: $(PVR_DIR)/comm_tbl_4_img_composit.f90 m_precision.o m_constants.o quicksort.o + $(F90) -c $(F90OPTFLAGS) $< +comm_tbl_4_img_output.o: $(PVR_DIR)/comm_tbl_4_img_output.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +const_comm_tbl_img_composit.o: $(PVR_DIR)/const_comm_tbl_img_composit.f90 m_precision.o m_constants.o calypso_mpi.o t_calypso_comm_table.o t_stencil_buffer_work.o comm_tbl_4_img_output.o m_error_IDs.o calypso_mpi_int.o comm_tbl_4_img_composit.o quicksort.o + $(F90) -c $(F90OPTFLAGS) $< +convert_real_rgb_2_bite.o: $(PVR_DIR)/convert_real_rgb_2_bite.f90 m_precision.o m_constants.o calypso_mpi.o + $(F90) -c $(F90OPTFLAGS) $< +count_pvr_ray_start_point.o: $(PVR_DIR)/count_pvr_ray_start_point.f90 m_precision.o calypso_mpi.o m_constants.o m_geometry_constants.o t_control_params_4_pvr.o t_geometry_data.o t_surface_data.o set_position_pvr_screen.o cal_fline_in_cube.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_data_each_pvr_IO.o: $(PVR_DIR)/ctl_data_each_pvr_IO.f90 m_precision.o calypso_mpi.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_4_view_transfer.o t_control_array_integer.o t_control_array_character.o t_control_array_chara2real.o t_ctl_data_pvr_colormap_bar.o t_ctl_data_pvr_light.o t_control_data_pvr_sections.o t_ctl_data_quilt_image.o t_ctl_data_pvr_movie.o t_control_data_pvr_isosurfs.o t_ctl_data_pvr_area.o t_control_data_4_pvr.o skip_comment_f.o ctl_file_pvr_modelview_IO.o ctl_file_pvr_light_IO.o ctl_data_pvr_movie_IO.o ctl_data_view_transfer_IO.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_data_four_vizs_IO.o: $(PVR_DIR)/ctl_data_four_vizs_IO.f90 m_precision.o m_machine_parameter.o calypso_mpi.o t_control_data_viz4.o t_control_data_sections.o t_control_data_isosurfaces.o t_control_data_pvrs.o t_control_data_flines.o t_control_array_character.o t_control_array_real.o t_control_array_integer.o t_read_control_elements.o ctl_file_sections_IO.o ctl_file_isosurfaces_IO.o ctl_file_map_renderings_IO.o ctl_file_fieldlines_IO.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_data_pvr_colorbar_IO.o: $(PVR_DIR)/ctl_data_pvr_colorbar_IO.f90 m_precision.o calypso_mpi.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_4_view_transfer.o t_control_array_character.o t_control_array_integer.o t_control_array_real2.o t_ctl_data_pvr_colorbar.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_data_pvr_colormap_IO.o: $(PVR_DIR)/ctl_data_pvr_colormap_IO.f90 m_precision.o calypso_mpi.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_4_view_transfer.o t_control_array_character.o t_control_array_real.o t_control_array_real2.o t_control_array_real3.o t_ctl_data_pvr_colormap.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_data_pvr_movie_IO.o: $(PVR_DIR)/ctl_data_pvr_movie_IO.f90 m_precision.o calypso_mpi.o m_machine_parameter.o t_read_control_elements.o t_control_data_4_psf.o t_control_array_character.o t_control_array_integer.o t_control_array_real2.o t_control_array_integer2.o t_ctl_data_4_view_transfer.o t_ctl_data_view_transfers.o t_ctl_data_pvr_movie.o skip_comment_f.o ctl_file_pvr_modelview_IO.o write_control_elements.o ctl_data_view_transfer_IO.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_data_view_transfer_IO.o: $(PVR_DIR)/ctl_data_view_transfer_IO.f90 m_precision.o m_constants.o m_machine_parameter.o t_read_control_elements.o t_control_array_real.o t_control_array_charareal.o t_control_array_chara2real.o t_ctl_data_4_screen_pixel.o t_ctl_data_4_projection.o t_ctl_data_4_streo_view.o t_ctl_data_4_view_transfer.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_file_each_pvr_IO.o: $(PVR_DIR)/ctl_file_each_pvr_IO.f90 m_precision.o t_control_data_4_pvr.o ctl_data_each_pvr_IO.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_file_pvr_light_IO.o: $(PVR_DIR)/ctl_file_pvr_light_IO.f90 m_precision.o m_constants.o m_machine_parameter.o t_ctl_data_pvr_light.o t_read_control_elements.o write_control_elements.o ctl_data_view_transfer_IO.o skip_comment_f.o + $(F90) -c $(F90OPTFLAGS) $< +ctl_file_pvr_modelview_IO.o: $(PVR_DIR)/ctl_file_pvr_modelview_IO.f90 m_precision.o m_constants.o m_machine_parameter.o t_ctl_data_4_view_transfer.o t_read_control_elements.o ctl_data_view_transfer_IO.o write_control_elements.o skip_comment_f.o + $(F90) -c $(F90OPTFLAGS) $< +draw_pvr_colorbar.o: $(PVR_DIR)/draw_pvr_colorbar.f90 m_precision.o m_constants.o t_pvr_colormap_parameter.o draw_pvr_colorbar_nums.o set_color_4_pvr.o set_rgba_4_each_pixel.o + $(F90) -c $(F90OPTFLAGS) $< +draw_pvr_colorbar_nums.o: $(PVR_DIR)/draw_pvr_colorbar_nums.f90 m_precision.o m_constants.o set_color_4_pvr.o pvr_font_texture.o + $(F90) -c $(F90OPTFLAGS) $< +each_anaglyph_PVR.o: $(PVR_DIR)/each_anaglyph_PVR.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o t_mesh_data.o t_phys_data.o t_jacobians.o t_particle_trace.o t_fieldline.o t_surf_grp_list_each_surf.o t_rendering_vr_image.o t_control_params_4_pvr.o t_surf_grp_4_pvr_domain.o t_pvr_ray_startpoints.o t_pvr_image_array.o t_geometries_in_pvr_screen.o t_pvr_field_data.o t_mesh_SR.o set_default_pvr_params.o set_position_pvr_screen.o mesh_outline_4_pvr.o generate_vr_image.o rendering_streo_vr_image.o cal_pvr_modelview_mat.o rendering_vr_image.o m_work_time.o t_rotation_pvr_images.o write_multi_PVR_image.o set_PVR_view_and_image.o output_image_sel_4_png.o + $(F90) -c $(F90OPTFLAGS) $< +each_volume_rendering.o: $(PVR_DIR)/each_volume_rendering.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o t_mesh_data.o t_phys_data.o t_jacobians.o t_particle_trace.o t_fieldline.o t_surf_grp_list_each_surf.o t_rendering_vr_image.o t_control_params_4_pvr.o t_surf_grp_4_pvr_domain.o t_pvr_ray_startpoints.o t_pvr_image_array.o t_geometries_in_pvr_screen.o t_pvr_field_data.o t_mesh_SR.o set_default_pvr_params.o set_position_pvr_screen.o mesh_outline_4_pvr.o generate_vr_image.o rendering_streo_vr_image.o t_control_data_pvr_sections.o set_pvr_control.o find_pvr_surf_domain.o set_iflag_for_used_ele.o cal_pvr_modelview_mat.o rendering_vr_image.o m_work_time.o set_PVR_view_and_image.o write_PVR_image.o + $(F90) -c $(F90OPTFLAGS) $< +elapsed_labels_4_PVR.o: $(PVR_DIR)/elapsed_labels_4_PVR.f90 m_precision.o m_work_time.o + $(F90) -c $(F90OPTFLAGS) $< +find_pvr_surf_domain.o: $(PVR_DIR)/find_pvr_surf_domain.f90 m_precision.o m_constants.o m_geometry_constants.o t_geometry_data.o t_surface_data.o t_control_params_4_pvr.o t_surf_grp_4_pvr_domain.o t_geometries_in_pvr_screen.o find_selected_domain_bd.o pvr_surface_enhancement.o ordering_pvr_sf_domain_grp.o cal_fline_in_cube.o set_position_pvr_screen.o + $(F90) -c $(F90OPTFLAGS) $< +generate_vr_image.o: $(PVR_DIR)/generate_vr_image.f90 m_precision.o m_machine_parameter.o m_constants.o calypso_mpi.o t_control_params_4_pvr.o t_geometries_in_pvr_screen.o t_surf_grp_4_pvr_domain.o t_pvr_ray_startpoints.o t_pvr_image_array.o m_geometry_constants.o t_geometry_data.o t_surface_data.o set_position_pvr_screen.o find_pvr_surf_domain.o pvr_axis_label.o count_pvr_ray_start_point.o set_pvr_ray_start_point.o cal_field_on_surf_viz.o + $(F90) -c $(F90OPTFLAGS) $< +m_elapsed_labels_4_VIZ.o: $(PVR_DIR)/m_elapsed_labels_4_VIZ.f90 m_precision.o m_work_time.o t_elapsed_labels_4_VIZ.o + $(F90) -c $(F90OPTFLAGS) $< +m_pvr_control_labels.o: $(PVR_DIR)/m_pvr_control_labels.f90 m_precision.o m_constants.o t_control_array_character.o + $(F90) -c $(F90OPTFLAGS) $< +mesh_outline_4_pvr.o: $(PVR_DIR)/mesh_outline_4_pvr.f90 m_precision.o m_constants.o m_machine_parameter.o calypso_mpi.o t_surf_grp_4_pvr_domain.o t_geometry_data.o calypso_mpi_real.o + $(F90) -c $(F90OPTFLAGS) $< +mpi_write_quilt_BMP_file.o: $(PVR_DIR)/mpi_write_quilt_BMP_file.F90 m_precision.o m_constants.o calypso_mpi.o t_MPI_quilt_bitmap_IO.o output_image_sel_4_png.o m_calypso_mpi_IO.o MPI_ascii_data_IO.o t_calypso_mpi_IO_param.o write_bmp_image.o t_buffer_4_gzip.o zlib_convert_text.o data_convert_by_zlib.o calypso_mpi_int8.o transfer_to_long_integers.o set_parallel_file_name.o + $(F90) -c $(F90OPTFLAGS) $(F90CPPFLAGS) $< +multi_volume_renderings.o: $(PVR_DIR)/multi_volume_renderings.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o m_work_time.o t_mesh_data.o t_phys_data.o t_jacobians.o t_particle_trace.o t_fieldline.o t_volume_rendering.o t_surf_grp_list_each_surf.o t_rendering_vr_image.o t_control_params_4_pvr.o t_surf_grp_4_pvr_domain.o t_pvr_ray_startpoints.o t_pvr_image_array.o t_pvr_field_data.o t_geometries_in_pvr_screen.o t_control_data_pvrs.o t_mesh_SR.o set_PVR_view_and_image.o cal_pvr_modelview_mat.o each_volume_rendering.o each_anaglyph_PVR.o + $(F90) -c $(F90OPTFLAGS) $< +ordering_pvr_sf_domain_grp.o: $(PVR_DIR)/ordering_pvr_sf_domain_grp.f90 m_precision.o m_constants.o t_surf_grp_4_pvr_domain.o quicksort.o + $(F90) -c $(F90OPTFLAGS) $< +pvr_axis_label.o: $(PVR_DIR)/pvr_axis_label.f90 m_precision.o m_constants.o t_geometries_in_pvr_screen.o set_position_pvr_screen.o t_control_params_4_pvr.o draw_pvr_colorbar_nums.o + $(F90) -c $(F90OPTFLAGS) $< +pvr_font_texture.o: $(PVR_DIR)/pvr_font_texture.f90 m_constants.o m_precision.o + $(F90) -c $(F90OPTFLAGS) $< +pvr_surface_enhancement.o: $(PVR_DIR)/pvr_surface_enhancement.f90 m_precision.o m_constants.o m_machine_parameter.o m_geometry_constants.o t_surface_data.o t_surf_grp_list_each_surf.o t_group_data.o t_surface_group_normals.o t_surface_group_connect.o t_control_params_4_pvr.o calypso_mpi.o m_pvr_control_labels.o skip_comment_f.o set_position_pvr_screen.o + $(F90) -c $(F90OPTFLAGS) $< +ray_trace_4_each_image.o: $(PVR_DIR)/ray_trace_4_each_image.f90 m_precision.o m_constants.o m_geometry_constants.o calypso_mpi.o set_rgba_4_each_pixel.o t_mesh_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_particle_trace.o t_fieldline.o t_surf_grp_list_each_surf.o t_control_params_4_pvr.o t_pvr_colormap_parameter.o t_pvr_field_data.o t_geometries_in_pvr_screen.o t_pvr_ray_startpoints.o set_position_pvr_screen.o cal_field_on_surf_viz.o cal_fline_in_cube.o set_coefs_of_sections.o pvr_surface_enhancement.o t_local_fline.o + $(F90) -c $(F90OPTFLAGS) $< +rendering_and_image_nums.o: $(PVR_DIR)/rendering_and_image_nums.f90 m_precision.o calypso_mpi.o t_control_data_4_pvr.o t_rendering_vr_image.o t_pvr_image_array.o t_sort_PVRs_by_type.o m_error_IDs.o set_composition_pe_range.o set_parallel_file_name.o delete_data_files.o t_control_params_4_pvr.o set_area_4_viz.o skip_comment_f.o output_image_sel_4_png.o + $(F90) -c $(F90OPTFLAGS) $< +rendering_streo_vr_image.o: $(PVR_DIR)/rendering_streo_vr_image.f90 m_precision.o m_machine_parameter.o m_constants.o m_work_time.o calypso_mpi.o t_mesh_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_phys_data.o t_jacobians.o t_surf_grp_list_each_surf.o t_rendering_vr_image.o t_control_params_4_pvr.o t_geometries_in_pvr_screen.o t_surf_grp_4_pvr_domain.o t_pvr_ray_startpoints.o t_pvr_image_array.o t_pvr_field_data.o t_solver_SR.o t_solver_SR_int.o generate_vr_image.o t_rotation_pvr_images.o set_PVR_view_and_image.o write_multi_PVR_image.o output_image_sel_4_png.o rendering_vr_image.o + $(F90) -c $(F90OPTFLAGS) $< +rendering_vr_image.o: $(PVR_DIR)/rendering_vr_image.f90 m_precision.o m_machine_parameter.o m_constants.o m_work_time.o calypso_mpi.o t_mesh_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_particle_trace.o t_fieldline.o t_surf_grp_list_each_surf.o t_control_params_4_pvr.o t_pvr_colormap_parameter.o t_geometries_in_pvr_screen.o t_pvr_ray_startpoints.o t_pvr_image_array.o t_pvr_stencil_buffer.o t_pvr_field_data.o t_rendering_vr_image.o t_control_params_stereo_pvr.o t_mesh_SR.o generate_vr_image.o cal_pvr_projection_mat.o cal_pvr_modelview_mat.o write_PVR_image.o m_geometry_constants.o t_solver_SR.o ray_trace_4_each_image.o draw_pvr_colorbar.o pvr_axis_label.o + $(F90) -c $(F90OPTFLAGS) $< +set_PVR_view_and_image.o: $(PVR_DIR)/set_PVR_view_and_image.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o m_work_time.o t_mesh_data.o t_pvr_image_array.o t_rendering_vr_image.o t_surf_grp_4_pvr_domain.o t_geometries_in_pvr_screen.o t_mesh_SR.o rendering_vr_image.o cal_pvr_modelview_mat.o cal_pvr_projection_mat.o + $(F90) -c $(F90OPTFLAGS) $< +set_color_4_pvr.o: $(PVR_DIR)/set_color_4_pvr.f90 m_precision.o set_rgb_colors.o colormap_rainbow.o colormap_two_colors.o colormap_grayscales.o colormap_metal.o colormap_space.o + $(F90) -c $(F90OPTFLAGS) $< +set_composition_pe_range.o: $(PVR_DIR)/set_composition_pe_range.f90 m_precision.o t_rendering_vr_image.o t_pvr_image_array.o + $(F90) -c $(F90OPTFLAGS) $< +set_control_each_pvr.o: $(PVR_DIR)/set_control_each_pvr.f90 m_precision.o m_constants.o m_error_IDs.o t_control_data_4_pvr.o calypso_mpi.o set_field_comp_for_viz.o output_image_sel_4_png.o t_control_params_4_pvr.o skip_comment_f.o t_control_array_character.o t_group_data.o t_particle_trace.o t_fieldline.o t_pvr_colormap_parameter.o t_geometries_in_pvr_screen.o t_ctl_param_tracer_render.o set_color_4_pvr.o set_rgba_4_each_pixel.o set_coefs_of_sections.o set_control_pvr_color.o t_ctl_data_pvr_area.o pvr_surface_enhancement.o set_area_4_viz.o t_control_data_pvr_sections.o t_control_data_pvr_isosurfs.o m_pvr_control_labels.o + $(F90) -c $(F90OPTFLAGS) $< +set_control_pvr_color.o: $(PVR_DIR)/set_control_pvr_color.f90 m_precision.o m_constants.o m_error_IDs.o calypso_mpi.o t_pvr_colormap_parameter.o skip_comment_f.o t_ctl_data_pvr_light.o set_color_4_pvr.o set_rgba_4_each_pixel.o t_ctl_data_pvr_colormap.o t_ctl_data_pvr_colorbar.o + $(F90) -c $(F90OPTFLAGS) $< +set_control_pvr_movie.o: $(PVR_DIR)/set_control_pvr_movie.f90 m_precision.o m_constants.o m_error_IDs.o calypso_mpi.o t_ctl_data_pvr_movie.o t_control_params_4_pvr.o t_geometries_in_pvr_screen.o m_pvr_control_labels.o output_image_sel_4_png.o skip_comment_f.o + $(F90) -c $(F90OPTFLAGS) $< +set_default_pvr_params.o: $(PVR_DIR)/set_default_pvr_params.f90 m_precision.o m_constants.o t_control_params_4_pvr.o t_pvr_colormap_parameter.o t_surf_grp_4_pvr_domain.o t_geometries_in_pvr_screen.o set_color_4_pvr.o + $(F90) -c $(F90OPTFLAGS) $< +set_position_pvr_screen.o: $(PVR_DIR)/set_position_pvr_screen.f90 m_precision.o m_constants.o m_machine_parameter.o m_geometry_constants.o + $(F90) -c $(F90OPTFLAGS) $< +set_projection_matrix.o: $(PVR_DIR)/set_projection_matrix.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +set_pvr_control.o: $(PVR_DIR)/set_pvr_control.f90 m_precision.o calypso_mpi.o t_control_data_4_pvr.o ctl_file_pvr_modelview_IO.o bcast_control_data_4_pvr.o t_group_data.o t_phys_data.o t_particle_trace.o t_fieldline.o t_rendering_vr_image.o t_geometries_in_pvr_screen.o t_control_data_pvr_sections.o set_control_each_pvr.o set_field_comp_for_viz.o set_pvr_modelview_matrix.o set_control_pvr_movie.o t_pvr_colormap_parameter.o + $(F90) -c $(F90OPTFLAGS) $< +set_pvr_modelview_matrix.o: $(PVR_DIR)/set_pvr_modelview_matrix.f90 m_precision.o calypso_mpi.o m_constants.o m_error_IDs.o t_ctl_data_4_view_transfer.o t_control_params_4_pvr.o t_geometries_in_pvr_screen.o t_control_params_stereo_pvr.o t_ctl_data_4_screen_pixel.o t_ctl_data_4_projection.o t_ctl_data_4_streo_view.o skip_comment_f.o + $(F90) -c $(F90OPTFLAGS) $< +set_pvr_ray_start_point.o: $(PVR_DIR)/set_pvr_ray_start_point.f90 m_precision.o calypso_mpi.o m_constants.o m_geometry_constants.o t_geometry_data.o t_surface_data.o t_control_params_4_pvr.o cal_field_on_surf_viz.o calypso_mpi_int.o write_bmp_image.o + $(F90) -c $(F90OPTFLAGS) $< +set_pvr_stencil_buffer.o: $(PVR_DIR)/set_pvr_stencil_buffer.f90 m_precision.o m_constants.o m_machine_parameter.o calypso_mpi.o t_calypso_comm_table.o t_pvr_ray_startpoints.o t_pvr_image_stack_table.o t_stencil_buffer_work.o t_solver_SR.o t_solver_SR_int.o m_work_time.o quicksort.o calypso_SR_type.o const_comm_tbl_img_composit.o set_parallel_file_name.o + $(F90) -c $(F90OPTFLAGS) $< +set_rgb_colors.o: $(PVR_DIR)/set_rgb_colors.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +set_rgba_4_each_pixel.o: $(PVR_DIR)/set_rgba_4_each_pixel.f90 m_precision.o m_constants.o t_pvr_colormap_parameter.o set_color_4_pvr.o + $(F90) -c $(F90OPTFLAGS) $< +t_MPI_quilt_bitmap_IO.o: $(PVR_DIR)/t_MPI_quilt_bitmap_IO.f90 m_precision.o m_constants.o calypso_mpi.o set_parallel_file_name.o output_image_sel_4_png.o + $(F90) -c $(F90OPTFLAGS) $< +t_VIZ_mesh_field.o: $(PVR_DIR)/t_VIZ_mesh_field.f90 m_precision.o m_machine_parameter.o t_comm_table.o t_phys_data.o t_next_node_ele_4_node.o t_shape_functions.o t_jacobians.o t_VIZ_step_parameter.o t_para_double_numbering.o t_parallel_surface_indices.o t_elapsed_labels_4_VIZ.o m_work_time.o t_work_time.o int_volume_of_domain.o set_element_id_4_node.o parallel_FEM_mesh_init.o const_element_comm_tables.o const_surface_comm_table.o set_normal_vectors.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_data_4_pvr.o: $(PVR_DIR)/t_control_data_4_pvr.f90 m_precision.o calypso_mpi.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_4_view_transfer.o t_control_array_integer.o t_control_array_character.o t_control_array_chara2real.o t_ctl_data_pvr_colormap_bar.o t_ctl_data_pvr_light.o t_ctl_data_pvr_movie.o t_ctl_data_quilt_image.o t_control_data_pvr_sections.o t_control_data_pvr_isosurfs.o t_control_data_pvr_tracers.o t_ctl_data_pvr_area.o skip_comment_f.o t_control_array_character3.o add_nodal_fields_ctl.o bcast_control_arrays.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_data_pvr_isosurfs.o: $(PVR_DIR)/t_control_data_pvr_isosurfs.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_character.o t_control_array_real.o t_ctl_data_pvr_isosurface.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_data_pvr_sections.o: $(PVR_DIR)/t_control_data_pvr_sections.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_data_4_psf_def.o t_control_array_real.o t_control_array_character.o t_control_array_chara2real.o t_ctl_data_pvr_section.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_data_pvr_tracers.o: $(PVR_DIR)/t_control_data_pvr_tracers.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_character.o t_control_array_real.o t_ctl_data_pvr_tracer.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_data_pvrs.o: $(PVR_DIR)/t_control_data_pvrs.f90 m_precision.o m_machine_parameter.o t_control_data_4_pvr.o t_read_control_elements.o skip_comment_f.o write_control_elements.o ctl_file_each_pvr_IO.o t_control_array_character3.o ctl_data_each_pvr_IO.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_data_viz4.o: $(PVR_DIR)/t_control_data_viz4.f90 m_precision.o m_machine_parameter.o t_control_data_sections.o t_control_data_isosurfaces.o t_control_data_maps.o t_control_data_pvrs.o t_control_data_flines.o t_control_array_character.o t_control_array_real.o t_control_array_integer.o t_control_array_character3.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_params_4_pvr.o: $(PVR_DIR)/t_control_params_4_pvr.f90 m_precision.o m_constants.o output_image_sel_4_png.o + $(F90) -c $(F90OPTFLAGS) $< +t_control_params_stereo_pvr.o: $(PVR_DIR)/t_control_params_stereo_pvr.f90 m_precision.o m_constants.o t_control_data_4_pvr.o set_area_4_viz.o skip_comment_f.o t_ctl_data_quilt_image.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_4_projection.o: $(PVR_DIR)/t_ctl_data_4_projection.f90 m_precision.o m_constants.o m_machine_parameter.o t_read_control_elements.o t_control_array_real.o t_control_array_real2.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_4_screen_pixel.o: $(PVR_DIR)/t_ctl_data_4_screen_pixel.f90 m_precision.o m_constants.o m_machine_parameter.o t_read_control_elements.o t_control_array_integer.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_4_streo_view.o: $(PVR_DIR)/t_ctl_data_4_streo_view.f90 m_precision.o m_constants.o m_machine_parameter.o t_read_control_elements.o t_control_array_character.o t_control_array_real.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_4_view_transfer.o: $(PVR_DIR)/t_ctl_data_4_view_transfer.f90 m_precision.o m_constants.o m_machine_parameter.o t_read_control_elements.o t_control_array_real.o t_control_array_character.o t_control_array_charareal.o t_control_array_chara2real.o t_ctl_data_4_screen_pixel.o t_ctl_data_4_projection.o t_ctl_data_4_streo_view.o skip_comment_f.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_pvr_area.o: $(PVR_DIR)/t_ctl_data_pvr_area.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_character.o t_control_array_chara2real.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_pvr_colorbar.o: $(PVR_DIR)/t_ctl_data_pvr_colorbar.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_4_view_transfer.o t_control_array_character.o t_control_array_integer.o t_control_array_real2.o skip_comment_f.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_pvr_colormap.o: $(PVR_DIR)/t_ctl_data_pvr_colormap.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_4_view_transfer.o t_control_array_character.o t_control_array_real.o t_control_array_real2.o t_control_array_real3.o skip_comment_f.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_pvr_colormap_bar.o: $(PVR_DIR)/t_ctl_data_pvr_colormap_bar.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_pvr_colormap.o t_ctl_data_pvr_colorbar.o skip_comment_f.o write_control_elements.o ctl_data_pvr_colorbar_IO.o ctl_data_pvr_colormap_IO.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_pvr_isosurface.o: $(PVR_DIR)/t_ctl_data_pvr_isosurface.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_character.o t_control_array_real.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_pvr_light.o: $(PVR_DIR)/t_ctl_data_pvr_light.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_real.o t_control_array_real3.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_pvr_movie.o: $(PVR_DIR)/t_ctl_data_pvr_movie.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_data_4_psf.o t_control_array_character.o t_control_array_integer.o t_control_array_real2.o t_control_array_integer2.o t_ctl_data_4_view_transfer.o t_ctl_data_view_transfers.o skip_comment_f.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_pvr_section.o: $(PVR_DIR)/t_ctl_data_pvr_section.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_data_4_psf_def.o t_control_array_real.o t_control_array_real2.o t_control_array_integer.o t_control_array_character.o t_control_array_chara2real.o skip_comment_f.o ctl_file_section_def_IO.o write_control_elements.o ctl_data_section_def_IO.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_pvr_tracer.o: $(PVR_DIR)/t_ctl_data_pvr_tracer.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_character.o t_control_array_integer.o t_control_array_real.o t_control_array_real3.o skip_comment_f.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_quilt_image.o: $(PVR_DIR)/t_ctl_data_quilt_image.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_character.o t_control_array_integer.o t_control_array_integer2.o t_control_array_real2.o t_ctl_data_view_transfers.o skip_comment_f.o ctl_file_pvr_modelview_IO.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_data_view_transfers.o: $(PVR_DIR)/t_ctl_data_view_transfers.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_control_array_character.o t_ctl_data_4_view_transfer.o skip_comment_f.o ctl_file_pvr_modelview_IO.o ctl_data_view_transfer_IO.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +t_ctl_param_tracer_render.o: $(PVR_DIR)/t_ctl_param_tracer_render.f90 m_precision.o m_constants.o t_control_data_pvr_tracers.o t_control_params_4_fline.o + $(F90) -c $(F90OPTFLAGS) $< +t_elapsed_labels_4_VIZ.o: $(PVR_DIR)/t_elapsed_labels_4_VIZ.f90 m_precision.o m_work_time.o elapsed_labels_4_PVR.o elapsed_labels_4_FLINE.o elapsed_labels_4_PSF.o + $(F90) -c $(F90OPTFLAGS) $< +t_four_visualizers.o: $(PVR_DIR)/t_four_visualizers.f90 m_precision.o m_machine_parameter.o m_work_time.o calypso_mpi.o t_elapsed_labels_4_VIZ.o t_VIZ_step_parameter.o t_time_data.o t_mesh_data.o t_comm_table.o t_phys_data.o t_next_node_ele_4_node.o t_VIZ_mesh_field.o t_mesh_SR.o t_control_data_viz4.o t_cross_section.o t_isosurface.o t_map_projection.o t_volume_rendering.o t_fieldline.o t_particle_trace.o volume_rendering.o map_projection.o + $(F90) -c $(F90OPTFLAGS) $< +t_geometries_in_pvr_screen.o: $(PVR_DIR)/t_geometries_in_pvr_screen.f90 m_precision.o m_constants.o t_ctl_param_tracer_render.o t_geometry_data.o t_group_data.o t_control_params_4_pvr.o set_projection_matrix.o + $(F90) -c $(F90OPTFLAGS) $< +t_pvr_colormap_parameter.o: $(PVR_DIR)/t_pvr_colormap_parameter.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +t_pvr_field_data.o: $(PVR_DIR)/t_pvr_field_data.f90 m_precision.o m_constants.o t_geometry_data.o t_phys_data.o t_fem_gauss_int_coefs.o t_jacobian_3d.o t_geometries_in_pvr_screen.o t_control_params_4_pvr.o cal_gradient_on_element.o convert_components_4_viz.o + $(F90) -c $(F90OPTFLAGS) $< +t_pvr_image_array.o: $(PVR_DIR)/t_pvr_image_array.f90 m_precision.o calypso_mpi.o m_constants.o t_control_params_4_pvr.o + $(F90) -c $(F90OPTFLAGS) $< +t_pvr_image_stack_table.o: $(PVR_DIR)/t_pvr_image_stack_table.f90 m_precision.o m_constants.o calypso_mpi.o t_calypso_comm_table.o t_stencil_buffer_work.o set_rgba_4_each_pixel.o + $(F90) -c $(F90OPTFLAGS) $< +t_pvr_ray_startpoints.o: $(PVR_DIR)/t_pvr_ray_startpoints.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +t_pvr_stencil_buffer.o: $(PVR_DIR)/t_pvr_stencil_buffer.f90 m_precision.o m_constants.o m_machine_parameter.o calypso_mpi.o t_calypso_comm_table.o t_pvr_ray_startpoints.o t_pvr_image_stack_table.o t_stencil_buffer_work.o t_pvr_image_array.o m_work_time.o set_pvr_stencil_buffer.o t_solver_SR.o calypso_SR_type.o select_copy_from_recv.o + $(F90) -c $(F90OPTFLAGS) $< +t_rendering_vr_image.o: $(PVR_DIR)/t_rendering_vr_image.f90 m_precision.o m_machine_parameter.o m_constants.o m_work_time.o calypso_mpi.o t_mesh_data.o t_geometry_data.o t_surface_data.o t_group_data.o t_surf_grp_list_each_surf.o t_control_params_4_pvr.o t_pvr_colormap_parameter.o t_geometries_in_pvr_screen.o t_pvr_ray_startpoints.o t_pvr_image_array.o t_pvr_stencil_buffer.o t_pvr_field_data.o t_control_params_stereo_pvr.o t_mesh_SR.o generate_vr_image.o + $(F90) -c $(F90OPTFLAGS) $< +t_rotation_pvr_images.o: $(PVR_DIR)/t_rotation_pvr_images.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o t_pvr_image_array.o t_control_params_4_pvr.o + $(F90) -c $(F90OPTFLAGS) $< +t_sort_PVRs_by_type.o: $(PVR_DIR)/t_sort_PVRs_by_type.f90 m_precision.o m_constants.o t_control_data_4_pvr.o cal_minmax_and_stacks.o + $(F90) -c $(F90OPTFLAGS) $< +t_stencil_buffer_work.o: $(PVR_DIR)/t_stencil_buffer_work.f90 m_precision.o m_constants.o m_machine_parameter.o calypso_mpi.o calypso_mpi_int8.o t_pvr_ray_startpoints.o transfer_to_long_integers.o calypso_mpi_int.o + $(F90) -c $(F90OPTFLAGS) $< +t_surf_grp_4_pvr_domain.o: $(PVR_DIR)/t_surf_grp_4_pvr_domain.f90 m_precision.o m_constants.o + $(F90) -c $(F90OPTFLAGS) $< +t_volume_rendering.o: $(PVR_DIR)/t_volume_rendering.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o m_work_time.o t_mesh_data.o t_phys_data.o t_jacobians.o t_surf_grp_list_each_surf.o t_rendering_vr_image.o t_control_params_4_pvr.o t_surf_grp_4_pvr_domain.o t_pvr_ray_startpoints.o t_pvr_image_array.o t_pvr_field_data.o t_geometries_in_pvr_screen.o t_control_data_pvrs.o t_sort_PVRs_by_type.o each_volume_rendering.o t_particle_trace.o t_fieldline.o t_control_data_pvr_sections.o set_pvr_control.o rendering_and_image_nums.o calypso_mpi_int.o bcast_control_data_4_pvr.o ctl_file_each_pvr_IO.o skip_comment_f.o t_read_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< +viz4_step_ctls_to_time_ctl.o: $(PVR_DIR)/viz4_step_ctls_to_time_ctl.f90 m_precision.o m_constants.o t_control_data_viz4.o t_ctl_data_4_time_steps.o t_control_array_real.o t_control_array_character.o t_control_array_integer.o + $(F90) -c $(F90OPTFLAGS) $< +volume_rendering.o: $(PVR_DIR)/volume_rendering.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o m_work_time.o t_mesh_data.o t_phys_data.o t_jacobians.o t_volume_rendering.o t_surf_grp_list_each_surf.o t_rendering_vr_image.o t_control_params_4_pvr.o t_surf_grp_4_pvr_domain.o t_pvr_ray_startpoints.o t_pvr_image_array.o t_pvr_field_data.o t_geometries_in_pvr_screen.o t_control_data_pvrs.o t_particle_trace.o t_fieldline.o t_mesh_SR.o t_control_data_pvr_sections.o set_pvr_control.o multi_volume_renderings.o anaglyph_volume_renderings.o cal_pvr_modelview_mat.o write_multi_PVR_image.o + $(F90) -c $(F90OPTFLAGS) $< +write_PVR_image.o: $(PVR_DIR)/write_PVR_image.f90 m_precision.o m_work_time.o calypso_mpi.o m_constants.o m_machine_parameter.o t_MPI_quilt_bitmap_IO.o t_pvr_image_array.o t_control_params_4_pvr.o output_image_sel_4_png.o set_parallel_file_name.o convert_real_rgb_2_bite.o mpi_write_quilt_BMP_file.o + $(F90) -c $(F90OPTFLAGS) $< +write_multi_PVR_image.o: $(PVR_DIR)/write_multi_PVR_image.f90 m_precision.o calypso_mpi.o m_constants.o m_machine_parameter.o m_geometry_constants.o t_pvr_image_array.o t_rendering_vr_image.o write_PVR_image.o + $(F90) -c $(F90OPTFLAGS) $< + diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/anaglyph_volume_renderings.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/anaglyph_volume_renderings.f90 new file mode 100644 index 00000000..bd04bfd9 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/anaglyph_volume_renderings.f90 @@ -0,0 +1,211 @@ +!>@file anaglyph_volume_renderings.f90 +!!@brief module anaglyph_volume_renderings +!! +!!@date Programmed by H.Matsui in May. 2006 +!! Modified by H.Matsui in May, 2021 +! +!>@brief Main routines for volume renderings +!! +!!@verbatim +!! subroutine PVR_anaglyph_view_and_images(num_pvr, num_pvr_images,& +!! & elps_PVR, mesh, PVR_sort, pvr_rgb, pvr_param, & +!! & pvr_bound, pvr_proj, m_SR) +!! integer(kind = kint), intent(in) :: num_pvr, num_pvr_images +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(mesh_geometry), intent(in) :: mesh +!! type(sort_PVRs_by_type), intent(in) :: PVR_sort +!! type(pvr_image_type), intent(in) :: pvr_rgb(num_pvr_images) +!! type(PVR_control_params), intent(in) :: pvr_param(num_pvr) +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound(num_pvr) +!! type(PVR_projection_data), intent(inout) & +!! & :: pvr_proj(num_pvr_images) +!! type(mesh_SR), intent(inout) :: m_SR +!! +!! subroutine PVR_anaglyph_rendering(istep_pvr, time, elps_PVR, & +!! & geofem, jacs, nod_fld, & +!! & tracer, fline, pvr, m_SR) +!! integer(kind = kint), intent(in) :: istep_pvr +!! real(kind = kreal), intent(in) :: time +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(mesh_data), intent(in) :: geofem +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(jacobians_type), intent(in) :: jacs +!! type(volume_rendering_module), intent(inout) :: pvr +!! type(mesh_SR), intent(inout) :: m_SR +!! +!! subroutine PVR_movie_anaglyph_visualize & +!! & (istep_pvr, time, elps_PVR, geofem, jacs, & +!! & nod_fld, tracer, fline, pvr, m_SR) +!! integer(kind = kint), intent(in) :: istep_pvr +!! real(kind = kreal), intent(in) :: time +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(mesh_data), intent(in) :: geofem +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(jacobians_type), intent(in) :: jacs +!! type(volume_rendering_module), intent(inout) :: pvr +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module anaglyph_volume_renderings +! + use m_precision + use calypso_mpi +! + use m_constants + use m_machine_parameter + use m_geometry_constants + use m_work_time +! + use t_mesh_data + use t_phys_data + use t_jacobians + use t_particle_trace + use t_fieldline +! + use t_volume_rendering + use t_surf_grp_list_each_surf + use t_rendering_vr_image + use t_control_params_4_pvr + use t_surf_grp_4_pvr_domain + use t_pvr_ray_startpoints + use t_pvr_image_array + use t_pvr_field_data + use t_geometries_in_pvr_screen + use t_control_data_pvrs + use t_mesh_SR +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine PVR_anaglyph_view_and_images(num_pvr, num_pvr_images, & + & elps_PVR, mesh, PVR_sort, pvr_rgb, pvr_param, & + & pvr_bound, pvr_proj, m_SR) +! + use set_PVR_view_and_image +! + integer(kind = kint), intent(in) :: num_pvr, num_pvr_images + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(sort_PVRs_by_type), intent(in) :: PVR_sort + type(pvr_image_type), intent(in) :: pvr_rgb(num_pvr_images) + type(PVR_control_params), intent(in) :: pvr_param(num_pvr) +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound(num_pvr) + type(PVR_projection_data), intent(inout) & + & :: pvr_proj(num_pvr_images) + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_pvr, ist_pvr, ied_pvr, ist_img +! +! Anaglyph with fixed view + ist_pvr = PVR_sort%istack_PVR_modes(4) + 1 + ied_pvr = PVR_sort%istack_PVR_modes(5) + do i_pvr = ist_pvr, ied_pvr + ist_img = PVR_sort%istack_pvr_images(i_pvr-1) + call anaglyph_PVR_view_matrices & + & (elps_PVR, mesh, pvr_rgb(ist_img+1), pvr_param(i_pvr), & + & pvr_bound(i_pvr), pvr_proj(ist_img+1), m_SR) + end do +! + end subroutine PVR_anaglyph_view_and_images +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine PVR_anaglyph_rendering(istep_pvr, time, elps_PVR, & + & geofem, jacs, nod_fld, & + & tracer, fline, pvr, m_SR) +! + use each_volume_rendering + use each_anaglyph_PVR + use write_multi_PVR_image +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs +! + type(volume_rendering_module), intent(inout) :: pvr + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_pvr, ist_pvr, ied_pvr, ist_img +! +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+1) + ist_pvr = pvr%PVR_sort%istack_PVR_modes(4) + 1 + ied_pvr = pvr%PVR_sort%istack_PVR_modes(5) + do i_pvr = ist_pvr, ied_pvr + ist_img = pvr%PVR_sort%istack_pvr_images(i_pvr-1) + call each_PVR_anaglyph(istep_pvr, time, elps_PVR, & + & geofem%mesh, geofem%group, jacs, nod_fld, tracer, fline, & + & pvr%sf_grp_4_sf, pvr%field_pvr(i_pvr), pvr%pvr_param(i_pvr), & + & pvr%pvr_proj(ist_img+1), pvr%pvr_rgb(ist_img+1), & + & m_SR%SR_sig, m_SR%SR_r) + end do + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+1) +! +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+2) + call output_PVR_images(istep_pvr, pvr%num_pvr, ist_pvr, ied_pvr, & + & pvr%num_pvr_images, pvr%PVR_sort%istack_pvr_images, & + & pvr%pvr_rgb) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+2) +! + end subroutine PVR_anaglyph_rendering +! +! --------------------------------------------------------------------- +! + subroutine PVR_movie_anaglyph_visualize & + & (istep_pvr, time, elps_PVR, geofem, jacs, & + & nod_fld, tracer, fline, pvr, m_SR) +! + use each_anaglyph_PVR +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs +! + type(volume_rendering_module), intent(inout) :: pvr + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_pvr, ist_pvr, ied_pvr, ist_img +! +! + ist_pvr = pvr%PVR_sort%istack_PVR_modes(5) + 1 + ied_pvr = pvr%PVR_sort%istack_PVR_modes(6) + do i_pvr = ist_pvr, ied_pvr + ist_img = pvr%PVR_sort%istack_pvr_images(i_pvr-1) + call anaglyph_rendering_w_rotation(istep_pvr, time, elps_PVR, & + & geofem%mesh, geofem%group, jacs, nod_fld, tracer, fline, & + & pvr%sf_grp_4_sf, pvr%field_pvr(i_pvr), pvr%pvr_param(i_pvr), & + & pvr%pvr_bound(i_pvr), pvr%pvr_proj(ist_img+1), & + & pvr%pvr_rgb(ist_img+1), m_SR%SR_sig, m_SR%SR_r, m_SR%SR_i) + end do +! + end subroutine PVR_movie_anaglyph_visualize +! +! --------------------------------------------------------------------- +! + end module anaglyph_volume_renderings diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_control_data_4_pvr.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_control_data_4_pvr.f90 new file mode 100644 index 00000000..84db7e64 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_control_data_4_pvr.f90 @@ -0,0 +1,102 @@ +!>@file bcast_control_data_4_pvr.f90 +!!@brief module bcast_control_data_4_pvr +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for parallel volume rendering +!! +!!@verbatim +!! subroutine bcast_vr_psf_ctl(pvr) +!! type(pvr_parameter_ctl), intent(inout) :: pvr +!!@end verbatim +! +! + module bcast_control_data_4_pvr +! + use m_precision + use calypso_mpi +! + use t_control_data_4_pvr +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine bcast_vr_psf_ctl(pvr) +! + use calypso_mpi_int + use calypso_mpi_char + use bcast_control_arrays + use bcast_pvr_color_ctl + use bcast_ctl_data_view_trans + use bcast_ctl_data_pvr_surfaces + use transfer_to_long_integers +! + type(pvr_parameter_ctl), intent(inout) :: pvr +! +! + call calypso_mpi_bcast_one_int(pvr%i_pvr_ctl, 0) + call calypso_mpi_bcast_character(pvr%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_character(pvr%fname_mat_ctl, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_character(pvr%fname_cmap_cbar_c, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_character(pvr%fname_pvr_light_c, & + & cast_long(kchara), 0) +! +! + call bcast_view_transfer_ctl(pvr%mat) +! + call bcast_pvr_isosurfs_ctl(pvr%pvr_isos_c) + call bcast_pvr_sections_ctl(pvr%pvr_scts_c) +! + call bcast_pvr_tracers_ctl(pvr%pvr_flines_c) + call bcast_pvr_tracers_ctl(pvr%pvr_tracers_c) +! + call bcast_lighting_ctl(pvr%light) + + call calypso_mpi_bcast_character(pvr%cmap_cbar_c%block_name, & + & cast_long(kchara), 0) + call bcast_pvr_colorbar_ctl(pvr%cmap_cbar_c%cbar_ctl) + call bcast_pvr_colordef_ctl(pvr%cmap_cbar_c%color) +! + call bcast_quilt_image_ctl(pvr%quilt_c) + call bcast_pvr_moving_view_ctl(pvr%movie) + call bcast_pvr_render_area_ctl(pvr%render_area_c) +! + call bcast_ctl_type_c1(pvr%updated_ctl) + call bcast_ctl_type_c1(pvr%file_head_ctl) + call bcast_ctl_type_c1(pvr%file_fmt_ctl ) + call bcast_ctl_type_c1(pvr%monitoring_ctl) +! + call bcast_ctl_type_c1(pvr%streo_ctl) + call bcast_ctl_type_c1(pvr%anaglyph_ctl) + call bcast_ctl_type_c1(pvr%quilt_ctl) +! + call bcast_ctl_type_c1(pvr%pvr_field_ctl) + call bcast_ctl_type_c1(pvr%pvr_comp_ctl) +! + end subroutine bcast_vr_psf_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_pvr_update_flag(pvr) +! + use bcast_control_arrays +! + type(pvr_parameter_ctl), intent(inout) :: pvr +! +! + call bcast_ctl_type_c1(pvr%updated_ctl) +! + end subroutine bcast_pvr_update_flag +! +! --------------------------------------------------------------------- +! + end module bcast_control_data_4_pvr diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_control_data_pvrs.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_control_data_pvrs.f90 new file mode 100644 index 00000000..4e132c29 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_control_data_pvrs.f90 @@ -0,0 +1,54 @@ +!>@file bcast_control_data_pvrs.f90 +!!@brief module bcast_control_data_pvrs +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +! +!>@brief structure of control data for multiple PVRs +!! +!!@verbatim +!! subroutine bcast_files_4_pvr_ctl(pvr_ctls) +!! type(volume_rendering_controls), intent(in) :: pvr_ctls +!!@endverbatim +! + module bcast_control_data_pvrs +! + use m_precision +! + use m_machine_parameter + use t_control_data_pvrs + use calypso_mpi +! + implicit none +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine bcast_files_4_pvr_ctl(pvr_ctls) +! + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers + use bcast_control_data_4_pvr +! + type(volume_rendering_controls), intent(inout) :: pvr_ctls +! +! + call calypso_mpi_bcast_character(pvr_ctls%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(pvr_ctls%num_pvr_ctl, 0) + if(pvr_ctls%num_pvr_ctl .le. 0) return +! + if(my_rank .gt. 0) call alloc_pvr_ctl_struct(pvr_ctls) +! + call calypso_mpi_bcast_character(pvr_ctls%fname_pvr_ctl, & + & cast_long(kchara*pvr_ctls%num_pvr_ctl), 0) +! + end subroutine bcast_files_4_pvr_ctl +! +! --------------------------------------------------------------------- +! + end module bcast_control_data_pvrs diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_ctl_data_pvr_surfaces.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_ctl_data_pvr_surfaces.f90 new file mode 100644 index 00000000..abc40fd6 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_ctl_data_pvr_surfaces.f90 @@ -0,0 +1,218 @@ +!>@file bcast_ctl_data_pvr_surfaces.f90 +!!@brief module bcast_ctl_data_pvr_surfaces +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for parallel volume rendering +!! +!!@verbatim +!! subroutine bcast_pvr_sections_ctl(pvr_scts_c) +!! type(pvr_sections_ctl), intent(inout) :: pvr_scts_c +!! subroutine bcast_pvr_isosurfs_ctl(pvr_isos_c) +!! type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_c +!! subroutine bcast_pvr_section_ctl(pvr_scts_c) +!! type(pvr_section_ctl), intent(inout) :: pvr_scts_c +!! subroutine bcast_pvr_tracers_ctl(pvr_trcs_c) +!! type(pvr_tracers_ctl), intent(inout) :: pvr_trcs_c +!!@endverbatim +! + module bcast_ctl_data_pvr_surfaces +! + use m_precision + use m_machine_parameter + use calypso_mpi +! + implicit none +! + private :: bcast_pvr_isosurface_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine bcast_pvr_sections_ctl(pvr_scts_c) +! + use t_control_data_pvr_sections + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(pvr_sections_ctl), intent(inout) :: pvr_scts_c +! + integer(kind = kint) :: i +! +! + call calypso_mpi_bcast_character & + & (pvr_scts_c%block_name, cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(pvr_scts_c%num_pvr_sect_ctl, 0) +! + if(pvr_scts_c%num_pvr_sect_ctl .gt. 0 .and. my_rank .gt. 0) then + allocate(pvr_scts_c%pvr_sect_ctl(pvr_scts_c%num_pvr_sect_ctl)) + end if +! + do i = 1, pvr_scts_c%num_pvr_sect_ctl + call bcast_pvr_section_ctl(pvr_scts_c%pvr_sect_ctl(i)) + end do +! + end subroutine bcast_pvr_sections_ctl +! +! ----------------------------------------------------------------------- +! + subroutine bcast_pvr_isosurfs_ctl(pvr_isos_c) +! + use t_control_data_pvr_isosurfs + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_c +! + integer(kind = kint) :: i +! +! + call calypso_mpi_bcast_one_int(pvr_isos_c%num_pvr_iso_ctl, 0) + call calypso_mpi_bcast_character & + & (pvr_isos_c%block_name, cast_long(kchara), 0) +! + if(pvr_isos_c%num_pvr_iso_ctl .gt. 0 .and. my_rank .gt. 0) then + call alloc_pvr_isosurfs_ctl(pvr_isos_c) + end if + call calypso_mpi_barrier +! + do i = 1, pvr_isos_c%num_pvr_iso_ctl + call bcast_pvr_isosurface_ctl(pvr_isos_c%pvr_iso_ctl(i)) + end do +! +! write(*,*) my_rank, 'pvr_isos_c%num_pvr_iso_ctl', & +! & pvr_isos_c%num_pvr_iso_ctl +! do i = 1, pvr_isos_c%num_pvr_iso_ctl +! write(*,*) my_rank, & +! & 'pvr_isos_c%pvr_iso_ctl(i)%iso_value_ctl%realvalue', & +! & i, pvr_isos_c%pvr_iso_ctl(i)%iso_value_ctl%iflag, & +! & pvr_isos_c%pvr_iso_ctl(i)%iso_value_ctl%realvalue +! write(*,*) my_rank, & +! & 'pvr_isos_c%pvr_iso_ctl(i)%opacity_ctl%realvalue', & +! & i, pvr_isos_c%pvr_iso_ctl(i)%opacity_ctl%iflag, & +! & pvr_isos_c%pvr_iso_ctl(i)%opacity_ctl%realvalue +! write(*,*) my_rank, & +! & 'pvr_isos_c%pvr_iso_ctl(i)%isosurf_type_ctl%realvalue', & +! & i, pvr_isos_c%pvr_iso_ctl(i)%isosurf_type_ctl%iflag, & +! & pvr_isos_c%pvr_iso_ctl(i)%isosurf_type_ctl%charavalue +! end do +! + end subroutine bcast_pvr_isosurfs_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_pvr_tracers_ctl(pvr_trcs_c) +! + use t_control_data_pvr_tracers + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(pvr_tracers_ctl), intent(inout) :: pvr_trcs_c +! + integer(kind = kint) :: i +! +! + call calypso_mpi_bcast_one_int(pvr_trcs_c%num_pvr_tracer_ctl, 0) + call calypso_mpi_bcast_character & + & (pvr_trcs_c%block_name, cast_long(kchara), 0) +! + if(pvr_trcs_c%num_pvr_tracer_ctl .gt. 0 .and. my_rank.gt.0) then + call alloc_pvr_tracers_ctl(pvr_trcs_c) + end if + call calypso_mpi_barrier +! + do i = 1, pvr_trcs_c%num_pvr_tracer_ctl + call bcast_pvr_tracer_ctl(pvr_trcs_c%pvr_trc_c(i)) + end do +! + end subroutine bcast_pvr_tracers_ctl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine bcast_pvr_section_ctl(pvr_sct_c) +! + use t_ctl_data_pvr_section + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers + use bcast_control_arrays + use bcast_section_control_data +! + type(pvr_section_ctl), intent(inout) :: pvr_sct_c +! +! + call calypso_mpi_bcast_one_int(pvr_sct_c%i_pvr_sect_ctl, 0) + call calypso_mpi_bcast_character & + & (pvr_sct_c%block_name, cast_long(kchara), 0) + call calypso_mpi_bcast_character & + & (pvr_sct_c%fname_sect_ctl, cast_long(kchara), 0) +! + call bcast_section_def_control(pvr_sct_c%psf_def_c) + call bcast_ctl_type_r1(pvr_sct_c%opacity_ctl) + call bcast_ctl_type_c1(pvr_sct_c%zeroline_switch_ctl) +! + end subroutine bcast_pvr_section_ctl +! +! ----------------------------------------------------------------------- +! + subroutine bcast_pvr_isosurface_ctl(pvr_iso_ctl) +! + use t_ctl_data_pvr_isosurface + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers + use bcast_control_arrays +! + type(pvr_isosurf_ctl), intent(inout) :: pvr_iso_ctl +! +! + call calypso_mpi_bcast_one_int(pvr_iso_ctl%i_pvr_isosurf_ctl, 0) + call calypso_mpi_bcast_character & + & (pvr_iso_ctl%block_name, cast_long(kchara), 0) +! + call bcast_ctl_type_c1(pvr_iso_ctl%isosurf_type_ctl) + call bcast_ctl_type_r1(pvr_iso_ctl%iso_value_ctl) + call bcast_ctl_type_r1(pvr_iso_ctl%opacity_ctl) +! + end subroutine bcast_pvr_isosurface_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_pvr_tracer_ctl(pvr_tracer_c) +! + use t_ctl_data_pvr_tracer + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers + use bcast_control_arrays +! + type(pvr_tracer_ctl), intent(inout) :: pvr_tracer_c +! +! + call calypso_mpi_bcast_one_int(pvr_tracer_c%i_pvr_tracer_ctl, 0) + call calypso_mpi_bcast_character & + & (pvr_tracer_c%block_name, cast_long(kchara), 0) +! + call bcast_ctl_type_c1(pvr_tracer_c%tracer_file_prefix) + call bcast_ctl_type_i1(pvr_tracer_c%render_increment_ctl) + call bcast_ctl_type_r1(pvr_tracer_c%render_radius_ctl) + call bcast_ctl_type_c1(pvr_tracer_c%color_mode_ctl) + call bcast_ctl_type_r3(pvr_tracer_c%rgb_color_ctl) + call bcast_ctl_type_r1(pvr_tracer_c%opacity_ctl) +! + end subroutine bcast_pvr_tracer_ctl +! +! --------------------------------------------------------------------- +! + end module bcast_ctl_data_pvr_surfaces diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_ctl_data_view_trans.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_ctl_data_view_trans.f90 new file mode 100644 index 00000000..a027a741 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_ctl_data_view_trans.f90 @@ -0,0 +1,251 @@ +!>@file bcast_ctl_data_view_trans.f90 +!!@brief module bcast_ctl_data_view_trans +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief Control inputs for PVR projection and streo parameter +!! +!!@verbatim +!! subroutine bcast_pvr_moving_view_ctl(movie) +!! type(pvr_movie_ctl), intent(inout) :: movie +!! subroutine bcast_quilt_image_ctl(quilt_c) +!! type(quilt_image_ctl), intent(inout) :: quilt_c +!! subroutine bcast_mul_view_trans_ctl(mul_mats_c) +!! type(multi_modelview_ctl), intent(inout) :: mul_mats_c +!! subroutine bcast_view_transfer_ctl(mat) +!! type(modeview_ctl), intent(inout) :: mat +!! +!! subroutine bcast_image_size_ctl(pixel) +!! type(screen_pixel_ctl), intent(inout) :: pixel +!! subroutine bcast_projection_mat_ctl(proj) +!! type(projection_ctl), intent(inout) :: proj +!! subroutine bcast_stereo_view_ctl(streo) +!! type(streo_view_ctl), intent(inout) :: streo +!!@endverbatim +!! +! + module bcast_ctl_data_view_trans +! + use m_precision + use calypso_mpi +! + use m_constants + use m_machine_parameter +! + implicit none +! + private :: bcast_projection_mat_ctl, bcast_image_size_ctl + private :: bcast_stereo_view_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine bcast_pvr_moving_view_ctl(movie) +! + use t_ctl_data_pvr_movie + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers + use bcast_control_arrays +! + type(pvr_movie_ctl), intent(inout) :: movie +! +! + call calypso_mpi_bcast_one_int(movie%i_pvr_rotation, 0) + call calypso_mpi_bcast_character(movie%block_name, & + & cast_long(kchara), 0) +! + call bcast_ctl_type_c1(movie%movie_mode_ctl) + call bcast_ctl_type_i1(movie%num_frames_ctl) + call bcast_ctl_type_c1(movie%rotation_axis_ctl) +! + call bcast_ctl_type_r2(movie%angle_range_ctl) + call bcast_ctl_type_r2(movie%apature_range_ctl) + call bcast_ctl_type_r2(movie%LIC_kernel_peak_range_ctl) +! + call calypso_mpi_bcast_character(movie%fname_view_start_ctl, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_character(movie%fname_view_end_ctl, & + & cast_long(kchara), 0) + call bcast_view_transfer_ctl(movie%view_start_ctl) + call bcast_view_transfer_ctl(movie%view_end_ctl) +! + call bcast_mul_view_trans_ctl(movie%mul_mmats_c) +! + end subroutine bcast_pvr_moving_view_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_quilt_image_ctl(quilt_c) +! + use t_ctl_data_quilt_image + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers + use bcast_control_arrays +! + type(quilt_image_ctl), intent(inout) :: quilt_c +! +! + call calypso_mpi_bcast_one_int(quilt_c%i_quilt_image, 0) + call calypso_mpi_bcast_character(quilt_c%block_name, & + & cast_long(kchara), 0) +! + call bcast_ctl_type_i2(quilt_c%num_column_row_ctl) + call bcast_ctl_type_i2(quilt_c%num_row_column_ctl) +! + call bcast_mul_view_trans_ctl(quilt_c%mul_qmats_c) +! + end subroutine bcast_quilt_image_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_mul_view_trans_ctl(mul_mats_c) +! + use t_ctl_data_view_transfers + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(multi_modelview_ctl), intent(inout) :: mul_mats_c +! + integer(kind = kint) :: i, num +! +! + call calypso_mpi_bcast_one_int(mul_mats_c%num_modelviews_c, 0) + call calypso_mpi_bcast_character(mul_mats_c%block_name, & + & cast_long(kchara), 0) +! + if(mul_mats_c%num_modelviews_c .gt. 0 .and. my_rank .gt. 0) then + num = mul_mats_c%num_modelviews_c + call alloc_multi_modeview_ctl(mul_mats_c) + end if +! + call calypso_mpi_bcast_character(mul_mats_c%fname_mat_ctl, & + & cast_long(kchara*mul_mats_c%num_modelviews_c), 0) + do i = 1, mul_mats_c%num_modelviews_c + call bcast_view_transfer_ctl(mul_mats_c%matrices(i)) + end do +! + end subroutine bcast_mul_view_trans_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_view_transfer_ctl(mat) +! + use t_ctl_data_4_view_transfer + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(modeview_ctl), intent(inout) :: mat +! +! + call calypso_mpi_bcast_character(mat%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(mat%i_view_transform, 0) +! + call bcast_ctl_array_cr(mat%lookpoint_ctl) + call bcast_ctl_array_cr(mat%viewpoint_ctl) + call bcast_ctl_array_cr(mat%up_dir_ctl) +! + call bcast_ctl_array_cr(mat%view_rot_vec_ctl) + call bcast_ctl_array_cr(mat%scale_vector_ctl) + call bcast_ctl_array_cr(mat%viewpt_in_viewer_ctl) +! + call bcast_ctl_array_c2r(mat%modelview_mat_ctl) +! + call bcast_ctl_type_r1(mat%view_rotation_deg_ctl) + call bcast_ctl_type_r1(mat%scale_factor_ctl) + call bcast_ctl_type_c1(mat%projection_type_ctl) +! +! + call bcast_projection_mat_ctl(mat%proj) + call bcast_image_size_ctl(mat%pixel) + call bcast_stereo_view_ctl(mat%streo) +! + end subroutine bcast_view_transfer_ctl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine bcast_image_size_ctl(pixel) +! + use t_ctl_data_4_screen_pixel + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(screen_pixel_ctl), intent(inout) :: pixel +! +! + call calypso_mpi_bcast_character(pixel%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(pixel%i_image_size, 0) +! + call bcast_ctl_type_i1(pixel%num_xpixel_ctl) + call bcast_ctl_type_i1(pixel%num_ypixel_ctl) +! + end subroutine bcast_image_size_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_projection_mat_ctl(proj) +! + use t_ctl_data_4_projection + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(projection_ctl), intent(inout) :: proj +! +! + call calypso_mpi_bcast_character(proj%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(proj%i_project_mat, 0) +! + call bcast_ctl_type_r1(proj%perspective_angle_ctl) + call bcast_ctl_type_r1(proj%perspective_xy_ratio_ctl) + call bcast_ctl_type_r1(proj%perspective_near_ctl) + call bcast_ctl_type_r1(proj%perspective_far_ctl) +! + call bcast_ctl_type_r2(proj%horizontal_range_ctl) + call bcast_ctl_type_r2(proj%vertical_range_ctl) +! + end subroutine bcast_projection_mat_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_stereo_view_ctl(streo) +! + use t_ctl_data_4_streo_view + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(streo_view_ctl), intent(inout) :: streo +! +! + call calypso_mpi_bcast_character(streo%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(streo%i_stereo_view, 0) +! + call bcast_ctl_type_r1(streo%focalpoint_ctl) + call bcast_ctl_type_r1(streo%eye_separation_ctl) + call bcast_ctl_type_r1(streo%eye_sep_angle_ctl) + call bcast_ctl_type_c1(streo%step_eye_sep_angle_ctl) +! + end subroutine bcast_stereo_view_ctl +! +! --------------------------------------------------------------------- +! + end module bcast_ctl_data_view_trans diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_ctl_data_viz4.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_ctl_data_viz4.f90 new file mode 100644 index 00000000..24e8aa16 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_ctl_data_viz4.f90 @@ -0,0 +1,76 @@ +!>@file bcast_ctl_data_viz4.f90 +!!@brief module bcast_ctl_data_viz4 +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +!! +!>@brief Control data for four visualizations +!! +!!@verbatim +!! subroutine bcast_viz4_controls(viz4_ctls) +!! type(vis4_controls), intent(inout) :: viz4_ctls +!!@endverbatim +! + module bcast_ctl_data_viz4 +! + use m_precision + use m_machine_parameter + use calypso_mpi_int +! + implicit none +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine bcast_viz4_controls(viz4_ctls) +! + use t_control_data_viz4 + use calypso_mpi_int + use calypso_mpi_char + use bcast_control_arrays + use bcast_section_control_data + use bcast_maps_control_data + use bcast_ctl_data_field_line + use bcast_control_data_pvrs + use transfer_to_long_integers +! + type(vis4_controls), intent(inout) :: viz4_ctls +! +! + call bcast_files_4_psf_ctl(viz4_ctls%psf_ctls) + call bcast_files_4_iso_ctl(viz4_ctls%iso_ctls) + call bcast_files_4_map_ctl(viz4_ctls%map_ctls) +! + call bcast_files_4_pvr_ctl(viz4_ctls%pvr_ctls) + call bcast_files_4_fline_ctl(viz4_ctls%fline_ctls) +! + call bcast_ctl_type_r1(viz4_ctls%delta_t_psf_v_ctl) + call bcast_ctl_type_r1(viz4_ctls%delta_t_iso_v_ctl) + call bcast_ctl_type_r1(viz4_ctls%delta_t_map_v_ctl) +! + call bcast_ctl_type_r1(viz4_ctls%delta_t_pvr_v_ctl) + call bcast_ctl_type_r1(viz4_ctls%delta_t_fline_v_ctl) + call bcast_ctl_type_r1(viz4_ctls%delta_t_ucd_v_ctl) +! + call bcast_ctl_type_i1(viz4_ctls%i_step_psf_v_ctl) + call bcast_ctl_type_i1(viz4_ctls%i_step_iso_v_ctl) + call bcast_ctl_type_i1(viz4_ctls%i_step_map_v_ctl) +! + call bcast_ctl_type_i1(viz4_ctls%i_step_pvr_v_ctl) + call bcast_ctl_type_i1(viz4_ctls%i_step_fline_v_ctl) + call bcast_ctl_type_i1(viz4_ctls%i_step_ucd_v_ctl) +! + call bcast_ctl_type_c1(viz4_ctls%output_field_file_fmt_ctl) +! + call calypso_mpi_bcast_character & + & (viz4_ctls%block_name, cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(viz4_ctls%i_viz_control, 0) +! + end subroutine bcast_viz4_controls +! +! -------------------------------------------------------------------- +! + end module bcast_ctl_data_viz4 diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_pvr_color_ctl.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_pvr_color_ctl.f90 new file mode 100644 index 00000000..1606340c --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/bcast_pvr_color_ctl.f90 @@ -0,0 +1,153 @@ +!>@file bcast_pvr_color_ctl.f90 +!!@brief module bcast_pvr_color_ctl +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief colormap control data for parallel volume rendering +!! +!!@verbatim +!! subroutine bcast_pvr_colordef_ctl(color) +!! type(pvr_colormap_ctl), intent(inout) :: color +!! subroutine bcast_lighting_ctl(light) +!! type(pvr_light_ctl), intent(in) :: light +!! subroutine bcast_pvr_colorbar_ctl(cbar_ctl) +!! type(pvr_colorbar_ctl), intent(inout) :: cbar_ctl +!! +!! subroutine bcast_pvr_render_area_ctl(render_area_c) +!! type(pvr_render_area_ctl), intent(inout) :: render_area_c +!!@endverbatim +! + module bcast_pvr_color_ctl +! + use m_precision + use m_machine_parameter + use calypso_mpi +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine bcast_pvr_colordef_ctl(color) +! + use t_ctl_data_pvr_colormap + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(pvr_colormap_ctl), intent(inout) :: color +! +! + call calypso_mpi_bcast_character(color%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(color%i_pvr_colordef, 0) +! + call bcast_ctl_array_r2(color%colortbl_ctl) + call bcast_ctl_array_r2(color%linear_opacity_ctl) +! + call bcast_ctl_type_c1(color%lic_color_fld_ctl) + call bcast_ctl_type_c1(color%lic_color_comp_ctl) + call bcast_ctl_type_c1(color%lic_opacity_fld_ctl) + call bcast_ctl_type_c1(color%lic_opacity_comp_ctl) +! + call bcast_ctl_type_c1(color%colormap_mode_ctl) + call bcast_ctl_type_c1(color%data_mapping_ctl) + call bcast_ctl_type_c1(color%opacity_style_ctl) +! + call bcast_ctl_type_r1(color%range_min_ctl) + call bcast_ctl_type_r1(color%range_max_ctl) + call bcast_ctl_type_r1(color%fix_opacity_ctl) + call bcast_ctl_type_r3(color%background_color_ctl) +! + end subroutine bcast_pvr_colordef_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_lighting_ctl(light) +! + use t_ctl_data_pvr_light + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(pvr_light_ctl), intent(inout) :: light +! +! + call calypso_mpi_bcast_character(light%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(light%i_pvr_lighting, 0) +! + call bcast_ctl_array_r3(light%light_position_ctl) + call bcast_ctl_array_r3(light%light_sph_posi_ctl) +! + call bcast_ctl_type_r1(light%ambient_coef_ctl ) + call bcast_ctl_type_r1(light%diffuse_coef_ctl ) + call bcast_ctl_type_r1(light%specular_coef_ctl) +! + end subroutine bcast_lighting_ctl +! +! --------------------------------------------------------------------- +! + subroutine bcast_pvr_colorbar_ctl(cbar_ctl) +! + use t_ctl_data_pvr_colorbar + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(pvr_colorbar_ctl), intent(inout) :: cbar_ctl +! +! + call calypso_mpi_bcast_character(cbar_ctl%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(cbar_ctl%i_pvr_colorbar, 0) +! + call bcast_ctl_type_i1(cbar_ctl%font_size_ctl) + call bcast_ctl_type_i1(cbar_ctl%ngrid_cbar_ctl) +! + call bcast_ctl_type_c1(cbar_ctl%colorbar_switch_ctl) + call bcast_ctl_type_c1(cbar_ctl%colorbar_scale_ctl) + call bcast_ctl_type_c1(cbar_ctl%colorbar_position_ctl) + call bcast_ctl_type_c1(cbar_ctl%zeromarker_flag_ctl) +! + call bcast_ctl_type_c1(cbar_ctl%axis_switch_ctl) + call bcast_ctl_type_c1(cbar_ctl%time_switch_ctl) + call bcast_ctl_type_c1(cbar_ctl%mapgrid_switch_ctl) +! + call bcast_ctl_type_r2(cbar_ctl%cbar_range_ctl) +! + end subroutine bcast_pvr_colorbar_ctl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine bcast_pvr_render_area_ctl(render_area_c) +! + use t_ctl_data_pvr_area + use bcast_control_arrays + use calypso_mpi_int + use calypso_mpi_char + use transfer_to_long_integers +! + type(pvr_render_area_ctl), intent(inout) :: render_area_c +! +! + call calypso_mpi_bcast_character(render_area_c%block_name, & + & cast_long(kchara), 0) + call calypso_mpi_bcast_one_int(render_area_c%i_plot_area, 0) +! + call bcast_ctl_array_c1(render_area_c%pvr_area_ctl) + call bcast_ctl_array_c2r(render_area_c%surf_enhanse_ctl) +! + end subroutine bcast_pvr_render_area_ctl +! +! --------------------------------------------------------------------- +! + end module bcast_pvr_color_ctl diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/cal_pvr_modelview_mat.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/cal_pvr_modelview_mat.f90 new file mode 100644 index 00000000..ef04bcae --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/cal_pvr_modelview_mat.f90 @@ -0,0 +1,277 @@ +!>@file cal_pvr_modelview_mat.f90 +!! module cal_pvr_modelview_mat +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!> @brief Get model view matrix for PVR +!! +!!@verbatim +!! subroutine cal_pvr_modelview_matrix(i_stereo, i_rot, & +!! & outline, movie_def, stereo_def, view_param, & +!! & viewpoint_vec, modelview_mat) +!! type(pvr_domain_outline), intent(in) :: outline +!! type(pvr_movie_parameter), intent(in) :: movie_def +!! type(pvr_view_parameter), intent(in) :: view_param +!! real(kind = kreal), intent(inout) :: modelview_mat(4,4) +!! real(kind = kreal), intent(inout) :: viewpoint_vec(3) +!!@endverbatim +! + module cal_pvr_modelview_mat +! + use m_precision +! + use m_constants + use m_machine_parameter + use t_control_params_4_pvr + use t_geometries_in_pvr_screen + use t_control_params_stereo_pvr +! + implicit none +! + private :: cal_modelview_mat_by_views + private :: update_rot_mat_from_viewpts +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine cal_pvr_modelview_matrix(i_stereo, i_rot, & + & outline, movie_def, stereo_def, view_param, & + & viewpoint_vec, modelview_mat) +! + use t_surf_grp_4_pvr_domain + use cal_inverse_small_matrix + use small_mat_mat_product +! + integer(kind = kint), intent(in) :: i_stereo, i_rot + type(pvr_domain_outline), intent(in) :: outline + type(pvr_movie_parameter), intent(in) :: movie_def + type(pvr_stereo_parameter), intent(in) :: stereo_def + type(pvr_view_parameter), intent(in) :: view_param +! + real(kind = kreal), intent(inout) :: modelview_mat(4,4) + real(kind = kreal), intent(inout) :: viewpoint_vec(3) +! + integer(kind = kint) :: i, ierr2 + real(kind = kreal) :: vec_tmp(4) + real(kind = kreal) :: posi_zero(4) = (/zero,zero,zero,one/) +!> Inverse of modelview matrix + real(kind = kreal) :: modelview_inv(4,4) +! +! + call cal_modelview_mat_by_views(i_stereo, i_rot, & + & outline, movie_def, stereo_def, view_param, modelview_mat) +! + call cal_inverse_44_matrix(modelview_mat, & + & modelview_inv, ierr2) + call prod_mat44_vec3(modelview_inv, posi_zero(1), & + & vec_tmp(1)) + viewpoint_vec(1:3) = vec_tmp(1:3) +! +! if(my_rank .eq. 0) then + if (iflag_debug .gt. 0) then + write(*,*) 'modelview' + do i = 1, 4 + write(*,'(1p4e16.7)') modelview_mat(i,1:4) + end do +! + write(*,*) 'modelview_inv' + do i = 1, 4 + write(*,'(1p4e16.7)') modelview_inv(i,1:4) + end do +! + write(*,*) 'lookat_vec', view_param%lookat_vec(1:3) + write(*,*) 'scale_factor_pvr', & + & view_param%scale_factor_pvr(1:3) + write(*,*) 'viewpoint_vec', viewpoint_vec(1:3) + write(*,*) 'viewpt_in_view', & + & view_param%viewpt_in_viewer_pvr(1:3) + end if +! + end subroutine cal_pvr_modelview_matrix +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine cal_modelview_mat_by_views(i_stereo, i_rot, & + & outline, movie_def, stereo_def, view_param, & + & modelview_mat) +! + use t_surf_grp_4_pvr_domain + use transform_mat_operations + use small_mat_mat_product +! + integer(kind = kint), intent(in) :: i_stereo, i_rot + type(pvr_domain_outline), intent(in) :: outline + type(pvr_movie_parameter), intent(in) :: movie_def + type(pvr_stereo_parameter), intent(in) :: stereo_def + type(pvr_view_parameter), intent(in) :: view_param +! + real(kind = kreal), intent(inout) :: modelview_mat(4,4) +! + real(kind = kreal) :: rotation_mat(4,4), mat_tmp(4,4) + real(kind = kreal) :: rotation_axis(3), rev_lookat(3) + real(kind = kreal) :: rev_eye(3), streo_eye(3), scale(3) + real(kind = kreal) :: angle_deg +! +! + if(view_param%iflag_modelview_mat .gt. 0) then + modelview_mat(1:4,1:4) = view_param%modelview(1:4,1:4) + return + end if +! + if(view_param%iflag_lookpoint .eq. 0) then + rev_lookat(1:3) = - outline%center_g(1:3) + else + rev_lookat(1:3) = - view_param%lookat_vec(1:3) + end if +! + if(view_param%iflag_scale_fact .eq. 0) then + scale(1:3) = one + else + scale(1:3) = view_param%scale_factor_pvr(1:3) + end if +! + if(view_param%iflag_rotation .gt. 0) then + call Kemo_Unit(rotation_mat) + call Kemo_Rotate(rotation_mat, & + & view_param%rotation_pvr(1), view_param%rotation_pvr(2:4)) + else + mat_tmp(1:4,1:4) = modelview_mat(1:4,1:4) + call update_rot_mat_from_viewpts(view_param, rotation_mat) + end if +! + if(view_param%iflag_viewpt_in_view .eq. 0) then + call prod_mat44_vec3(rotation_mat, view_param%viewpoint, & + & rev_eye) + else + rev_eye(1:3) = - view_param%viewpt_in_viewer_pvr(1:3) + end if +! +! Start matrix construction + call Kemo_Unit(modelview_mat) + call Kemo_Translate(modelview_mat, rev_lookat) +! +! Change scale + call Kemo_Scale(modelview_mat, scale) +! +! Rotate by Movie + if(movie_def%iflag_movie_mode .eq. I_ROTATE_MOVIE & + & .and. i_rot .gt. 0) then + rotation_axis(1:3) = zero + rotation_axis(movie_def%id_rot_axis) = one + angle_deg = movie_def%angle_range(1) & + & + (movie_def%angle_range(2) - movie_def%angle_range(1)) & + & * dble(i_rot-1) / dble(movie_def%num_frame) + call Kemo_Rotate(modelview_mat, angle_deg, rotation_axis(1)) + end if +! +! Rotate for viewpoint + mat_tmp(1:4,1:4) = modelview_mat(1:4,1:4) + call cal_matmat44(modelview_mat, rotation_mat(1,1), mat_tmp(1,1)) +! +! Shift by viewpoint + call Kemo_Translate(modelview_mat, rev_eye) +! +! Shift for stereo view + if(stereo_def%flag_quilt .or. stereo_def%flag_anaglyph) then + streo_eye(1) = each_eye_from_middle(i_stereo, stereo_def) + streo_eye(2:3) = zero + call Kemo_Translate(modelview_mat, streo_eye) + end if +! + if (iflag_debug .gt. 0) then + write(*,*) 'viewpt_in_view', & + & view_param%viewpt_in_viewer_pvr(1:3) + end if +! + end subroutine cal_modelview_mat_by_views +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine update_rot_mat_from_viewpts(view_param, rotation_mat) +! + use mag_of_field_smp + use cal_products_smp + use transform_mat_operations +! + type(pvr_view_parameter), intent(in) :: view_param + real(kind = kreal), intent(inout) :: rotation_mat(4,4) +! + integer(kind = kint) :: i + real(kind = kreal) :: viewing_dir(3), u(3), v(3) + real(kind = kreal) :: look_norm(3), view_norm(3), up_norm(3) + real(kind = kreal) :: v_tmp(3) +! +! + v_tmp(1:3) = view_param%viewpoint(1:3) & + & - view_param%lookat_vec(1:3) + call cal_normalized_vector(v_tmp, viewing_dir) + call cal_normalized_vector(view_param%lookat_vec, look_norm) +! + v_tmp(1:3) = view_param%viewpoint(1:3) + call cal_normalized_vector(v_tmp, view_norm) + call cal_normalized_vector(view_param%up_direction_vec, up_norm) +! +! /* find the direction of axis U */ + call one_cross_product(up_norm, viewing_dir, v_tmp) + call cal_normalized_vector(v_tmp, u) +! +! /*find the direction of axix V */ + call one_cross_product(viewing_dir, u, v_tmp) + call cal_normalized_vector(v_tmp, v) +! + do i = 1, 3 + rotation_mat(1,i) = u(i) + rotation_mat(2,i) = v(i) + rotation_mat(3,i) = viewing_dir(i) + rotation_mat(4,i) = zero + end do + rotation_mat(1:3,4) = zero + rotation_mat(4,4) = one +! +! /* Flip matrix to Rotate the object */ + rotation_mat(1:4,1:4) = - rotation_mat(1:4,1:4) +! + end subroutine update_rot_mat_from_viewpts +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine cal_normalized_vector(d_fld, d_norm) +! + real(kind=kreal), intent(in) :: d_fld(3) + real(kind=kreal), intent(inout) :: d_norm(3) +! + real(kind = kreal) :: d_mag +! + d_mag = sqrt( d_fld(1)*d_fld(1) + d_fld(2)*d_fld(2) & + & + d_fld(3)*d_fld(3) ) + if(d_mag .le. zero) then + d_norm(1:3) = zero + else + d_norm(1:3) = d_fld(1:3) / d_mag + end if +! + end subroutine cal_normalized_vector +! +! ----------------------------------------------------------------------- +! + subroutine one_cross_product(vect1, vect2, prod) +! + real (kind=kreal), intent(in) :: vect1(3), vect2(3) + real (kind=kreal), intent(inout) :: prod(3) +! + prod(1) = (vect1(2)*vect2(3) - vect1(3)*vect2(2)) + prod(2) = (vect1(3)*vect2(1) - vect1(1)*vect2(3)) + prod(3) = (vect1(1)*vect2(2) - vect1(2)*vect2(1)) +! + end subroutine one_cross_product +! +! ---------------------------------------------------------------------- +! + end module cal_pvr_modelview_mat diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/cal_pvr_projection_mat.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/cal_pvr_projection_mat.f90 new file mode 100644 index 00000000..712256b8 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/cal_pvr_projection_mat.f90 @@ -0,0 +1,208 @@ +!>@file cal_pvr_projection_mat.f90 +!! module cal_pvr_projection_mat +!! +!!@author H. Matsui +!!@date Programmed in May. 2009 +! +!> @brief Evaluate projection matirx +!! +!!@verbatim +!! subroutine set_pvr_projection_matrix(view_param, projection_mat) +!! subroutine set_pvr_step_projection_mat & +!! & (i_img, view_param, stereo_def, projection_step) +!! subroutine set_pvr_projection_left_mat & +!! & (view_param, stereo_def, projection_left) +!! subroutine set_pvr_projection_right_mat & +!! & (view_param, stereo_def, projection_right) +!! type(pvr_view_parameter), intent(in) :: view_param +!! type(pvr_stereo_parameter), intent(in) :: stereo_def +!!@endverbatim +! + module cal_pvr_projection_mat +! + use m_precision +! + use m_constants + use m_machine_parameter + use t_control_params_4_pvr + use t_control_params_stereo_pvr +! + implicit none +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine set_pvr_projection_matrix(view_param, projection_mat) +! + use set_projection_matrix +! + type(pvr_view_parameter), intent(in) :: view_param + real(kind = kreal), intent(inout) :: projection_mat(4,4) +! + integer(kind = kint) :: i +! +! + call set_perspective_mat_by_angle(view_param%perspective_angle, & + & view_param%perspective_xy_ratio, view_param%perspective_near, & + & view_param%perspective_far, projection_mat) +! + if (iflag_debug .gt. 0) then + write(*,*) 'projection_mat for PVR ' + do i = 1, 4 + write(*,'(1p4e16.7)') projection_mat(i,1:4) + end do + end if +! + end subroutine set_pvr_projection_matrix +! +! ----------------------------------------------------------------------- +! + subroutine set_pvr_step_projection_mat & + & (i_img, view_param, stereo_def, projection_step) +! + use set_projection_matrix +! + integer(kind = kint), intent(in) :: i_img + type(pvr_view_parameter), intent(in) :: view_param + type(pvr_stereo_parameter), intent(in) :: stereo_def + real(kind = kreal), intent(inout) :: projection_step(4,4) +! + integer(kind = kint) :: i +! + real(kind = kreal) :: pi_180, wd2, ndfl, each_eye + real(kind = kreal) :: view_right, view_left + real(kind = kreal) :: view_top, view_bottom + real(kind = kreal) :: view_far, view_near +! +! + view_near = view_param%perspective_near + view_far = view_param%perspective_far +! + pi_180 = four * atan(one) / 180.0d0 + wd2 = view_near * tan(view_param%perspective_angle*pi_180*half) + ndfl = view_near / stereo_def%focalLength +! + each_eye = each_eye_from_middle(i_img, stereo_def) +! + view_bottom = - wd2 + view_top = wd2 + view_left = - view_param%perspective_xy_ratio * wd2 & + & + each_eye * ndfl + view_right = view_param%perspective_xy_ratio * wd2 & + & + each_eye * ndfl +! + call set_perspective_mat_by_area(view_left, view_right, & + & view_bottom, view_top, view_near, view_far, & + & projection_step) +! + if (iflag_debug .gt. 0) then + write(*,*) 'projection_step for PVR ', i_img + do i = 1, 4 + write(*,'(1p4e16.7)') projection_step(i,1:4) + end do + end if +! + end subroutine set_pvr_step_projection_mat +! +! ----------------------------------------------------------------------- +! + subroutine set_pvr_projection_left_mat & + & (view_param, stereo_def, projection_left) +! + use set_projection_matrix +! + type(pvr_view_parameter), intent(in) :: view_param + type(pvr_stereo_parameter), intent(in) :: stereo_def + real(kind = kreal), intent(inout) :: projection_left(4,4) +! + integer(kind = kint) :: i +! + real(kind = kreal) :: pi_180, wd2, ndfl, each_eye + real(kind = kreal) :: view_right, view_left + real(kind = kreal) :: view_top, view_bottom + real(kind = kreal) :: view_far, view_near +! +! + view_near = view_param%perspective_near + view_far = view_param%perspective_far +! + pi_180 = four * atan(one) / 180.0d0 + wd2 = view_near * tan(view_param%perspective_angle*pi_180*half) + ndfl = view_near / stereo_def%focalLength +! + each_eye = each_eye_from_middle(ione, stereo_def) +! + view_bottom = - wd2 + view_top = wd2 + view_left = - view_param%perspective_xy_ratio * wd2 & + & + each_eye * ndfl + view_right = view_param%perspective_xy_ratio * wd2 & + & + each_eye * ndfl +! + call set_perspective_mat_by_area(view_left, view_right, & + & view_bottom, view_top, view_near, view_far, & + & projection_left) +! + if (iflag_debug .gt. 0) then + write(*,*) 'projection_left for PVR ' + do i = 1, 4 + write(*,'(1p4e16.7)') projection_left(i,1:4) + end do + end if +! + end subroutine set_pvr_projection_left_mat +! +! ----------------------------------------------------------------------- +! + subroutine set_pvr_projection_right_mat & + & (view_param, stereo_def, projection_right) +! + use set_projection_matrix +! + type(pvr_view_parameter), intent(in) :: view_param + type(pvr_stereo_parameter), intent(in) :: stereo_def + real(kind = kreal), intent(inout) :: projection_right(4,4) +! + integer(kind = kint) :: i +! + real(kind = kreal) :: pi_180, wd2, ndfl, each_eye + real(kind = kreal) :: view_right, view_left + real(kind = kreal) :: view_top, view_bottom + real(kind = kreal) :: view_far, view_near +! +! + view_near = view_param%perspective_near + view_far = view_param%perspective_far +! + pi_180 = four * atan(one) / 180.0d0 + wd2 = view_near * tan(view_param%perspective_angle*pi_180*half) + ndfl = view_near / stereo_def%focalLength +! + each_eye = each_eye_from_middle(ione, stereo_def) +! + view_bottom = - wd2 + view_top = wd2 + view_left = - view_param%perspective_xy_ratio * wd2 & + & - each_eye * ndfl + view_right = view_param%perspective_xy_ratio * wd2 & + & - each_eye * ndfl +! + call set_perspective_mat_by_area(view_left, view_right, & + & view_bottom, view_top, view_near, view_far, & + & projection_right) +! + if (iflag_debug .gt. 0) then + write(*,*) 'projection_right for PVR ' + do i = 1, 4 + write(*,'(1p4e16.7)') projection_right(i,1:4) + end do + end if +! + end subroutine set_pvr_projection_right_mat +! +! ----------------------------------------------------------------------- +! + end module cal_pvr_projection_mat diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_grayscales.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_grayscales.f90 new file mode 100644 index 00000000..7ecd7340 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_grayscales.f90 @@ -0,0 +1,88 @@ +!>@file colormap_grayscales.F90 +!!@brief module colormap_grayscales +!! +!!@author H. Matsui +!!@date Programmed in Apr., 2024 +! +!>@brief Colormapping for grayscales +!! +!!@verbatim +!! subroutine s_colormap_grayscale(rnorm, r, g, b) +!! subroutine s_colormap_sym_grayscale(rnorm, r, g, b) +!! real(kind = kreal), intent(in) :: rnorm +!! real(kind = kreal), intent(inout) :: r, g, b +!!@endverbatim +! + module colormap_grayscales +! + use m_precision + use m_constants +! + implicit none +! +! ------------------------------------------------------------------ +! + contains +! +! ------------------------------------------------------------------ +! + subroutine s_colormap_grayscale(rnorm, r, g, b) +! + real(kind = kreal), intent(in) :: rnorm + real(kind = kreal), intent(inout) :: r, g, b +! + real(kind = kreal), parameter :: black = zero + real(kind = kreal), parameter :: white = one +! +! + if (rnorm .lt. zero ) then + r = zero + g = zero + b = zero + else if (rnorm .ge. zero .and. rnorm.lt.white) then + r = 0.85d0*rnorm + g = 0.85d0*rnorm + b = 0.85d0*rnorm + else if (rnorm .ge. white ) then + r = 0.85d0 + g = 0.85d0 + b = 0.85d0 + end if +! + end subroutine s_colormap_grayscale +! +! ---------------------------------------------------------------------- +! + subroutine s_colormap_sym_grayscale(rnorm, r, g, b) +! + real(kind = kreal), intent(in) :: rnorm + real(kind = kreal), intent(inout) :: r, g, b +! + real(kind = kreal), parameter :: black = zero + real(kind = kreal), parameter :: white = one + real(kind = kreal), parameter :: half = one / two +! +! + if (rnorm .lt. zero ) then + r = zero + g = zero + b = zero + else if (rnorm .ge. zero .and. rnorm.lt.half) then + r = 0.85d0*two*rnorm + g = 0.85d0*two*rnorm + b = 0.85d0*two*rnorm + else if (rnorm .ge. half .and. rnorm.lt.white) then + r = 0.85d0*two*(one - rnorm) + g = 0.85d0*two*(one - rnorm) + b = 0.85d0*two*(one - rnorm) + else if (rnorm .ge. white ) then + r = zero + g = zero + b = zero + end if +! + end subroutine s_colormap_sym_grayscale +! +! ---------------------------------------------------------------------- +! + end module colormap_grayscales diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_metal.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_metal.f90 new file mode 100644 index 00000000..1c590383 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_metal.f90 @@ -0,0 +1,63 @@ +!>@file colormap_metal.F90 +!!@brief module colormap_metal +!! +!!@author H. Matsui +!!@date Programmed in Apr., 2024 +! +!>@brief Colormapping for molten metal +!! +!!@verbatim +!! subroutine s_colormap_metal(rnorm, r, g, b) +!! real(kind = kreal), intent(in) :: rnorm +!! real(kind = kreal), intent(inout) :: r, g, b +!!@endverbatim +! + module colormap_metal +! + use m_precision + use m_constants +! + implicit none +! +! ------------------------------------------------------------------ +! + contains +! +! ------------------------------------------------------------------ +! + subroutine s_colormap_metal(rnorm, r, g, b) +! + real(kind = kreal), intent(in) :: rnorm + real(kind = kreal), intent(inout) :: r, g, b +! + real(kind = kreal), parameter :: c_g1 = 0.6 + real(kind = kreal), parameter :: r_mul = one / c_g1 + real(kind = kreal), parameter :: g_mul = one / (one - c_g1) +! + real(kind = kreal) :: x +! +! + x = rnorm + if (x .lt. zero) then + r = zero + else if(r .lt. c_g1) then + r = x * r_mul + else + r = one + end if +! + if (x .lt. c_g1) then + g = zero + else if(r .lt. one) then + g = (x - c_g1) * g_mul + else + g = one + end if +! + b = zero +! + end subroutine s_colormap_metal +! +! ---------------------------------------------------------------------- +! + end module colormap_metal diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_rainbow.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_rainbow.f90 new file mode 100644 index 00000000..bb7f84f7 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_rainbow.f90 @@ -0,0 +1,76 @@ +!>@file colormap_rainbow.F90 +!!@brief module colormap_rainbow +!! +!!@author H. Matsui +!!@date Programmed in Apr., 2024 +! +!>@brief Rainbow colormapping +!! +!!@verbatim +!! subroutine s_colormap_rainbow(rnorm, r, g, b) +!! real(kind = kreal), intent(in) :: rnorm +!! real(kind = kreal), intent(inout) :: r, g, b +!!@endverbatim +! + module colormap_rainbow +! + use m_precision + use m_constants +! + implicit none +! +! ------------------------------------------------------------------ +! + contains +! +! ------------------------------------------------------------------ +! + subroutine s_colormap_rainbow(rnorm, r, g, b) +! + real(kind = kreal), intent(in) :: rnorm + real(kind = kreal), intent(inout) :: r, g, b +! + real(kind = kreal), parameter :: purple = zero + real(kind = kreal), parameter :: blue = 0.1e0 + real(kind = kreal), parameter :: ocean = 0.325e0 + real(kind = kreal), parameter :: green = 0.55e0 + real(kind = kreal), parameter :: yellow = 0.775e0 + real(kind = kreal), parameter :: red = one + real(kind = kreal), parameter :: forty = four*ten +! +! + if (rnorm .lt. purple ) then + r = half + g = zero + b = one + else if (rnorm .ge. purple .and. rnorm.lt.blue) then + r = half - five*rnorm + g = zero + b = one + else if (rnorm .ge. blue .and. rnorm.lt.ocean) then + r = zero + g = forty*(rnorm-blue) / dnine + b = one + else if (rnorm .ge. ocean .and. rnorm.lt.green) then + r = zero + g = one + b = one - forty*(rnorm-ocean) / dnine + else if (rnorm .ge. green .and. rnorm.lt.yellow) then + r = forty*(rnorm-green) / dnine + g = one + b = zero + else if (rnorm .ge. yellow .and. rnorm.lt. red) then + r = one + g = one - forty*(rnorm-yellow) / dnine + b = zero + else if (rnorm .ge. red ) then + r = one + g = zero + b = zero + end if +! + end subroutine s_colormap_rainbow +! +! ---------------------------------------------------------------------- +! + end module colormap_rainbow diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_space.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_space.f90 new file mode 100644 index 00000000..a7025d55 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_space.f90 @@ -0,0 +1,117 @@ +!>@file colormap_space.F90 +!!@brief module colormap_space +!! +!!@author H. Matsui +!!@date Programmed in Apr., 2024 +! +!>@brief Colormapping +!! +!!@verbatim +!! subroutine s_colormap_space(rnorm, r, g, b) +!! real(kind = kreal), intent(in) :: rnorm +!! real(kind = kreal), intent(inout) :: r, g, b +!!@endverbatim +! + module colormap_space +! + use m_precision + use m_constants +! + implicit none +! +! ------------------------------------------------------------------ +! + contains +! +! ------------------------------------------------------------------ +! + subroutine s_colormap_space(rnorm, r, g, b) +! + real(kind = kreal), intent(in) :: rnorm + real(kind = kreal), intent(inout) :: r, g, b +! + real(kind = kreal), parameter :: c_r1 = 37067.0 / 158860.0 + real(kind = kreal), parameter :: c_r2 = 85181.0 / 230350.0 + real(kind = kreal), parameter & + & :: c_r3 = (sqrt(3196965649.0) + 83129.0) / 310480.0 + real(kind = kreal), parameter :: c_r4 = 231408.0 / 362695.0 + real(kind = kreal), parameter :: c_r5 = 152073.0 / 222340.0 + real(kind = kreal), parameter :: c_r6 = 294791.0 / 397780.0 + real(kind = kreal), parameter :: c_r7 = 491189.0 / 550980.0 +! + real(kind = kreal), parameter & + & :: c_g1 = (-sqrt(166317494.0) + 39104.0) / 183830.0 + real(kind = kreal), parameter & + & :: c_g3 = (3.0 * sqrt(220297369.0) + 58535.0) / 155240.0 +! + real(kind = kreal), parameter :: c_b1 = 51987.0 / 349730.0 +! + real(kind = kreal) :: x, xx +! +! + x = rnorm + if (x .lt. c_r1) then + r = 0.0 + else if (x .lt. c_r2) then + xx = x - c_r1 + r = (780.25 * xx + 319.71) * xx / 255.0 + else if (x .lt. c_r3) then + r = ((1035.33580904442 * x - 82.5380748768798) * x & + & - 52.8985266363332) / 255.0 + else if (x .lt. c_r4) then + r = (339.41 * x - 33.194) / 255.0 + else if (x .lt. c_r5) then + r = (1064.8 * x - 496.01) / 255.0 + else if (x .lt. c_r6) then + r = (397.78 * x - 39.791) / 255.0 + else if (x .lt. c_r7) then + r = 1.0 + else if (x .lt. one) then + r = (5509.8 * x + 597.91) * x / 255.0 + else + r = 1.0 + end if + + if (x .lt. zero) then + g = 0.0 + else if (x .lt. c_g1) then + g = (-1838.3 * x + 464.36) * x / 255.0 + else if (x .lt. c_r1) then + g = (-317.72 * x + 74.134) / 255.0 + else if (x .lt. c_g3) then + g = 0.0 + else if (x .lt. c_r6) then + xx = x - c_g3 + g = (-1945.0 * xx + 1430.2) * xx / 255.0 + else if (x .lt. c_r7) then + g = ((-1770.0 * x + 3.92813840044638e3) * x & + & - 1.84017494792245e3) / 255.0 + else + g = 1.0 + end if + + if (x .lt. zero) then + b = 0.0 + else if (x .lt. c_b1) then + b = (458.79 * x) / 255.0 + else if (x .lt. c_r2) then + b = (109.06 * x + 51.987) / 255.0 + else if (x .lt. c_r3) then + b = (339.41 * x - 33.194) / 255.0 + else if (x .lt. c_g3) then + b = ((-1552.4 * x + 1170.7) * x - 92.996) / 255.0 + else if (x .lt. 27568.0 / 38629.0) then + b = 0.0 + else if (x .lt. 81692.0 / 96241.0) then + b = (386.29 * x - 275.68) / 255.0 + else if (x .lt. 1.0) then + b = (1348.7 * x - 1092.6) / 255.0 + else + b = 1.0 + end if +! + end subroutine s_colormap_space +! +! ---------------------------------------------------------------------- +! + end module colormap_space diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_two_colors.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_two_colors.f90 new file mode 100644 index 00000000..cf0d8389 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/colormap_two_colors.f90 @@ -0,0 +1,103 @@ +!>@file colormap_two_colors.F90 +!!@brief module colormap_two_colors +!! +!!@author H. Matsui +!!@date Programmed in Apr., 2024 +! +!>@brief Colormapping with two colors +!! +!!@verbatim +!! subroutine s_colormap_redblue(rnorm, r, g, b) +!! subroutine s_colormap_orangecyan(rnorm, r, g, b) +!! real(kind = kreal), intent(in) :: rnorm +!! real(kind = kreal), intent(inout) :: r, g, b +!!@endverbatim +! + module colormap_two_colors +! + use m_precision + use m_constants +! + implicit none +! +! ------------------------------------------------------------------ +! + contains +! +! ------------------------------------------------------------------ +! + subroutine s_colormap_redblue(rnorm, r, g, b) +! + real(kind = kreal), intent(in) :: rnorm + real(kind = kreal), intent(inout) :: r, g, b +! + real(kind = kreal), parameter :: abyss = zero + real(kind = kreal), parameter :: blue = 0.1d0 + real(kind = kreal), parameter :: white = half + real(kind = kreal), parameter :: red = 0.9d0 + real(kind = kreal), parameter :: blood = one +! +! + if (rnorm .lt. abyss ) then + r = zero + g = 0.2d0 + b = 0.8d0 + else if (rnorm .ge. abyss .and. rnorm.lt.blue) then + r = zero + g = 2.0d0 * (blue - rnorm) + b = 0.8d0 + 2.0d0 * rnorm + else if (rnorm .ge. blue .and. rnorm.lt.white) then + r = (rnorm - blue) * 2.0d0 + g = (rnorm - blue) * 2.0d0 + b = one - (rnorm - blue) * 0.25 + else if (rnorm .ge. white .and. rnorm.lt.red) then + r = one - (red - rnorm) * 0.25 + g = (red - rnorm) * 2.0d0 + b = (red - rnorm) * 2.0d0 + else if (rnorm .ge. red .and. rnorm.lt. blood) then + r = one - (rnorm - red) * 2.0d0 + g = zero + b = zero + else if (rnorm .ge. blood) then + r = 0.8d0 + g = zero + b = zero + end if +! + end subroutine s_colormap_redblue +! +! ---------------------------------------------------------------------- +! + subroutine s_colormap_orangecyan(rnorm, r, g, b) +! + real(kind = kreal), intent(in) :: rnorm + real(kind = kreal), intent(inout) :: r, g, b +! + real(kind = kreal), parameter :: blue = zero + real(kind = kreal), parameter :: white = half + real(kind = kreal), parameter :: red = one +! +! + if (rnorm .lt. blue ) then + r = 0.0d0 + g = 1.0d0 + b = 1.0d0 + else if (rnorm .ge. blue .and. rnorm.lt.white) then + r = rnorm * 2.0d0 + g = 1.0d0 + b = 1.0d0 - rnorm * 0.5d0 + else if (rnorm .ge. white .and. rnorm.lt.red) then + r = 1.0 + g = (red - rnorm) + 0.5d0 + b = (red - rnorm) * 1.5d0 + else if (rnorm .ge. red) then + r = 1.0d0 + g = 0.5d0 + b = 0.0d0 + end if +! + end subroutine s_colormap_orangecyan +! +! ---------------------------------------------------------------------- +! + end module colormap_two_colors diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/comm_tbl_4_img_composit.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/comm_tbl_4_img_composit.f90 new file mode 100644 index 00000000..fc432753 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/comm_tbl_4_img_composit.f90 @@ -0,0 +1,339 @@ +!>@file comm_tbl_4_img_composit.f90 +!!@brief module comm_tbl_4_img_composit +!! +!!@author H. Matsui +!!@date Programmed on Oct., 2016 +! +!>@brief Routies to construct communication table for image compostiion +!! +!!@verbatim +!! subroutine count_comm_pe_pvr_composition & +!! & (nprocs, num_send_pixel_tmp, num_recv_pixel_tmp, & +!! & ncomm_send_pixel_composit, ncomm_recv_pixel_composit) +!! subroutine count_comm_tbl_pvr_composition(nprocs, my_rank, & +!! & num_send_pixel_tmp, num_recv_pixel_tmp, & +!! & ncomm_send_pixel_composit, ncomm_recv_pixel_composit, & +!! & ntot_send_pixel_composit, irank_send_pixel_composit, & +!! & istack_send_pixel_composit, ntot_recv_pixel_composit, & +!! & irank_recv_pixel_composit, istack_recv_pixel_composit,& +!! & iself_pixel_composit) +!! subroutine set_comm_tbl_pvr_composition & +!! & (num_pvr_ray, id_pixel_start, index_pvr_start, & +!! & num_pixel_xy, irank_4_composit, & +!! & ncomm_send_pixel_composit, ntot_send_pixel_composit, & +!! & irank_send_pixel_composit, istack_send_pixel_composit,& +!! & item_send_pixel_composit) +!! +!! subroutine set_item_recv_tmp_composit(ntot_recv_pixel_composit, & +!! & item_recv_pixel_composit) +!! subroutine set_image_composition_stack(num_pixel_xy, & +!! & item_4_composit, npixel_4_composit, & +!! & ntot_recv_pixel_composit, ipix_4_composit, & +!! & istack_composition, idx_recv_pixel_composit) +!! subroutine sort_recv_pixel_by_depth & +!! & (npixel_4_composit, ntot_recv_pixel_composit, & +!! & depth_pixel_composit, istack_composition, & +!! & idx_recv_pixel_composit, item_recv_pixel_composit) +!!@endverbatim +!! + module comm_tbl_4_img_composit +! + use m_precision + use m_constants +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine count_comm_pe_pvr_composition & + & (nprocs, num_send_pixel_tmp, num_recv_pixel_tmp, & + & ncomm_send_pixel_composit, ncomm_recv_pixel_composit) +! + integer, intent(in) :: nprocs + integer(kind = kint), intent(in) :: num_send_pixel_tmp(nprocs) + integer(kind = kint), intent(in) :: num_recv_pixel_tmp(nprocs) +! + integer(kind = kint), intent(inout) :: ncomm_send_pixel_composit + integer(kind = kint), intent(inout) :: ncomm_recv_pixel_composit +! + integer :: ip + integer(kind = kint) :: icou1, icou2 +! +! + icou1 = 0 + icou2 = 0 + do ip = 1, nprocs + if(num_send_pixel_tmp(ip) .gt. 0) icou1 = icou1 + 1 + if(num_recv_pixel_tmp(ip) .gt. 0) icou2 = icou2 + 1 + end do + ncomm_send_pixel_composit = icou1 + ncomm_recv_pixel_composit = icou2 +! + end subroutine count_comm_pe_pvr_composition +! +! --------------------------------------------------------------------- +! + subroutine count_comm_tbl_pvr_composition(nprocs, my_rank, & + & num_send_pixel_tmp, num_recv_pixel_tmp, & + & ncomm_send_pixel_composit, ncomm_recv_pixel_composit, & + & ntot_send_pixel_composit, irank_send_pixel_composit, & + & istack_send_pixel_composit, ntot_recv_pixel_composit, & + & irank_recv_pixel_composit, istack_recv_pixel_composit, & + & iself_pixel_composit) +! + integer, intent(in) :: nprocs, my_rank + integer(kind = kint), intent(in) :: num_send_pixel_tmp(nprocs) + integer(kind = kint), intent(in) :: num_recv_pixel_tmp(nprocs) +! + integer(kind = kint), intent(in) :: ncomm_send_pixel_composit + integer(kind = kint), intent(in) :: ncomm_recv_pixel_composit +! + integer(kind = kint), intent(inout) :: iself_pixel_composit + integer(kind = kint), intent(inout) :: ntot_send_pixel_composit + integer(kind = kint), intent(inout) & + & :: irank_send_pixel_composit(ncomm_send_pixel_composit) + integer(kind = kint), intent(inout) & + & :: istack_send_pixel_composit(0:ncomm_send_pixel_composit) +! + integer(kind = kint), intent(inout) :: ntot_recv_pixel_composit + integer(kind = kint), intent(inout) & + & :: irank_recv_pixel_composit(ncomm_recv_pixel_composit) + integer(kind = kint), intent(inout) & + & :: istack_recv_pixel_composit(0:ncomm_recv_pixel_composit) +! + integer :: ip + integer(kind = kint) :: icou1, icou2, i_rank +! +! + icou1 = 0 + icou2 = 0 + iself_pixel_composit = 0 + istack_send_pixel_composit(icou1) = 0 + istack_recv_pixel_composit(icou2) = 0 + do ip = 1, nprocs + i_rank = mod(my_rank+ip,nprocs) + if(num_send_pixel_tmp(i_rank+1) .gt. 0) then + icou1 = icou1 + 1 + irank_send_pixel_composit(icou1) = i_rank + istack_send_pixel_composit(icou1) & + & = istack_send_pixel_composit(icou1-1) & + & + num_send_pixel_tmp(i_rank+1) + if(i_rank .eq. my_rank) iself_pixel_composit = 1 + end if + if(num_recv_pixel_tmp(i_rank+1) .gt. 0) then + icou2 = icou2 + 1 + irank_recv_pixel_composit(icou2) = i_rank + istack_recv_pixel_composit(icou2) & + & = istack_recv_pixel_composit(icou2-1) & + & + num_recv_pixel_tmp(i_rank+1) + if(i_rank .eq. my_rank) iself_pixel_composit = 1 + end if + end do +! + ntot_send_pixel_composit & + & = istack_send_pixel_composit(ncomm_send_pixel_composit) + ntot_recv_pixel_composit & + & = istack_recv_pixel_composit(ncomm_recv_pixel_composit) +! + end subroutine count_comm_tbl_pvr_composition +! +! --------------------------------------------------------------------- +! + subroutine set_comm_tbl_pvr_composition & + & (num_pvr_ray, id_pixel_start, index_pvr_start, & + & num_pixel_xy, irank_4_composit, & + & ncomm_send_pixel_composit, ntot_send_pixel_composit, & + & irank_send_pixel_composit, istack_send_pixel_composit, & + & item_send_pixel_composit) +! + integer(kind = kint), intent(in) :: num_pixel_xy + integer(kind = kint), intent(in) & + & :: irank_4_composit(num_pixel_xy) +! + integer(kind = kint), intent(in) :: num_pvr_ray + integer(kind = kint), intent(in) :: id_pixel_start(num_pvr_ray) + integer(kind = kint), intent(in) :: index_pvr_start(num_pvr_ray) +! + integer(kind = kint), intent(in) :: ncomm_send_pixel_composit + integer(kind = kint), intent(in) :: ntot_send_pixel_composit + integer(kind = kint), intent(in) & + & :: irank_send_pixel_composit(ncomm_send_pixel_composit) + integer(kind = kint), intent(in) & + & :: istack_send_pixel_composit(0:ncomm_send_pixel_composit) +! + integer(kind = kint), intent(inout) & + & :: item_send_pixel_composit(ntot_send_pixel_composit) +! + integer(kind = kint) :: ip, jst, num + integer(kind = kint) :: inum, icou, isrt, ipix, i_rank +! +! + icou = 0 + if(icou .ge. num_pvr_ray) return + do + isrt = index_pvr_start(icou+1) + ipix = id_pixel_start(isrt) + i_rank = irank_4_composit(ipix) + do ip = 1, ncomm_send_pixel_composit + if(irank_send_pixel_composit(ip) .eq. i_rank) then + jst = istack_send_pixel_composit(ip-1) + num = istack_send_pixel_composit(ip) - jst + do inum = 1, num + icou = icou + 1 + isrt = index_pvr_start(icou) + item_send_pixel_composit(inum+jst) = isrt + end do + exit + end if + end do + if(icou .ge. num_pvr_ray) exit + end do +! + end subroutine set_comm_tbl_pvr_composition +! +! --------------------------------------------------------------------- +! + subroutine set_item_recv_tmp_composit(ntot_recv_pixel_composit, & + & item_recv_pixel_composit) +! + integer(kind = kint), intent(in) :: ntot_recv_pixel_composit +! + integer(kind = kint), intent(inout) & + & :: item_recv_pixel_composit(ntot_recv_pixel_composit) +! + integer(kind = kint) :: inum +! +! +!$omp parallel do + do inum = 1, ntot_recv_pixel_composit + item_recv_pixel_composit(inum) = inum + end do +!$omp end parallel do +! + end subroutine set_item_recv_tmp_composit +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_image_composition_stack(num_pixel_xy, & + & item_4_composit, npixel_4_composit, & + & ntot_recv_pixel_composit, ipix_4_composit, & + & istack_composition, idx_recv_pixel_composit) +! + use quicksort +! + integer(kind = kint), intent(in) :: num_pixel_xy + integer(kind = kint), intent(in) :: item_4_composit(num_pixel_xy) +! + integer(kind = kint), intent(in) :: ntot_recv_pixel_composit + integer(kind = kint), intent(in) & + & :: ipix_4_composit(ntot_recv_pixel_composit) + integer(kind = kint), intent(in) :: npixel_4_composit +! + integer(kind = kint), intent(inout) & + & :: istack_composition(0:npixel_4_composit) + integer(kind = kint), intent(inout) & + & :: idx_recv_pixel_composit(ntot_recv_pixel_composit) +! + integer(kind = kint), allocatable :: itmp_recv_pixel_composit(:) + integer(kind = kint) :: inum, ipix +! +! + allocate(itmp_recv_pixel_composit(ntot_recv_pixel_composit)) +! +!$omp parallel do + do inum = 1, ntot_recv_pixel_composit + ipix = ipix_4_composit(inum) + itmp_recv_pixel_composit(inum) = item_4_composit(ipix) + idx_recv_pixel_composit(inum) = inum + end do +!$omp end parallel do +! + if(ntot_recv_pixel_composit .gt. 1) then + call quicksort_w_index & + & (ntot_recv_pixel_composit, itmp_recv_pixel_composit, & + & ione, ntot_recv_pixel_composit, idx_recv_pixel_composit) + end if +! +!$omp parallel workshare + istack_composition(0:npixel_4_composit) = 0 +!$omp end parallel workshare + do inum = 1, ntot_recv_pixel_composit + ipix = itmp_recv_pixel_composit(inum) + istack_composition(ipix) = istack_composition(ipix) + 1 + end do + do ipix = 1, npixel_4_composit + istack_composition(ipix) = istack_composition(ipix-1) & + & + istack_composition(ipix) + end do +! + deallocate(itmp_recv_pixel_composit) +! + end subroutine set_image_composition_stack +! +! --------------------------------------------------------------------- +! + subroutine sort_recv_pixel_by_depth & + & (npixel_4_composit, ntot_recv_pixel_composit, & + & depth_pixel_composit, istack_composition, & + & idx_recv_pixel_composit, item_recv_pixel_composit) +! + use quicksort +! + integer(kind = kint), intent(in) :: ntot_recv_pixel_composit + real(kind = kreal), intent(in) & + & :: depth_pixel_composit(ntot_recv_pixel_composit) + integer(kind = kint), intent(in) :: npixel_4_composit +! + integer(kind = kint), intent(in) & + & :: istack_composition(0:npixel_4_composit) +! + integer(kind = kint), intent(inout) & + & :: idx_recv_pixel_composit(ntot_recv_pixel_composit) + integer(kind = kint), intent(inout) & + & :: item_recv_pixel_composit(ntot_recv_pixel_composit) +! + real(kind = kreal), allocatable :: rwork_recv_pixel_composit(:) + integer(kind = kint) :: inum, ipix, ist, ied, num, icou +! +! + allocate(rwork_recv_pixel_composit(ntot_recv_pixel_composit)) +! +!$omp parallel do private(inum,icou) + do inum = 1, ntot_recv_pixel_composit + icou = idx_recv_pixel_composit(inum) + rwork_recv_pixel_composit(inum) = depth_pixel_composit(icou) + end do +!$omp end parallel do +! +!$omp parallel do private(ipix,ist,ied,num) + do ipix = 1, npixel_4_composit + ist = istack_composition(ipix-1) + ied = istack_composition(ipix) + num = ied - ist + if(num .gt. 1) then + call quicksort_real_w_index & + & (num, rwork_recv_pixel_composit(ist+1), & + & ione, num, idx_recv_pixel_composit(ist+1)) + end if + end do +!$omp end parallel do +! +!$omp parallel do private(inum,icou) + do inum = 1, ntot_recv_pixel_composit + icou = idx_recv_pixel_composit(inum) + item_recv_pixel_composit(icou) = inum + end do +!$omp end parallel do +! + deallocate(rwork_recv_pixel_composit) +! + end subroutine sort_recv_pixel_by_depth +! +! --------------------------------------------------------------------- +! + end module comm_tbl_4_img_composit diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/comm_tbl_4_img_output.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/comm_tbl_4_img_output.f90 new file mode 100644 index 00000000..3078977e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/comm_tbl_4_img_output.f90 @@ -0,0 +1,228 @@ +!>@file comm_tbl_4_img_output.f90 +!!@brief module comm_tbl_4_img_output +!! +!!@author H. Matsui +!!@date Programmed on Oct., 2016 +! +!>@brief Routies to construct communication table for image output +!! +!!@verbatim +!! subroutine count_export_pe_pvr_output & +!! & (npixel_4_composit, ncomm_send_pixel_output) +!! subroutine count_export_item_pvr_output & +!! & (irank_image_file, npixel_4_composit, & +!! & ncomm_send_pixel_output, ntot_send_pixel_output, & +!! & irank_send_pixel_output, istack_send_pixel_output) +!! subroutine set_export_item_pvr_output & +!! & (ntot_send_pixel_output, item_send_pixel_output) +!! +!! subroutine count_import_pe_pvr_output & +!! & (nprocs, my_rank, irank_image_file, istack_recv_image, & +!! & ncomm_recv_pixel_output) +!! subroutine count_import_item_pvr_output & +!! & (nprocs, my_rank, irank_image_file, istack_recv_image, & +!! & num_pixel_xy, irank_4_composit, item_recv_image, & +!! & ncomm_recv_pixel_output, ntot_recv_pixel_output, & +!! & irank_recv_pixel_output, istack_recv_pixel_output, & +!! & iself_pixel_output, num_pixel_recv) +!! subroutine set_import_item_pvr_output & +!! & (num_pixel_xy, item_recv_image, & +!! & ntot_recv_pixel_output, num_pixel_recv, & +!! & item_recv_pixel_output, irev_recv_pixel_output) +!!@endverbatim +!! + module comm_tbl_4_img_output +! + use m_precision + use m_constants +! use calypso_mpi +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine count_export_pe_pvr_output & + & (npixel_4_composit, ncomm_send_pixel_output) +! + integer(kind = kint), intent(in) :: npixel_4_composit + integer(kind = kint), intent(inout) :: ncomm_send_pixel_output +! +! + ncomm_send_pixel_output = 0 + if(npixel_4_composit .gt. 0) ncomm_send_pixel_output = 1 +! + end subroutine count_export_pe_pvr_output +! +! --------------------------------------------------------------------- +! + subroutine count_export_item_pvr_output & + & (irank_image_file, npixel_4_composit, & + & ncomm_send_pixel_output, ntot_send_pixel_output, & + & irank_send_pixel_output, istack_send_pixel_output) +! + integer(kind = kint), intent(in) :: irank_image_file + integer(kind = kint), intent(in) :: npixel_4_composit +! + integer(kind = kint), intent(in) :: ncomm_send_pixel_output + integer(kind = kint), intent(inout) :: ntot_send_pixel_output + integer(kind = kint), intent(inout) & + & :: irank_send_pixel_output(ncomm_send_pixel_output) + integer(kind = kint), intent(inout) & + & :: istack_send_pixel_output(0:ncomm_send_pixel_output) +! +! + istack_send_pixel_output(0) = 0 + if(ncomm_send_pixel_output .eq. 1) then + irank_send_pixel_output(ncomm_send_pixel_output) & + & = irank_image_file + istack_send_pixel_output(ncomm_send_pixel_output) & + & = npixel_4_composit + end if + ntot_send_pixel_output & + & = istack_send_pixel_output(ncomm_send_pixel_output) +! + end subroutine count_export_item_pvr_output +! +! --------------------------------------------------------------------- +! + subroutine set_export_item_pvr_output & + & (ntot_send_pixel_output, item_send_pixel_output) +! + integer(kind = kint), intent(in) :: ntot_send_pixel_output + integer(kind = kint), intent(inout) & + & :: item_send_pixel_output(ntot_send_pixel_output) +! + integer(kind = kint) :: inum +! +! +!$omp parallel do + do inum = 1, ntot_send_pixel_output + item_send_pixel_output(inum) = inum + end do +!$omp end parallel do +! + end subroutine set_export_item_pvr_output +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine count_import_pe_pvr_output & + & (nprocs, my_rank, irank_image_file, istack_recv_image, & + & ncomm_recv_pixel_output) +! + integer, intent(in) :: nprocs, my_rank + integer(kind = kint), intent(in) :: irank_image_file + integer(kind = kint), intent(in) :: istack_recv_image(0:nprocs) +! + integer(kind = kint), intent(inout) :: ncomm_recv_pixel_output +! + integer(kind = kint) :: ip, num +! +! + ncomm_recv_pixel_output = 0 + if(my_rank .eq. irank_image_file) then + do ip = 1, nprocs + num = istack_recv_image(ip) - istack_recv_image(ip-1) + if(num .gt. 0) then + ncomm_recv_pixel_output = ncomm_recv_pixel_output + 1 + end if + end do + end if +! + end subroutine count_import_pe_pvr_output +! +! --------------------------------------------------------------------- +! + subroutine count_import_item_pvr_output & + & (nprocs, my_rank, irank_image_file, istack_recv_image, & + & num_pixel_xy, irank_4_composit, item_recv_image, & + & ncomm_recv_pixel_output, ntot_recv_pixel_output, & + & irank_recv_pixel_output, istack_recv_pixel_output, & + & iself_pixel_output, num_pixel_recv) +! + integer, intent(in) :: nprocs, my_rank + integer(kind = kint), intent(in) :: irank_image_file + integer(kind = kint), intent(in) :: istack_recv_image(0:nprocs) + integer(kind = kint), intent(in) :: num_pixel_xy + integer(kind = kint), intent(in) :: irank_4_composit(num_pixel_xy) + integer(kind = kint), intent(in) :: item_recv_image(num_pixel_xy) +! + integer(kind = kint), intent(in) :: ncomm_recv_pixel_output +! + integer(kind = kint), intent(inout) :: num_pixel_recv + integer(kind = kint), intent(inout) :: iself_pixel_output + integer(kind = kint), intent(inout) :: ntot_recv_pixel_output + integer(kind = kint), intent(inout) & + & :: irank_recv_pixel_output(ncomm_recv_pixel_output) + integer(kind = kint), intent(inout) & + & :: istack_recv_pixel_output(0:ncomm_recv_pixel_output) +! + integer(kind = kint) :: ip, icou, ist, num, ipix +! + iself_pixel_output = 0 + num_pixel_recv = 0 + istack_recv_pixel_output(0) = 0 + if(my_rank .eq. irank_image_file) then + num_pixel_recv = num_pixel_xy +! + icou = 0 + do ip = 1, nprocs + ist = istack_recv_image(ip-1) + num = istack_recv_image(ip) - istack_recv_image(ip-1) + ipix = item_recv_image(ist+1) +! + if(num .gt. 0) then + icou = icou + 1 + istack_recv_pixel_output(icou) = istack_recv_image(ip) + irank_recv_pixel_output(icou) = irank_4_composit(ipix) + end if + if(irank_4_composit(ipix) .eq. irank_image_file) then + iself_pixel_output = 1 + end if + end do + end if + ntot_recv_pixel_output & + & = istack_recv_pixel_output(ncomm_recv_pixel_output) +! + end subroutine count_import_item_pvr_output +! +! --------------------------------------------------------------------- +! + subroutine set_import_item_pvr_output & + & (num_pixel_xy, item_recv_image, & + & ntot_recv_pixel_output, num_pixel_recv, & + & item_recv_pixel_output, irev_recv_pixel_output) +! + integer(kind = kint), intent(in) :: ntot_recv_pixel_output + integer(kind = kint), intent(in) :: num_pixel_xy, num_pixel_recv + integer(kind = kint), intent(in) :: item_recv_image(num_pixel_xy) +! + integer(kind = kint), intent(inout) & + & :: item_recv_pixel_output(ntot_recv_pixel_output) + integer(kind = kint), intent(inout) & + & :: irev_recv_pixel_output(num_pixel_recv) +! + integer(kind = kint) :: inum, ipix +! +! + if(num_pixel_recv .le. 0) return +! +!$omp parallel workshare + irev_recv_pixel_output(1:num_pixel_recv) = 0 +!$omp end parallel workshare +! + do inum = 1, ntot_recv_pixel_output + ipix = item_recv_image(inum) + item_recv_pixel_output(inum) = ipix + irev_recv_pixel_output(ipix) = inum + end do +! + end subroutine set_import_item_pvr_output +! +! --------------------------------------------------------------------- +! + end module comm_tbl_4_img_output diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/const_comm_tbl_img_composit.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/const_comm_tbl_img_composit.f90 new file mode 100644 index 00000000..eb7582db --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/const_comm_tbl_img_composit.f90 @@ -0,0 +1,286 @@ +!>@file const_comm_tbl_img_composit.f90 +!!@brief module const_comm_tbl_img_composit +!! +!!@author H. Matsui +!!@date Programmed on Oct., 2016 +! +!>@brief Routies to construct communication table for volume rendering +!! +!!@verbatim +!! subroutine s_const_comm_tbl_img_output & +!! & (stencil_wk, irank_image_file, num_pixel_xy, & +!! & npixel_4_composit, num_pixel_recv, img_output_tbl) +!! subroutine s_const_comm_tbl_img_composit & +!! & (irank_image_file, irank_end_composit, num_pixel_xy, & +!! & irank_4_composit, num_pvr_ray, id_pixel_start, & +!! & img_composit_tbl) +!! subroutine set_image_stacking_and_recv(num_pixel_xy, & +!! & item_4_composit, npixel_4_composit, ipix_4_composit, & +!! & depth_pixel_composit, istack_composition, & +!! & img_composit_tbl) +!! type(calypso_comm_table), intent(inout) :: img_composit_tbl +!!@endverbatim +!! + module const_comm_tbl_img_composit +! + use m_precision + use m_constants + use calypso_mpi +! + use t_calypso_comm_table +! + implicit none +! + private :: sort_index_pvr_start, count_num_send_pixel_tmp +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_const_comm_tbl_img_output & + & (stencil_wk, irank_image_file, num_pixel_xy, & + & npixel_4_composit, num_pixel_recv, img_output_tbl) +! + use t_calypso_comm_table + use t_stencil_buffer_work + use comm_tbl_4_img_output +! + integer(kind = kint), intent(in) :: irank_image_file + integer(kind = kint), intent(in) :: num_pixel_xy + integer(kind = kint), intent(in) :: npixel_4_composit + type(stencil_buffer_work), intent(in) :: stencil_wk +! + integer(kind = kint), intent(inout) :: num_pixel_recv + type(calypso_comm_table), intent(inout) :: img_output_tbl +! +! + call count_export_pe_pvr_output & + & (npixel_4_composit, img_output_tbl%nrank_export) +! + call alloc_calypso_export_num(img_output_tbl) + call count_export_item_pvr_output & + & (irank_image_file, npixel_4_composit, & + & img_output_tbl%nrank_export, img_output_tbl%ntot_export, & + & img_output_tbl%irank_export, img_output_tbl%istack_export) +! + call alloc_calypso_export_item(img_output_tbl) + call set_export_item_pvr_output & + & (img_output_tbl%ntot_export, img_output_tbl%item_export) +! +! + call count_import_pe_pvr_output & + & (nprocs, my_rank, irank_image_file, & + & stencil_wk%istack_recv_image, img_output_tbl%nrank_import) +! + call alloc_calypso_import_num(img_output_tbl) + call count_import_item_pvr_output(nprocs, my_rank, & + & irank_image_file, stencil_wk%istack_recv_image, num_pixel_xy, & + & stencil_wk%irank_4_composit, stencil_wk%item_recv_image, & + & img_output_tbl%nrank_import, img_output_tbl%ntot_import, & + & img_output_tbl%irank_import, img_output_tbl%istack_import, & + & img_output_tbl%iflag_self_copy, num_pixel_recv) +! + call alloc_calypso_import_item(img_output_tbl) + call alloc_calypso_import_rev(num_pixel_recv, img_output_tbl) + call set_import_item_pvr_output & + & (num_pixel_xy, stencil_wk%item_recv_image, & + & img_output_tbl%ntot_import, num_pixel_recv, & + & img_output_tbl%item_import, img_output_tbl%irev_import) +! + end subroutine s_const_comm_tbl_img_output +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine s_const_comm_tbl_img_composit & + & (irank_image_file, irank_end_composit, num_pixel_xy, & + & irank_4_composit, num_pvr_ray, id_pixel_start, & + & img_composit_tbl) +! + use m_error_IDs + use calypso_mpi_int + use comm_tbl_4_img_composit +! + integer(kind = kint), intent(in) :: num_pixel_xy + integer(kind = kint), intent(in) :: irank_image_file + integer(kind = kint), intent(in) :: irank_end_composit + integer(kind = kint), intent(in) & + & :: irank_4_composit(num_pixel_xy) +! + integer(kind = kint), intent(in) :: num_pvr_ray + integer(kind = kint), intent(in) :: id_pixel_start(num_pvr_ray) +! + type(calypso_comm_table), intent(inout) :: img_composit_tbl +! + integer(kind = kint), allocatable :: index_pvr_start(:) + integer(kind = kint), allocatable :: num_send_pixel_tmp(:) + integer(kind = kint), allocatable :: num_recv_pixel_tmp(:) +! + integer :: i_rank + integer(kind = kint) :: ierr, num_rev +! +! + allocate(index_pvr_start(num_pvr_ray)) + call sort_index_pvr_start & + & (num_pvr_ray, id_pixel_start, index_pvr_start) +! + allocate(num_send_pixel_tmp(nprocs)) + allocate(num_recv_pixel_tmp(nprocs)) +!$omp parallel workshare + num_send_pixel_tmp(1:nprocs) = 0 + num_recv_pixel_tmp(1:nprocs) = 0 +!$omp end parallel workshare +! + call count_num_send_pixel_tmp & + & (num_pixel_xy, irank_4_composit, num_pvr_ray, & + & id_pixel_start, index_pvr_start, num_send_pixel_tmp) +! + do i_rank = int(irank_image_file), int(irank_end_composit) + call calypso_mpi_gather_one_int & + & (num_send_pixel_tmp(i_rank+1), num_recv_pixel_tmp, i_rank) + end do +! + call count_comm_pe_pvr_composition & + & (nprocs, num_send_pixel_tmp, num_recv_pixel_tmp, & + & img_composit_tbl%nrank_export, img_composit_tbl%nrank_import) +! + call alloc_calypso_import_num(img_composit_tbl) + call alloc_calypso_export_num(img_composit_tbl) +! + call count_comm_tbl_pvr_composition(nprocs, my_rank, & + & num_send_pixel_tmp, num_recv_pixel_tmp, & + & img_composit_tbl%nrank_export, img_composit_tbl%nrank_import, & + & img_composit_tbl%ntot_export, img_composit_tbl%irank_export, & + & img_composit_tbl%istack_export, img_composit_tbl%ntot_import, & + & img_composit_tbl%irank_import, img_composit_tbl%istack_import, & + & img_composit_tbl%iflag_self_copy) +! + call alloc_calypso_export_item(img_composit_tbl) + call set_comm_tbl_pvr_composition(num_pvr_ray, id_pixel_start, & + & index_pvr_start, num_pixel_xy, irank_4_composit, & + & img_composit_tbl%nrank_export, img_composit_tbl%ntot_export, & + & img_composit_tbl%irank_export, img_composit_tbl%istack_export, & + & img_composit_tbl%item_export) +! + call alloc_calypso_import_item(img_composit_tbl) + call set_item_recv_tmp_composit(img_composit_tbl%ntot_import, & + & img_composit_tbl%item_import) +! + num_rev = maxval(img_composit_tbl%item_import) + call alloc_calypso_import_rev(num_rev, img_composit_tbl) + call set_calypso_import_rev(img_composit_tbl, ierr) +! + if(ierr .gt. 0) then + call calypso_mpi_abort(ierr_repart, & + & 'Failed repatition table loading') + end if +! + deallocate(num_send_pixel_tmp, num_recv_pixel_tmp) + deallocate(index_pvr_start) +! + end subroutine s_const_comm_tbl_img_composit +! +! --------------------------------------------------------------------- +! + subroutine set_image_stacking_and_recv(num_pixel_xy, & + & item_4_composit, npixel_4_composit, ipix_4_composit, & + & depth_pixel_composit, istack_composition, & + & img_composit_tbl) +! + use comm_tbl_4_img_composit +! + integer(kind = kint), intent(in) :: num_pixel_xy + integer(kind = kint), intent(in) :: item_4_composit(num_pixel_xy) +! + type(calypso_comm_table), intent(inout) :: img_composit_tbl +! + integer(kind = kint), intent(in) & + & :: ipix_4_composit(img_composit_tbl%ntot_import) + real(kind = kreal), intent(in) & + & :: depth_pixel_composit(img_composit_tbl%ntot_import) + integer(kind = kint), intent(in) :: npixel_4_composit +! + integer(kind = kint), intent(inout) & + & :: istack_composition(0:npixel_4_composit) +! +! + call set_image_composition_stack & + & (num_pixel_xy, item_4_composit, npixel_4_composit, & + & img_composit_tbl%ntot_import, ipix_4_composit, & + & istack_composition, img_composit_tbl%irev_import) +! + call sort_recv_pixel_by_depth & + & (npixel_4_composit, img_composit_tbl%ntot_import, & + & depth_pixel_composit, istack_composition, & + & img_composit_tbl%irev_import, img_composit_tbl%item_import) +! + end subroutine set_image_stacking_and_recv +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine sort_index_pvr_start & + & (num_pvr_ray, id_pixel_start, index_pvr_start) +! + use quicksort +! + integer(kind = kint), intent(in) :: num_pvr_ray + integer(kind = kint), intent(in) :: id_pixel_start(num_pvr_ray) + integer(kind = kint), intent(inout) & + & :: index_pvr_start(num_pvr_ray) +! + integer(kind = kint), allocatable :: iref_pvr_start(:) + integer(kind = kint) :: inum +! +! + allocate(iref_pvr_start(num_pvr_ray)) +! + do inum = 1, num_pvr_ray + index_pvr_start(inum) = inum + iref_pvr_start(inum) = id_pixel_start(inum) + end do +! + if(num_pvr_ray .gt. 1) then + call quicksort_w_index(num_pvr_ray, iref_pvr_start, & + & ione, num_pvr_ray, index_pvr_start) + end if + deallocate(iref_pvr_start) +! + end subroutine sort_index_pvr_start +! +! --------------------------------------------------------------------- +! + subroutine count_num_send_pixel_tmp & + & (num_pixel_xy, irank_4_composit, num_pvr_ray, & + & id_pixel_start, index_pvr_start, num_send_pixel_tmp) +! + integer(kind = kint), intent(in) :: num_pixel_xy + integer(kind = kint), intent(in) & + & :: irank_4_composit(num_pixel_xy) +! + integer(kind = kint), intent(in) :: num_pvr_ray + integer(kind = kint), intent(in) :: id_pixel_start(num_pvr_ray) + integer(kind = kint), intent(in) :: index_pvr_start(num_pvr_ray) +! + integer(kind = kint), intent(inout) :: num_send_pixel_tmp(nprocs) +! + integer(kind = kint) :: inum, isrt, ipix, ip +! +! +!$omp parallel workshare + num_send_pixel_tmp(1:nprocs) = 0 +!$omp end parallel workshare + do inum = 1, num_pvr_ray + isrt = index_pvr_start(inum) + ipix = id_pixel_start(isrt) + ip = irank_4_composit(ipix) + 1 + num_send_pixel_tmp(ip) = num_send_pixel_tmp(ip) + 1 + end do +! + end subroutine count_num_send_pixel_tmp +! +! --------------------------------------------------------------------- +! + end module const_comm_tbl_img_composit diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/convert_real_rgb_2_bite.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/convert_real_rgb_2_bite.f90 new file mode 100644 index 00000000..8cc45dc2 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/convert_real_rgb_2_bite.f90 @@ -0,0 +1,140 @@ +!convert_real_rgb_2_bite.f90 +! module convert_real_rgb_2_bite +! +! subroutine cvt_double_rgba_to_char_rgb(num_pixel, rgba, crgb) +! subroutine cvt_double_rgba_to_char_rgba(num_pixel, rgba, crgba) +! +! subroutine set_rgb_background(num_pixel, rgba, bgcolor) +! + module convert_real_rgb_2_bite +! + use m_precision +! + use m_constants + use calypso_mpi +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine cvt_double_rgba_to_char_rgb(num_pixel, rgba, crgb) +! + integer(kind = kint), intent(in) :: num_pixel + real(kind = kreal), intent(in) :: rgba(4,num_pixel) + character(len = 1), intent(inout) :: crgb(3,num_pixel) + integer(kind = kint) :: i + integer :: ir, ig, ib +! +!$omp parallel do private(i,ir,ig,ib) + do i = 1, num_pixel + ir = int( rgba(1,i)*256.0d0) + ig = int( rgba(2,i)*256.0d0) + ib = int( rgba(3,i)*256.0d0) +! + if(ir.lt.0) then + ir = 0 + else if(ir.gt. 255) then + ir = 255 + end if +! + if(ig.lt.0) then + ig = 0 + else if(ig.gt. 255) then + ig = 255 + end if +! + if(ib.lt.0) then + ib = 0 + else if(ib.gt. 255) then + ib = 255 + end if +! + crgb(1,i) = char(ir) + crgb(2,i) = char(ig) + crgb(3,i) = char(ib) + end do +!$omp end parallel do +! + end subroutine cvt_double_rgba_to_char_rgb +! +! --------------------------------------------------------------------- +! + subroutine cvt_double_rgba_to_char_rgba(num_pixel, rgba, crgba) +! + integer(kind = kint), intent(in) :: num_pixel + real(kind = kreal), intent(in) :: rgba(4,num_pixel) + character(len = 1), intent(inout) :: crgba(4,num_pixel) + integer(kind = kint) :: i + integer :: ir, ig, ib, ia +! +!$omp parallel do private(i,ir,ig,ib,ia) + do i = 1, num_pixel + ir = int( rgba(1,i)*256.0d0) + ig = int( rgba(2,i)*256.0d0) + ib = int( rgba(3,i)*256.0d0) + ia = int( rgba(4,i)*256.0d0) +! + if(ir.lt.0) then + ir = 0 + else if(ir .gt. 255) then + ir = 255 + end if +! + if(ig.lt.0) then + ig = 0 + else if(ig .gt. 255) then + ig = 255 + end if +! + if(ib.lt.0) then + ib = 0 + else if(ib .gt. 255) then + ib = 255 + end if +! + if(ia.lt.0) then + ia = 0 + else if(ia .gt. 255) then + ia = 255 + end if +! + crgba(1,i) = char(ir) + crgba(2,i) = char(ig) + crgba(3,i) = char(ib) + crgba(4,i) = char(ia) + end do +!$omp end parallel do +! + end subroutine cvt_double_rgba_to_char_rgba +! +! --------------------------------------------------------------------- +! + subroutine set_rgb_background(num_pixel, rgba, bgcolor) +! + integer(kind = kint), intent(in) :: num_pixel + real(kind = kreal), intent(in) :: bgcolor(3) + real(kind = kreal), intent(inout) :: rgba(4,num_pixel) +! + integer(kind = kint) :: i +! +!$omp parallel do private(i) + do i = 1, num_pixel + if( rgba(1,i) .lt. (bgcolor(1)+0.004) & + & .and. rgba(2,i) .lt. (bgcolor(2)+0.004) & + & .and. rgba(3,i) .lt. (bgcolor(3)+0.004) ) then + rgba(1,i) = bgcolor(1) + rgba(2,i) = bgcolor(2) + rgba(3,i) = bgcolor(3) + end if + end do +!$omp end parallel do +! + end subroutine set_rgb_background +! +! --------------------------------------------------------------------- +! + end module convert_real_rgb_2_bite diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/count_pvr_ray_start_point.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/count_pvr_ray_start_point.f90 new file mode 100644 index 00000000..c37255f6 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/count_pvr_ray_start_point.f90 @@ -0,0 +1,303 @@ +!>@file count_pvr_ray_start_point.f90 +!!@brief module count_pvr_ray_start_point +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!>@brief Top routines to transfer spherical harmonics grids data +!! to FEM data for data visualization +!! +!!@verbatim +!! subroutine count_temporal_pvr_ray_start & +!! & (num_pvr_surf, screen_norm_pvr_domain, & +!! & isurf_xrng_pvr_domain, jsurf_yrng_pvr_domain, & +!! & ray_vec4, ntot_tmp_pvr_ray_sf, istack_tmp_pvr_ray_st) +!! subroutine count_each_pvr_ray_start(node, surf, & +!! & modelview_mat, projection_mat, npixel_x, npixel_y, & +!! & pixel_point_x, pixel_point_y,num_pvr_surf, & +!! & item_pvr_surf_domain, screen_norm_pvr_domain, & +!! & isurf_xrng_pvr_domain, jsurf_yrng_pvr_domain, ray_vec4,& +!! & num_pvr_ray, istack_pvr_ray_sf, ntot_tmp_pvr_ray, & +!! & istack_tmp_pvr_ray_st, ipix_start_tmp, iflag_start_tmp,& +!! & xi_pvr_start_tmp) +!! type(node_data), intent(in) :: node +!! type(surface_data), intent(in) :: surf +!!@endverbatim +! + module count_pvr_ray_start_point +! + use m_precision +! + use calypso_mpi + use m_constants + use m_geometry_constants + use t_control_params_4_pvr +! + implicit none +! + private :: cal_coefs_on_surf +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine count_temporal_pvr_ray_start & + & (num_pvr_surf, screen_norm_pvr_domain, & + & isurf_xrng_pvr_domain, jsurf_yrng_pvr_domain, & + & ray_vec4, ntot_tmp_pvr_ray_sf, istack_tmp_pvr_ray_st) +! + integer(kind = kint), intent(in) :: num_pvr_surf + integer(kind = kint), intent(in) & + & :: isurf_xrng_pvr_domain(2,num_pvr_surf) + integer(kind = kint), intent(in) & + & :: jsurf_yrng_pvr_domain(2,num_pvr_surf) + real(kind = kreal), intent(in) & + & :: screen_norm_pvr_domain(3,num_pvr_surf) +! + real(kind = kreal), intent(in) :: ray_vec4(4) +! + integer(kind = kint), intent(inout) :: ntot_tmp_pvr_ray_sf + integer(kind = kint), intent(inout) & + & :: istack_tmp_pvr_ray_st(0:num_pvr_surf) +! + integer(kind = kint) :: inum +! +! +!$omp parallel do private(inum) + do inum = 1, num_pvr_surf + if((screen_norm_pvr_domain(3,inum)*ray_vec4(3)) & + & .gt. SMALL_NORM) then + istack_tmp_pvr_ray_st(inum) = (isurf_xrng_pvr_domain(2,inum) & + & - isurf_xrng_pvr_domain(1,inum)+1) & + & * (jsurf_yrng_pvr_domain(2,inum) & + & - jsurf_yrng_pvr_domain(1,inum)+1) + else + istack_tmp_pvr_ray_st(inum) = 0 + end if + end do +!$omp end parallel do +! + istack_tmp_pvr_ray_st(0) = 0 + do inum = 1, num_pvr_surf + istack_tmp_pvr_ray_st(inum) = istack_tmp_pvr_ray_st(inum-1) & + & + istack_tmp_pvr_ray_st(inum) + end do + ntot_tmp_pvr_ray_sf = istack_tmp_pvr_ray_st(num_pvr_surf) +! + end subroutine count_temporal_pvr_ray_start +! +! --------------------------------------------------------------------- +! + subroutine count_each_pvr_ray_start(node, surf, & + & modelview_mat, projection_mat, npixel_x, npixel_y, & + & pixel_point_x, pixel_point_y,num_pvr_surf, & + & item_pvr_surf_domain, screen_norm_pvr_domain, & + & isurf_xrng_pvr_domain, jsurf_yrng_pvr_domain, ray_vec4, & + & num_pvr_ray, istack_pvr_ray_sf, ntot_tmp_pvr_ray, & + & istack_tmp_pvr_ray_st, ipix_start_tmp, iflag_start_tmp, & + & xi_pvr_start_tmp) +! + use t_geometry_data + use t_surface_data + use set_position_pvr_screen + use cal_fline_in_cube +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf +! + real(kind = kreal), intent(in) :: modelview_mat(4,4) + real(kind = kreal), intent(in) :: projection_mat(4,4) +! + integer(kind = kint), intent(in) :: npixel_x, npixel_y + real(kind = kreal), intent(in) :: pixel_point_x(npixel_x) + real(kind = kreal), intent(in) :: pixel_point_y(npixel_y) +! + integer(kind = kint), intent(in) :: num_pvr_surf + integer(kind = kint), intent(in) & + & :: item_pvr_surf_domain(2,num_pvr_surf) + real(kind = kreal), intent(in) & + & :: screen_norm_pvr_domain(3,num_pvr_surf) + integer(kind = kint), intent(in) & + & :: isurf_xrng_pvr_domain(2,num_pvr_surf) + integer(kind = kint), intent(in) & + & :: jsurf_yrng_pvr_domain(2,num_pvr_surf) +! + real(kind = kreal), intent(in) :: ray_vec4(4) +! + integer(kind = kint), intent(in) :: ntot_tmp_pvr_ray + integer(kind = kint), intent(in) & + & :: istack_tmp_pvr_ray_st(0:num_pvr_surf) +! + integer(kind = kint), intent(inout) :: num_pvr_ray + integer(kind = kint), intent(inout) & + & :: iflag_start_tmp(ntot_tmp_pvr_ray) + integer(kind = kint), intent(inout) & + & :: ipix_start_tmp(2,ntot_tmp_pvr_ray) + real(kind = kreal), intent(inout) & + & :: xi_pvr_start_tmp(2,ntot_tmp_pvr_ray) + integer(kind = kint), intent(inout) & + & :: istack_pvr_ray_sf(0:num_pvr_surf) +! + integer(kind = kint) :: inum, iele, k1, isurf, icou + integer(kind = kint) :: ist_pix, ied_pix, jst_pix, jed_pix + integer(kind = kint) :: ipix, jpix, iflag + real(kind = kreal) :: xx4_model_sf(4,num_linear_sf,nsurf_4_ele) + real(kind = kreal) :: x_pix(2), xi(2) +! + real(kind = kreal) :: xt1(2), a(2,2) + real(kind = kreal) :: c1(3), c3(3), aj +! +! +!$omp parallel do private(inum,iele,k1,isurf,xx4_model_sf,iflag, & +!$omp& icou,ist_pix,ied_pix,jst_pix,jed_pix,ipix,jpix,x_pix,xi, & +!$omp& xt1,a,c1,c3,aj) + do inum = 1, num_pvr_surf + istack_pvr_ray_sf(inum) = 0 + iele = item_pvr_surf_domain(1,inum) + k1 = item_pvr_surf_domain(2,inum) + isurf = abs(surf%isf_4_ele(iele,k1)) + icou = istack_tmp_pvr_ray_st(inum-1) +! + if((screen_norm_pvr_domain(3,inum)*ray_vec4(3)) & + & .gt. SMALL_NORM) then + call position_on_each_ele_sfs_wone & + & (surf, node%numnod, node%xx, iele, xx4_model_sf) + call project_once_each_element(modelview_mat, projection_mat, & + & (num_linear_sf*nsurf_4_ele), xx4_model_sf(1,1,1)) +! + ist_pix = isurf_xrng_pvr_domain(1,inum) + ied_pix = isurf_xrng_pvr_domain(2,inum) + jst_pix = jsurf_yrng_pvr_domain(1,inum) + jed_pix = jsurf_yrng_pvr_domain(2,inum) + do ipix = ist_pix, ied_pix + do jpix = jst_pix, jed_pix + icou = icou + 1 + x_pix(1) = pixel_point_x(ipix) + x_pix(2) = pixel_point_y(jpix) + ipix_start_tmp(1,icou) = ipix + ipix_start_tmp(2,icou) = jpix +! + xt1(1:2)= x_pix(1:2) - xx4_model_sf(1:2,1,k1) + a(1:2,1)= xx4_model_sf(1:2,2,k1) - xx4_model_sf(1:2,1,k1) + a(1:2,2)= xx4_model_sf(1:2,4,k1) - xx4_model_sf(1:2,1,k1) + aj = one / (a(1,1)*a(2,2) - a(2,1)*a(1,2)) +! + c1(1) = ( a(2,2)*xt1(1) - a(1,2)*xt1(2) ) * aj + c1(2) = (-a(2,1)*xt1(1) + a(1,1)*xt1(2) ) * aj +! + xt1(1:2) = x_pix(1:2) - xx4_model_sf(1:2,3,k1) + a(1:2,1) = xx4_model_sf(1:2,2,k1) - xx4_model_sf(1:2,3,k1) + a(1:2,2) = xx4_model_sf(1:2,4,k1) - xx4_model_sf(1:2,3,k1) + aj = one / (a(1,1)*a(2,2) - a(2,1)*a(1,2)) +! + c3(1) = ( a(2,2)*xt1(1) - a(1,2)*xt1(2) ) * aj + c3(2) = (-a(2,1)*xt1(1) + a(1,1)*xt1(2) ) * aj +! + c1(3) = one - (c1(1) + c1(2)) + c3(3) = one - (c3(1) + c3(2)) +! + if(c1(1).ge.zero .and. c1(2).ge.zero & + & .and. c1(3).ge.zero) then + iflag = 1 + xi(1) = -one + two*c1(1) + xi(2) = -one + two*c1(2) +! + else if(c3(1).ge.zero .and. c3(2).ge.zero & + & .and. c3(3).ge.zero) then + iflag = 1 + xi(1) = one - two*c3(2) + xi(2) = one - two*c3(1) + else + xi(1) = -two + xi(2) = -two + iflag = 0 + end if +! write(200+my_rank,*) 'cal_coefs_on_surf', iflag, xi(1:2),& +! & c1, c3 +! +! +! write(200+my_rank,*) inum, ipix, jpix, iflag, xi, & +! & x_pix, xx4_model_sf(:,:,k1) + iflag_start_tmp(icou) = iflag + xi_pvr_start_tmp(1:2,icou) = xi +! +! write(100+my_rank,*) inum, ipix, jpix, & +! & iflag_start_tmp(icou), xi_pvr_start_tmp(1:2,icou), & +! & x_pix, xx4_model_sf(:,:,k1) +! + if(iflag_start_tmp(icou) .gt. 0) then + istack_pvr_ray_sf(inum) = istack_pvr_ray_sf(inum) + 1 + end if + end do + end do + end if + end do +!$omp end parallel do +! + istack_pvr_ray_sf(0) = 0 + do inum = 1, num_pvr_surf + istack_pvr_ray_sf(inum) = istack_pvr_ray_sf(inum-1) & + & + istack_pvr_ray_sf(inum) + end do + num_pvr_ray = istack_pvr_ray_sf(num_pvr_surf) +! + end subroutine count_each_pvr_ray_start +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine cal_coefs_on_surf(x_surf, x_pix, iflag, xi) +! + real(kind = kreal), intent(in) :: x_pix(2) + real(kind = kreal), intent(in) :: x_surf(2,4) + integer(kind = kint), intent(inout) :: iflag + real(kind = kreal), intent(inout) :: xi(2) +! + real(kind = kreal) :: xt1(2), a(2,2) + real(kind = kreal) :: c1(3), c3(3), aj +! +! + xt1(1:2) = x_pix(1:2) - x_surf(1:2,1) + a(1:2,1) = x_surf(1:2,2) - x_surf(1:2,1) + a(1:2,2) = x_surf(1:2,4) - x_surf(1:2,1) + aj = one / (a(1,1)*a(2,2) - a(2,1)*a(1,2)) +! + c1(1) = ( a(2,2)*xt1(1) - a(1,2)*xt1(2) ) * aj + c1(2) = (-a(2,1)*xt1(1) + a(1,1)*xt1(2) ) * aj +! + xt1(1:2) = x_pix(1:2) - x_surf(1:2,3) + a(1:2,1) = x_surf(1:2,2) - x_surf(1:2,3) + a(1:2,2) = x_surf(1:2,4) - x_surf(1:2,3) + aj = one / (a(1,1)*a(2,2) - a(2,1)*a(1,2)) +! + c3(1) = ( a(2,2)*xt1(1) - a(1,2)*xt1(2) ) * aj + c3(2) = (-a(2,1)*xt1(1) + a(1,1)*xt1(2) ) * aj +! + c1(3) = one - (c1(1) + c1(2)) + c3(3) = one - (c3(1) + c3(2)) +! + if(c1(1).ge.zero .and. c1(2).ge.zero .and. c1(3).ge.zero) then + iflag = 1 + xi(1) = -one + two*c1(1) + xi(2) = -one + two*c1(2) +! + else if(c3(1).ge.zero .and. c3(2).ge.zero .and. c3(3).ge.zero) & + & then + iflag = 1 + xi(1) = one - two*c3(2) + xi(2) = one - two*c3(1) + else + xi(1) = -two + xi(2) = -two + iflag = 0 + end if + write(200+my_rank,*) 'cal_coefs_on_surf', iflag, xi(1:2), & + & c1, c3 +! + end subroutine cal_coefs_on_surf +! +!----------------------------------------------------------------------- +! + end module count_pvr_ray_start_point diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_each_pvr_IO.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_each_pvr_IO.f90 new file mode 100644 index 00000000..e1c774a1 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_each_pvr_IO.f90 @@ -0,0 +1,438 @@ +!>@file ctl_data_each_pvr_IO.f90 +!!@brief module ctl_data_each_pvr_IO +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data IO for parallel volume rendering +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine init_pvr_ctl_label(hd_block, pvr_ctl) +!! subroutine read_pvr_ctl(id_control, hd_block, pvr_ctl, c_buf) +!! subroutine read_pvr_update_flag & +!! & (id_control, hd_block, pvr_ctl, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_parameter_ctl), intent(inout) :: pvr_ctl +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_ctl & +!! & (id_control, hd_block, pvr_ctl, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_parameter_ctl), intent(in) :: pvr_ctl +!! integer(kind = kint), intent(inout) :: level +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! example of control for Kemo's volume rendering +!! +!!begin volume_rendering (BMP or PNG) +!! updated_sign go +!! pvr_file_prefix pvr_temp +!! pvr_output_format PNG +!! monitoring_mode YES +!! +!! stereo_imaging YES +!! anaglyph_switch NO +!! quilt_3d_imaging YES +!!! +!! output_field temperature +!! output_component scalar +!!! +!! begin plot_area_ctl +!! ... +!! end plot_area_ctl +!!! +!! begin view_transform_ctl +!! ... +!! end view_transform_ctl +!! +!! begin pvr_color_ctl +!! ... +!! end pvr_color_ctl +!!! +!! begin lighting_ctl +!! ... +!! end lighting_ctl +!! +!! begin colorbar_ctl +!! ... +!! end colorbar_ctl +!!! +!! array section_ctl +!! file surface_define ctl_psf_eq +!! begin surface_define +!! ... +!! end surface_define +!! end array section_ctl +!!! +!! array isosurface_ctl +!! begin isosurface_ctl +!! isosurf_value 0.3 +!! opacity_ctl 0.9 +!! surface_direction normal +!! end isosurface_ctl +!! ... +!! end array isosurface_ctl +!!! +!! begin quilt_image_ctl +!! ... +!! end quilt_image_ctl +!!! +!! begin snapshot_movie_ctl +!! ... +!! end snapshot_movie_ctl +!!end volume_rendering +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module ctl_data_each_pvr_IO +! + use m_precision + use calypso_mpi +! + use m_machine_parameter + use t_read_control_elements + use t_ctl_data_4_view_transfer + use t_control_array_integer + use t_control_array_character + use t_control_array_chara2real + use t_ctl_data_pvr_colormap_bar + use t_ctl_data_pvr_light + use t_control_data_pvr_sections + use t_ctl_data_quilt_image + use t_ctl_data_pvr_movie + use t_control_data_pvr_isosurfs + use t_ctl_data_pvr_area + use t_control_data_4_pvr + use skip_comment_f +! + implicit none +! +! +! 2nd level for volume_rendering +! + character(len=kchara), parameter, private & + & :: hd_pvr_updated = 'updated_sign' + character(len=kchara), parameter, private & + & :: hd_pvr_file_prefix = 'pvr_file_prefix' + character(len=kchara), parameter, private & + & :: hd_pvr_out_format = 'pvr_output_format' + character(len=kchara), parameter, private & + & :: hd_pvr_monitor = 'monitoring_mode' +! + character(len=kchara), parameter, private & + & :: hd_pvr_stereo = 'stereo_imaging' + character(len=kchara), parameter, private & + & :: hd_anaglyph_switch = 'anaglyph_switch' + character(len=kchara), parameter, private & + & :: hd_pvr_quilt_3d = 'quilt_3d_imaging' +! + character(len=kchara), parameter, private & + & :: hd_output_field_def = 'output_field' + character(len=kchara), parameter, private & + & :: hd_output_comp_def = 'output_component' +! + character(len=kchara), parameter, private & + & :: hd_view_transform = 'view_transform_ctl' + character(len=kchara), parameter, private & + & :: hd_plot_area = 'plot_area_ctl' +! + character(len=kchara), parameter, private & + & :: hd_colormap_file = 'pvr_color_ctl' + character(len=kchara), parameter, private & + & :: hd_colormap = 'colormap_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_lighting = 'lighting_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_colorbar = 'colorbar_ctl' +! +! 3rd level for surface_define +! + character(len=kchara), parameter, private & + & :: hd_pvr_sections = 'section_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_isosurf = 'isosurface_ctl' +! + character(len=kchara), parameter, private & + & :: hd_pvr_flines = 'fieldline_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_tracers = 'tracer_ctl' +! + character(len=kchara), parameter, private & + & :: hd_quilt_image = 'quilt_image_ctl' + character(len=kchara), parameter, private & + & :: hd_snapshot_movie = 'snapshot_movie_ctl' +! +! Deprecated label + character(len=kchara), parameter, private & + & :: hd_pvr_file_head = 'pvr_file_head' + character(len=kchara), parameter, private & + & :: hd_pvr_out_type = 'pvr_output_type' + character(len=kchara), parameter, private & + & :: hd_pvr_rotation = 'image_rotation_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_streo = 'streo_imaging' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_pvr_ctl(id_control, hd_block, pvr_ctl, c_buf) +! + use ctl_file_pvr_modelview_IO + use ctl_file_pvr_light_IO + use ctl_data_pvr_movie_IO + use ctl_data_view_transfer_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(pvr_parameter_ctl), intent(inout) :: pvr_ctl + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(pvr_ctl%i_pvr_ctl .gt. 0) return + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! +! + call sel_read_ctl_modelview_file(id_control, hd_view_transform, & + & izero, pvr_ctl%fname_mat_ctl, pvr_ctl%mat, c_buf) + call sel_read_ctl_pvr_colormap_file & + & (id_control, hd_colormap_file, pvr_ctl%fname_cmap_cbar_c, & + & pvr_ctl%cmap_cbar_c, c_buf) + call sel_read_ctl_pvr_light_file(id_control, hd_pvr_lighting, & + & pvr_ctl%fname_pvr_light_c, pvr_ctl%light, c_buf) +! + call read_pvr_sections_ctl(id_control, hd_pvr_sections, & + & pvr_ctl%pvr_scts_c, c_buf) + call read_pvr_isosurfs_ctl(id_control, hd_pvr_isosurf, & + & pvr_ctl%pvr_isos_c, c_buf) +! + call read_pvr_tracers_ctl(id_control, hd_pvr_flines, & + & pvr_ctl%pvr_flines_c, c_buf) + call read_pvr_tracers_ctl(id_control, hd_pvr_tracers, & + & pvr_ctl%pvr_tracers_c, c_buf) +! + call read_pvr_render_area_ctl(id_control, hd_plot_area, & + & pvr_ctl%render_area_c, c_buf) + call read_quilt_image_ctl(id_control, hd_quilt_image, & + & pvr_ctl%quilt_c, c_buf) + call read_pvr_rotation_ctl(id_control, hd_snapshot_movie, & + & pvr_ctl%movie, c_buf) + call read_pvr_rotation_ctl(id_control, hd_pvr_rotation, & + & pvr_ctl%movie, c_buf) +! +! + call read_chara_ctl_type & + & (c_buf, hd_pvr_updated, pvr_ctl%updated_ctl) +! + call read_chara_ctl_type & + & (c_buf, hd_pvr_file_prefix, pvr_ctl%file_head_ctl) + call read_chara_ctl_type & + & (c_buf, hd_pvr_file_head, pvr_ctl%file_head_ctl) +! + call read_chara_ctl_type & + & (c_buf, hd_pvr_out_format, pvr_ctl%file_fmt_ctl) + call read_chara_ctl_type & + & (c_buf, hd_pvr_out_type, pvr_ctl%file_fmt_ctl) +! + call read_chara_ctl_type & + & (c_buf, hd_pvr_monitor, pvr_ctl%monitoring_ctl) +! + call read_chara_ctl_type & + & (c_buf, hd_pvr_stereo, pvr_ctl%streo_ctl) + call read_chara_ctl_type & + & (c_buf, hd_pvr_streo, pvr_ctl%streo_ctl) +! + call read_chara_ctl_type & + & (c_buf, hd_anaglyph_switch, pvr_ctl%anaglyph_ctl) + call read_chara_ctl_type & + & (c_buf, hd_pvr_quilt_3d, pvr_ctl%quilt_ctl) +! + call read_chara_ctl_type & + & (c_buf, hd_output_field_def, pvr_ctl%pvr_field_ctl) + call read_chara_ctl_type & + & (c_buf, hd_output_comp_def, pvr_ctl%pvr_comp_ctl) + end do + pvr_ctl%i_pvr_ctl = 1 +! + end subroutine read_pvr_ctl +! +! --------------------------------------------------------------------- +! + subroutine read_pvr_update_flag & + & (id_control, hd_block, pvr_ctl, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(pvr_parameter_ctl), intent(inout) :: pvr_ctl + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(pvr_ctl%i_pvr_ctl .gt. 0) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_chara_ctl_type & + & (c_buf, hd_pvr_updated, pvr_ctl%updated_ctl) + end do + pvr_ctl%i_pvr_ctl = 1 +! + end subroutine read_pvr_update_flag +! +! --------------------------------------------------------------------- +! + subroutine write_pvr_ctl & + & (id_control, hd_block, pvr_ctl, level) +! + use ctl_file_pvr_modelview_IO + use ctl_file_pvr_light_IO + use ctl_data_pvr_movie_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_parameter_ctl), intent(in) :: pvr_ctl +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(pvr_ctl%i_pvr_ctl .le. 0) return +! + maxlen = len_trim(hd_pvr_updated) + maxlen = max(maxlen, len_trim(hd_pvr_file_prefix)) + maxlen = max(maxlen, len_trim(hd_pvr_out_format)) + maxlen = max(maxlen, len_trim(hd_pvr_monitor)) + maxlen = max(maxlen, len_trim(hd_anaglyph_switch)) + maxlen = max(maxlen, len_trim(hd_pvr_stereo)) + maxlen = max(maxlen, len_trim(hd_pvr_quilt_3d)) + maxlen = max(maxlen, len_trim(hd_output_field_def)) + maxlen = max(maxlen, len_trim(hd_output_comp_def)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_ctl%updated_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_ctl%file_head_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_ctl%file_fmt_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_ctl%monitoring_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_ctl%streo_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_ctl%anaglyph_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_ctl%quilt_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_ctl%pvr_field_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_ctl%pvr_comp_ctl) +! + call sel_write_ctl_modelview_file(id_control, hd_view_transform, & + & pvr_ctl%fname_mat_ctl, pvr_ctl%mat, level) + call write_pvr_render_area_ctl(id_control, hd_plot_area, & + & pvr_ctl%render_area_c, level) +! + call sel_write_ctl_pvr_colormap_file & + & (id_control, hd_colormap_file, pvr_ctl%fname_cmap_cbar_c, & + & pvr_ctl%cmap_cbar_c, level) + call sel_write_ctl_pvr_light_file & + & (id_control, hd_pvr_lighting, pvr_ctl%fname_pvr_light_c, & + & pvr_ctl%light, level) +! + call write_pvr_sections_ctl(id_control, hd_pvr_sections, & + & pvr_ctl%pvr_scts_c, level) + call write_pvr_isosurfs_ctl(id_control, hd_pvr_isosurf, & + & pvr_ctl%pvr_isos_c, level) +! + call write_pvr_tracers_ctl(id_control, hd_pvr_flines, & + & pvr_ctl%pvr_flines_c, level) + call write_pvr_tracers_ctl(id_control, hd_pvr_tracers, & + & pvr_ctl%pvr_tracers_c, level) +! + call write_quilt_image_ctl(id_control, hd_quilt_image, & + & pvr_ctl%quilt_c, level) + call write_pvr_rotation_ctl(id_control, hd_snapshot_movie, & + & pvr_ctl%movie, level) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_pvr_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_ctl_label(hd_block, pvr_ctl) +! + use ctl_file_pvr_modelview_IO + use ctl_file_pvr_light_IO + use ctl_data_pvr_movie_IO + use ctl_data_view_transfer_IO +! + character(len=kchara), intent(in) :: hd_block + type(pvr_parameter_ctl), intent(inout) :: pvr_ctl +! +! + pvr_ctl%block_name = hd_block + call int_pvr_render_area_ctl(hd_plot_area, pvr_ctl%render_area_c) + call init_pvr_cmap_cbar_label(hd_colormap_file, & + & pvr_ctl%cmap_cbar_c) + call init_view_transfer_ctl_label(hd_view_transform, pvr_ctl%mat) + call init_lighting_ctl_label(hd_pvr_lighting, pvr_ctl%light) + call init_pvr_sections_ctl(hd_pvr_sections, pvr_ctl%pvr_scts_c) + call init_pvr_isosurfs_ctl(hd_pvr_isosurf, pvr_ctl%pvr_isos_c) + call init_pvr_tracerss_ctl(hd_pvr_flines, pvr_ctl%pvr_flines_c) + call init_pvr_tracerss_ctl(hd_pvr_tracers, pvr_ctl%pvr_tracers_c) + call init_quilt_image_ctl_label(hd_quilt_image, pvr_ctl%quilt_c) + call init_pvr_rotation_ctl_label(hd_snapshot_movie, & + & pvr_ctl%movie) +! + call init_chara_ctl_item_label & + & (hd_pvr_updated, pvr_ctl%updated_ctl) +! + call init_chara_ctl_item_label & + & (hd_pvr_file_prefix, pvr_ctl%file_head_ctl) + call init_chara_ctl_item_label & + & (hd_pvr_file_head, pvr_ctl%file_head_ctl) +! + call init_chara_ctl_item_label & + & (hd_pvr_out_format, pvr_ctl%file_fmt_ctl) + call init_chara_ctl_item_label & + & (hd_pvr_out_type, pvr_ctl%file_fmt_ctl) +! + call init_chara_ctl_item_label & + & (hd_pvr_monitor, pvr_ctl%monitoring_ctl) +! + call init_chara_ctl_item_label & + & (hd_pvr_stereo, pvr_ctl%streo_ctl) + call init_chara_ctl_item_label & + & (hd_anaglyph_switch, pvr_ctl%anaglyph_ctl) + call init_chara_ctl_item_label & + & (hd_pvr_quilt_3d, pvr_ctl%quilt_ctl) +! + call init_chara_ctl_item_label & + & (hd_output_field_def, pvr_ctl%pvr_field_ctl) + call init_chara_ctl_item_label & + & (hd_output_comp_def, pvr_ctl%pvr_comp_ctl) +! + end subroutine init_pvr_ctl_label +! +! --------------------------------------------------------------------- +! + end module ctl_data_each_pvr_IO diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_four_vizs_IO.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_four_vizs_IO.f90 new file mode 100644 index 00000000..1fb008f0 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_four_vizs_IO.f90 @@ -0,0 +1,344 @@ +!>@file ctl_data_four_vizs_IO.f90 +!!@brief module ctl_data_four_vizs_IO +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Control data structure for visualization controls +!! +!!@verbatim +!! subroutine s_read_viz4_controls(id_control, viz4_ctls, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(vis4_controls), intent(inout) :: viz4_ctls +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_viz4_controls(id_control, viz4_ctls, level) +!! integer(kind = kint), intent(in) :: id_control +!! type(vis4_controls), intent(in) :: viz4_ctls +!! integer(kind = kint), intent(inout) :: level +!! subroutine init_viz4_ctl_label(hd_block, viz4_ctls) +!! character(len=kchara), intent(in) :: hd_block +!! type(vis4_controls), intent(inout) :: viz4_ctls +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! begin visual_control +!! array cross_section_ctl +!! .... +!! end array cross_section_ctl +!! +!! array isosurface_ctl +!! .... +!! end array isosurface_ctl +!! +!! array map_rendering_ctl +!! .... +!! end array map_rendering_ctl +!! +!! array volume_rendering +!! .... +!! end array volume_rendering +!! +!! array fieldline +!! .... +!! end array fieldline +!! end visual_control +! +!! delta_t_sectioning_ctl 1.0e-3 +!! i_step_sectioning_ctl 400 +!! delta_t_isosurface_ctl 1.0e-3 +!! i_step_isosurface_ctl 400 +!! delta_t_map_projection_ctl 1.0e-3 +!! i_step_map_projection_ctl 400 +!! delta_t_pvr_ctl 1.0e-2 +!! i_step_pvr_ctl 400 +!! delta_t_fline_ctl 1.0e-1 +!! i_step_fline_ctl 400 +!! delta_t_field_ctl 1.0e-3 +!! i_step_field_ctl 800 +!! output_field_file_fmt_ctl 'VTK' +!! end visual_control +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! +! + module ctl_data_four_vizs_IO +! + use m_precision +! + use m_machine_parameter + use calypso_mpi + use t_control_data_viz4 + use t_control_data_sections + use t_control_data_isosurfaces + use t_control_data_pvrs + use t_control_data_flines + use t_control_array_character + use t_control_array_real + use t_control_array_integer +! + implicit none +! +! Top level + character(len=kchara), parameter, private & + & :: hd_section_ctl = 'cross_section_ctl' + character(len=kchara), parameter, private & + & :: hd_isosurf_ctl = 'isosurface_ctl' + character(len=kchara), parameter, private & + & :: hd_map_rendering = 'map_rendering_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_ctl = 'volume_rendering' + character(len=kchara), parameter, private & + & :: hd_fline_ctl = 'fieldline' +! + character(len=kchara), parameter, private & + & :: hd_i_step_section = 'i_step_sectioning_ctl' + character(len=kchara), parameter, private & + & :: hd_i_step_isosurf = 'i_step_isosurface_ctl' + character(len=kchara), parameter, private & + & :: hd_i_step_map_projection = 'i_step_map_projection_ctl' + character(len=kchara), parameter, private & + & :: hd_i_step_pvr = 'i_step_pvr_ctl' + character(len=kchara), parameter, private & + & :: hd_i_step_lic = 'i_step_LIC_ctl' + character(len=kchara), parameter, private & + & :: hd_i_step_fline = 'i_step_fline_ctl' +! + character(len=kchara), parameter, private & + & :: hd_i_step_ucd = 'i_step_field_ctl' +! + character(len=kchara), parameter, private & + & :: hd_delta_t_section = 'delta_t_sectioning_ctl' + character(len=kchara), parameter, private & + & :: hd_delta_t_isosurf = 'delta_t_isosurface_ctl' + character(len=kchara), parameter, private & + & :: hd_delta_t_map_projection = 'delta_t_map_projection_ctl' + character(len=kchara), parameter, private & + & :: hd_delta_t_pvr = 'delta_t_pvr_ctl' + character(len=kchara), parameter, private & + & :: hd_delta_t_lic = 'delta_t_LIC_ctl' + character(len=kchara), parameter, private & + & :: hd_delta_t_fline = 'delta_t_fline_ctl' +! + character(len=kchara), parameter, private & + & :: hd_delta_t_ucd = 'delta_t_field_ctl' + character(len=kchara), parameter, private & + & :: hd_output_fld_file_fmt = 'output_field_file_fmt_ctl' +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_read_viz4_controls & + & (id_control, hd_block, viz4_ctls, c_buf) +! + use t_read_control_elements + use ctl_file_sections_IO + use ctl_file_isosurfaces_IO + use ctl_file_map_renderings_IO + use ctl_file_fieldlines_IO + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(vis4_controls), intent(inout) :: viz4_ctls + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(viz4_ctls%i_viz_control .gt. 0) return + call init_psf_ctls_labels(hd_section_ctl, viz4_ctls%psf_ctls) + call init_iso_ctls_labels(hd_isosurf_ctl, viz4_ctls%iso_ctls) + call init_map_ctls_labels(hd_map_rendering, viz4_ctls%map_ctls) + call init_pvr_ctls_labels(hd_pvr_ctl, viz4_ctls%pvr_ctls) + call init_fline_ctl_struct(hd_fline_ctl, viz4_ctls%fline_ctls) + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_files_4_psf_ctl(id_control, hd_section_ctl, & + & viz4_ctls%psf_ctls, c_buf) + call read_files_4_iso_ctl(id_control, hd_isosurf_ctl, & + & viz4_ctls%iso_ctls, c_buf) + call read_files_4_map_ctl(id_control, hd_map_rendering, & + & viz4_ctls%map_ctls, c_buf) +! + call read_files_4_pvr_ctl(id_control, hd_pvr_ctl, & + & viz4_ctls%pvr_ctls, c_buf) +! + call read_files_4_fline_ctl(id_control, hd_fline_ctl, & + & viz4_ctls%fline_ctls, c_buf) +! +! + call read_integer_ctl_type(c_buf, hd_i_step_section, & + & viz4_ctls%i_step_psf_v_ctl) + call read_integer_ctl_type(c_buf, hd_i_step_isosurf, & + & viz4_ctls%i_step_iso_v_ctl) + call read_integer_ctl_type(c_buf, hd_i_step_map_projection, & + & viz4_ctls%i_step_map_v_ctl) + call read_integer_ctl_type(c_buf, hd_i_step_pvr, & + & viz4_ctls%i_step_pvr_v_ctl) + call read_integer_ctl_type(c_buf, hd_i_step_fline, & + & viz4_ctls%i_step_fline_v_ctl) + call read_integer_ctl_type(c_buf, hd_i_step_ucd, & + & viz4_ctls%i_step_ucd_v_ctl) +! + call read_real_ctl_type(c_buf, hd_delta_t_section, & + & viz4_ctls%delta_t_psf_v_ctl) + call read_real_ctl_type(c_buf, hd_delta_t_isosurf, & + & viz4_ctls%delta_t_iso_v_ctl) + call read_real_ctl_type(c_buf, hd_delta_t_map_projection, & + & viz4_ctls%delta_t_map_v_ctl) + call read_real_ctl_type(c_buf, hd_delta_t_pvr, & + & viz4_ctls%delta_t_pvr_v_ctl) + call read_real_ctl_type(c_buf, hd_delta_t_fline, & + & viz4_ctls%delta_t_fline_v_ctl) + call read_real_ctl_type(c_buf, hd_delta_t_ucd, & + & viz4_ctls%delta_t_ucd_v_ctl) +! + call read_chara_ctl_type(c_buf, hd_output_fld_file_fmt, & + & viz4_ctls%output_field_file_fmt_ctl) + end do + viz4_ctls%i_viz_control = 1 +! + end subroutine s_read_viz4_controls +! +! --------------------------------------------------------------------- +! + subroutine write_viz4_controls(id_control, viz4_ctls, level) +! + use t_read_control_elements + use ctl_file_sections_IO + use ctl_file_isosurfaces_IO + use ctl_file_map_renderings_IO + use ctl_file_fieldlines_IO + use write_control_elements + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + type(vis4_controls), intent(in) :: viz4_ctls +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(viz4_ctls%i_viz_control .le. 0) return +! + maxlen = len_trim(hd_delta_t_section) + maxlen = max(maxlen, len_trim(hd_i_step_section)) + maxlen = max(maxlen, len_trim(hd_delta_t_isosurf)) + maxlen = max(maxlen, len_trim(hd_i_step_isosurf)) + maxlen = max(maxlen, len_trim(hd_delta_t_map_projection)) + maxlen = max(maxlen, len_trim(hd_i_step_map_projection)) + maxlen = max(maxlen, len_trim(hd_delta_t_pvr)) + maxlen = max(maxlen, len_trim(hd_i_step_pvr)) + maxlen = max(maxlen, len_trim(hd_delta_t_fline)) + maxlen = max(maxlen, len_trim(hd_i_step_fline)) + maxlen = max(maxlen, len_trim(hd_delta_t_ucd)) + maxlen = max(maxlen, len_trim(hd_i_step_ucd)) +! + level = write_begin_flag_for_ctl(id_control, level, & + & viz4_ctls%block_name) + call write_real_ctl_type(id_control, level, maxlen, & + & viz4_ctls%delta_t_psf_v_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & viz4_ctls%i_step_psf_v_ctl) + call write_files_4_psf_ctl(id_control, hd_section_ctl, & + & viz4_ctls%psf_ctls, level) +! + call write_real_ctl_type(id_control, level, maxlen, & + & viz4_ctls%delta_t_iso_v_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & viz4_ctls%i_step_iso_v_ctl) + call write_files_4_iso_ctl(id_control, hd_isosurf_ctl, & + & viz4_ctls%iso_ctls, level) +! + call write_real_ctl_type(id_control, level, maxlen, & + & viz4_ctls%delta_t_map_v_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & viz4_ctls%i_step_map_v_ctl) + call write_files_4_map_ctl(id_control, hd_map_rendering, & + & viz4_ctls%map_ctls, level) +! + call write_real_ctl_type(id_control, level, maxlen, & + & viz4_ctls%delta_t_pvr_v_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & viz4_ctls%i_step_pvr_v_ctl) + call write_files_4_pvr_ctl(id_control, hd_pvr_ctl, & + & viz4_ctls%pvr_ctls, level) +! + call write_real_ctl_type(id_control, level, maxlen, & + & viz4_ctls%delta_t_fline_v_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & viz4_ctls%i_step_fline_v_ctl) + call write_files_4_fline_ctl(id_control, hd_fline_ctl, & + & viz4_ctls%fline_ctls, level) +! + call write_real_ctl_type(id_control, level, maxlen, & + & viz4_ctls%delta_t_ucd_v_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & viz4_ctls%i_step_ucd_v_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & viz4_ctls%output_field_file_fmt_ctl) + level = write_end_flag_for_ctl(id_control, level, & + & viz4_ctls%block_name) +! + end subroutine write_viz4_controls +! +! --------------------------------------------------------------------- +! + subroutine init_viz4_ctl_label(hd_block, viz4_ctls) +! + use ctl_file_sections_IO + use ctl_file_isosurfaces_IO + use ctl_file_map_renderings_IO + use ctl_file_fieldlines_IO +! + character(len=kchara), intent(in) :: hd_block + type(vis4_controls), intent(inout) :: viz4_ctls +! +! + viz4_ctls%block_name = hd_block + call init_psf_ctls_labels(hd_section_ctl, viz4_ctls%psf_ctls) + call init_iso_ctls_labels(hd_isosurf_ctl, viz4_ctls%iso_ctls) + call init_map_ctls_labels(hd_map_rendering, viz4_ctls%map_ctls) + call init_pvr_ctls_labels(hd_pvr_ctl, viz4_ctls%pvr_ctls) + call init_fline_ctl_struct(hd_fline_ctl, viz4_ctls%fline_ctls) +! + call init_int_ctl_item_label(hd_i_step_section, & + & viz4_ctls%i_step_psf_v_ctl) + call init_int_ctl_item_label(hd_i_step_isosurf, & + & viz4_ctls%i_step_iso_v_ctl) + call init_int_ctl_item_label(hd_i_step_map_projection, & + & viz4_ctls%i_step_map_v_ctl) + call init_int_ctl_item_label(hd_i_step_pvr, & + & viz4_ctls%i_step_pvr_v_ctl) + call init_int_ctl_item_label(hd_i_step_fline, & + & viz4_ctls%i_step_fline_v_ctl) + call init_int_ctl_item_label(hd_i_step_ucd, & + & viz4_ctls%i_step_ucd_v_ctl) +! + call init_real_ctl_item_label(hd_delta_t_section, & + & viz4_ctls%delta_t_psf_v_ctl) + call init_real_ctl_item_label(hd_delta_t_isosurf, & + & viz4_ctls%delta_t_iso_v_ctl) + call init_real_ctl_item_label(hd_delta_t_map_projection, & + & viz4_ctls%delta_t_map_v_ctl) + call init_real_ctl_item_label(hd_delta_t_pvr, & + & viz4_ctls%delta_t_pvr_v_ctl) + call init_real_ctl_item_label(hd_delta_t_fline, & + & viz4_ctls%delta_t_fline_v_ctl) + call init_real_ctl_item_label(hd_delta_t_ucd, & + & viz4_ctls%delta_t_ucd_v_ctl) +! + call init_chara_ctl_item_label(hd_output_fld_file_fmt, & + & viz4_ctls%output_field_file_fmt_ctl) +! + end subroutine init_viz4_ctl_label +! +! --------------------------------------------------------------------- +! + end module ctl_data_four_vizs_IO diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_pvr_colorbar_IO.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_pvr_colorbar_IO.f90 new file mode 100644 index 00000000..d6f5efa5 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_pvr_colorbar_IO.f90 @@ -0,0 +1,237 @@ +!>@file ctl_data_pvr_colorbar_IO.f90 +!!@brief module ctl_data_pvr_colorbar_IO +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief colormap control data for parallel volume rendering +!! +!!@verbatim +!! subroutine init_pvr_colorbar_ctl_label(hd_block, cbar_ctl) +!! subroutine read_pvr_colorbar_ctl & +!! & (id_control, hd_block, cbar_ctl, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_colorbar_ctl), intent(inout) :: cbar_ctl +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_colorbar_ctl & +!! & (id_control, hd_block, cbar_ctl, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_colorbar_ctl), intent(in) :: cbar_ctl +!! integer(kind = kint), intent(inout) :: level +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! example of color control for Kemo's volume rendering +!! +!!begin volume_rendering (BMP or PNG) +!! begin colorbar_ctl +!! colorbar_switch_ctl ON +!! colorbar_scale_ctl ON +!! colorbar_position_ctl 'side' or 'bottom' +!! zeromarker_switch ON +!! colorbar_range 0.0 1.0 +!! font_size_ctl 3 +!! num_grid_ctl 4 +!!! +!! axis_label_switch ON +!! time_label_switch ON +!! map_grid_switch ON +!! end colorbar_ctl +!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module ctl_data_pvr_colorbar_IO +! + use m_precision + use calypso_mpi +! + use m_machine_parameter + use t_read_control_elements + use t_ctl_data_4_view_transfer + use t_control_array_character + use t_control_array_integer + use t_control_array_real2 + use t_ctl_data_pvr_colorbar + use skip_comment_f +! + implicit none +! + character(len=kchara), parameter, private & + & :: hd_colorbar_switch = 'colorbar_switch_ctl' + character(len=kchara), parameter, private & + & :: hd_colorbar_scale = 'colorbar_scale_ctl' + character(len=kchara), parameter, private & + & :: hd_cbar_position = 'colorbar_position_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_font_size = 'font_size_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_numgrid_cbar = 'num_grid_ctl' + character(len=kchara), parameter, private & + & :: hd_zeromarker_switch = 'zeromarker_switch' + character(len=kchara), parameter, private & + & :: hd_cbar_range = 'colorbar_range' +! + character(len=kchara), parameter, private & + & :: hd_axis_switch = 'axis_label_switch' + character(len=kchara), parameter, private & + & :: hd_time_switch = 'time_label_switch' + character(len=kchara), parameter, private & + & :: hd_mapgrid_switch = 'map_grid_switch' +! +! Deprecated label + character(len=kchara), parameter, private & + & :: hd_zeromarker_flag = 'iflag_zeromarker' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_pvr_colorbar_ctl & + & (id_control, hd_block, cbar_ctl, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(pvr_colorbar_ctl), intent(inout) :: cbar_ctl + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(cbar_ctl%i_pvr_colorbar .gt. 0) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_integer_ctl_type & + & (c_buf, hd_pvr_font_size, cbar_ctl%font_size_ctl) + call read_integer_ctl_type(c_buf, hd_pvr_numgrid_cbar, & + & cbar_ctl%ngrid_cbar_ctl) +! +! + call read_chara_ctl_type(c_buf, hd_colorbar_switch, & + & cbar_ctl%colorbar_switch_ctl) + call read_chara_ctl_type(c_buf, hd_colorbar_scale, & + & cbar_ctl%colorbar_scale_ctl) + call read_chara_ctl_type(c_buf, hd_cbar_position, & + & cbar_ctl%colorbar_position_ctl) +! + call read_chara_ctl_type(c_buf, hd_zeromarker_switch, & + & cbar_ctl%zeromarker_flag_ctl) + call read_chara_ctl_type(c_buf, hd_zeromarker_flag, & + & cbar_ctl%zeromarker_flag_ctl) +! + call read_chara_ctl_type(c_buf, hd_axis_switch, & + & cbar_ctl%axis_switch_ctl) + call read_chara_ctl_type(c_buf, hd_time_switch, & + & cbar_ctl%time_switch_ctl) + call read_chara_ctl_type(c_buf, hd_mapgrid_switch, & + & cbar_ctl%mapgrid_switch_ctl) +! + call read_real2_ctl_type(c_buf, & + & hd_cbar_range, cbar_ctl%cbar_range_ctl) + end do + cbar_ctl%i_pvr_colorbar = 1 +! + end subroutine read_pvr_colorbar_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_pvr_colorbar_ctl & + & (id_control, hd_block, cbar_ctl, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_colorbar_ctl), intent(in) :: cbar_ctl +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(cbar_ctl%i_pvr_colorbar .le. 0) return +! + maxlen = len_trim(hd_colorbar_switch) + maxlen = max(maxlen, len_trim(hd_pvr_font_size)) + maxlen = max(maxlen, len_trim(hd_pvr_numgrid_cbar)) + maxlen = max(maxlen, len_trim(hd_colorbar_scale)) + maxlen = max(maxlen, len_trim(hd_cbar_position)) + maxlen = max(maxlen, len_trim(hd_zeromarker_switch)) + maxlen = max(maxlen, len_trim(hd_axis_switch)) + maxlen = max(maxlen, len_trim(hd_time_switch)) + maxlen = max(maxlen, len_trim(hd_mapgrid_switch)) + maxlen = max(maxlen, len_trim(hd_cbar_range)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & cbar_ctl%colorbar_switch_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & cbar_ctl%colorbar_scale_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & cbar_ctl%colorbar_position_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & cbar_ctl%zeromarker_flag_ctl) + call write_real2_ctl_type(id_control, level, maxlen, & + & cbar_ctl%cbar_range_ctl) +! + call write_integer_ctl_type(id_control, level, maxlen, & + & cbar_ctl%font_size_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & cbar_ctl%ngrid_cbar_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & cbar_ctl%axis_switch_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & cbar_ctl%time_switch_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & cbar_ctl%mapgrid_switch_ctl) +! + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_pvr_colorbar_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_colorbar_ctl_label(hd_block, cbar_ctl) +! + character(len=kchara), intent(in) :: hd_block + type(pvr_colorbar_ctl), intent(inout) :: cbar_ctl +! +! + cbar_ctl%block_name = hd_block + call init_int_ctl_item_label & + & (hd_pvr_font_size, cbar_ctl%font_size_ctl) + call init_int_ctl_item_label(hd_pvr_numgrid_cbar, & + & cbar_ctl%ngrid_cbar_ctl) +! +! + call init_chara_ctl_item_label(hd_colorbar_switch, & + & cbar_ctl%colorbar_switch_ctl) + call init_chara_ctl_item_label(hd_colorbar_scale, & + & cbar_ctl%colorbar_scale_ctl) + call init_chara_ctl_item_label(hd_cbar_position, & + & cbar_ctl%colorbar_position_ctl) + call init_chara_ctl_item_label(hd_zeromarker_switch, & + & cbar_ctl%zeromarker_flag_ctl) +! + call init_chara_ctl_item_label(hd_axis_switch, & + & cbar_ctl%axis_switch_ctl) + call init_chara_ctl_item_label(hd_time_switch, & + & cbar_ctl%time_switch_ctl) + call init_chara_ctl_item_label(hd_mapgrid_switch, & + & cbar_ctl%mapgrid_switch_ctl) +! + call init_real2_ctl_item_label & + & (hd_cbar_range, cbar_ctl%cbar_range_ctl) +! + end subroutine init_pvr_colorbar_ctl_label +! +! --------------------------------------------------------------------- +! + end module ctl_data_pvr_colorbar_IO diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_pvr_colormap_IO.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_pvr_colormap_IO.f90 new file mode 100644 index 00000000..0586d5a6 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_pvr_colormap_IO.f90 @@ -0,0 +1,276 @@ +!>@file ctl_data_pvr_colormap_IO.f90 +!!@brief module ctl_data_pvr_colormap_IO +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief colormap control data for parallel volume rendering +!! +!!@verbatim +!! subroutine init_pvr_colordef_ctl_labels(hd_block, color) +!! subroutine read_pvr_colordef_ctl & +!! & (id_control, hd_block, color, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_colormap_ctl), intent(inout) :: color +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_colordef_ctl & +!! & (id_control, hd_block, color, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_colormap_ctl), intent(in) :: color +!! integer(kind = kint), intent(inout) :: level +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! example of color control for Kemo's volume rendering +!! +!! begin colormap_ctl +!! colormap_mode_ctl rainbow +!! background_color_ctl 0.0 0.0 0.0 +!!! +!! LIC_color_field magnetic_field +!! LIC_color_componenet magnitude +!! +!! LIC_transparent_field magnetic_field +!! LIC_transparent_componenet magnitude +!!! +!! data_mapping_ctl Colormap_list +!! array color_table_ctl 3 +!! color_table_ctl 0.0 0.0 +!! color_table_ctl 0.5 0.5 +!! color_table_ctl 1.0 1.0 +!! end array color_table_ctl +!!! +!! opacity_style_ctl point_linear +!! array linear_opacity_ctl 7 +!! linear_opacity_ctl 0.0 0.01 +!! linear_opacity_ctl 0.01 0.015 +!! linear_opacity_ctl 0.2 0.02 +!! linear_opacity_ctl 0.6 0.04 +!! linear_opacity_ctl 0.7 0.03 +!! linear_opacity_ctl 0.85 0.01 +!! linear_opacity_ctl 0.95 0.001 +!! end array linear_opacity_ctl +!! constant_opacity_ctl 0.003 +!!! +!! range_min_ctl 0.0 +!! range_max_ctl 1.0 +!! end colormap_ctl +!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module ctl_data_pvr_colormap_IO +! + use m_precision + use calypso_mpi +! + use m_machine_parameter + use t_read_control_elements + use t_ctl_data_4_view_transfer + use t_control_array_character + use t_control_array_real + use t_control_array_real2 + use t_control_array_real3 + use t_ctl_data_pvr_colormap + use skip_comment_f +! + implicit none +! +! 3rd level for colormap +! + character(len=kchara), parameter, private & + & :: hd_colormap_mode = 'colormap_mode_ctl' + character(len=kchara), parameter, private & + & :: hd_background_color = 'background_color_ctl' +! + character(len=kchara), parameter, private & + & :: hd_lic_color_fld = 'LIC_color_field' + character(len=kchara), parameter, private & + & :: hd_lic_color_comp = 'LIC_color_componenet' + character(len=kchara), parameter, private & + & :: hd_lic_opacity_fld = 'LIC_transparent_field' + character(len=kchara), parameter, private & + & :: hd_lic_opacity_comp = 'LIC_transparent_componenet' +! + character(len=kchara), parameter, private & + & :: hd_data_mapping = 'data_mapping_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_range_min = 'range_min_ctl' + character(len=kchara), parameter, private & + & :: hd_pvr_range_max = 'range_max_ctl' + character(len=kchara), parameter, private & + & :: hd_colortable = 'color_table_ctl' + character(len=kchara), parameter, private & + & :: hd_opacity_style = 'opacity_style_ctl' + character(len=kchara), parameter, private & + & :: hd_constant_opacity = 'constant_opacity_ctl' + character(len=kchara), parameter, private & + & :: hd_linear_opacity = 'linear_opacity_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_pvr_colordef_ctl & + & (id_control, hd_block, color, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(pvr_colormap_ctl), intent(inout) :: color + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(color%i_pvr_colordef.gt.0) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! +! + call read_control_array_r2(id_control, hd_colortable, & + & color%colortbl_ctl, c_buf) + call read_control_array_r2(id_control, hd_linear_opacity, & + & color%linear_opacity_ctl, c_buf) +! + call read_chara_ctl_type & + & (c_buf, hd_lic_color_fld, color%lic_color_fld_ctl) + call read_chara_ctl_type & + & (c_buf, hd_lic_color_comp, color%lic_color_comp_ctl) + call read_chara_ctl_type & + & (c_buf, hd_lic_opacity_fld, color%lic_opacity_fld_ctl) + call read_chara_ctl_type & + & (c_buf, hd_lic_opacity_comp, color%lic_opacity_comp_ctl) +! + call read_chara_ctl_type & + & (c_buf, hd_colormap_mode, color%colormap_mode_ctl) + call read_chara_ctl_type & + & (c_buf, hd_data_mapping, color%data_mapping_ctl) + call read_chara_ctl_type(c_buf, hd_opacity_style, & + & color%opacity_style_ctl) +! + call read_real_ctl_type(c_buf, hd_pvr_range_min, & + & color%range_min_ctl) + call read_real_ctl_type(c_buf, hd_pvr_range_max, & + & color%range_max_ctl) + call read_real_ctl_type(c_buf, hd_constant_opacity, & + & color%fix_opacity_ctl) + call read_real3_ctl_type & + & (c_buf, hd_background_color, color%background_color_ctl) + end do + color%i_pvr_colordef = 1 +! + end subroutine read_pvr_colordef_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_pvr_colordef_ctl & + & (id_control, hd_block, color, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_colormap_ctl), intent(in) :: color +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(color%i_pvr_colordef .le. 0) return +! + maxlen = len_trim(hd_lic_color_fld) + maxlen = max(maxlen, len_trim(hd_lic_color_comp)) + maxlen = max(maxlen, len_trim(hd_lic_opacity_fld)) + maxlen = max(maxlen, len_trim(hd_lic_opacity_comp)) + maxlen = max(maxlen, len_trim(hd_data_mapping)) + maxlen = max(maxlen, len_trim(hd_opacity_style)) + maxlen = max(maxlen, len_trim(hd_constant_opacity)) + maxlen = max(maxlen, len_trim(hd_pvr_range_min)) + maxlen = max(maxlen, len_trim(hd_pvr_range_max)) + maxlen = max(maxlen, len_trim(hd_colormap_mode)) + maxlen = max(maxlen, len_trim(hd_background_color)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_chara_ctl_type(id_control, level, maxlen, & + & color%colormap_mode_ctl) + call write_real3_ctl_type(id_control, level, maxlen, & + & color%background_color_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & color%lic_color_fld_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & color%lic_color_comp_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & color%lic_opacity_fld_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & color%lic_opacity_comp_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & color%data_mapping_ctl) + call write_control_array_r2(id_control, level, & + & color%colortbl_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & color%opacity_style_ctl) + call write_control_array_r2(id_control, level, & + & color%linear_opacity_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & color%fix_opacity_ctl) +! + call write_real_ctl_type(id_control, level, maxlen, & + & color%range_min_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & color%range_max_ctl) +! + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_pvr_colordef_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_colordef_ctl_labels(hd_block, color) +! + character(len=kchara), intent(in) :: hd_block + type(pvr_colormap_ctl), intent(inout) :: color +! +! + color%block_name = hd_block + call init_r2_ctl_array_label(hd_colortable, & + & color%colortbl_ctl) + call init_r2_ctl_array_label(hd_linear_opacity, & + & color%linear_opacity_ctl) +! + call init_chara_ctl_item_label & + & (hd_lic_color_fld, color%lic_color_fld_ctl) + call init_chara_ctl_item_label & + & (hd_lic_color_comp, color%lic_color_comp_ctl) + call init_chara_ctl_item_label & + & (hd_lic_opacity_fld, color%lic_opacity_fld_ctl) + call init_chara_ctl_item_label & + & (hd_lic_opacity_comp, color%lic_opacity_comp_ctl) +! + call init_chara_ctl_item_label & + & (hd_colormap_mode, color%colormap_mode_ctl) + call init_chara_ctl_item_label & + & (hd_data_mapping, color%data_mapping_ctl) + call init_chara_ctl_item_label(hd_opacity_style, & + & color%opacity_style_ctl) +! + call init_real_ctl_item_label(hd_pvr_range_min, & + & color%range_min_ctl) + call init_real_ctl_item_label(hd_pvr_range_max, & + & color%range_max_ctl) + call init_real_ctl_item_label(hd_constant_opacity, & + & color%fix_opacity_ctl) + call init_real3_ctl_item_label & + & (hd_background_color, color%background_color_ctl) +! + end subroutine init_pvr_colordef_ctl_labels +! +! --------------------------------------------------------------------- +! + end module ctl_data_pvr_colormap_IO diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_pvr_movie_IO.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_pvr_movie_IO.f90 new file mode 100644 index 00000000..808dad58 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_pvr_movie_IO.f90 @@ -0,0 +1,250 @@ +!>@file ctl_data_pvr_movie_IO.f90 +!!@brief module ctl_data_pvr_movie_IO +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for PVR movie from snapshot +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine init_pvr_rotation_ctl_label(hd_block, movie) +!! subroutine read_pvr_rotation_ctl & +!! & (id_control, hd_block, movie, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_movie_ctl), intent(inout) :: movie +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_rotation_ctl & +!! & (id_control, hd_block, movie, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_movie_ctl), intent(in) :: movie +!! integer(kind = kint), intent(inout) :: level +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Avaiable parameters for movie_mode_ctl: +!! rotation, zoom, view_matrices, LIC_kernel, looking_glass +!! +!! begin snapshot_movie_ctl +!! movie_mode_ctl rotation +!! num_frames_ctl 120 +!! +!! rotation_axis_ctl z +!! +!! file start_view_control 'ctl_view_start' +!! file end_view_control 'ctl_view_end' +!! +!! array view_transform_ctl +!! file view_transform_ctl control_view +!! +!! begin view_transform_ctl +!! .. +!! end +!! end array view_transform_ctl +!! +!! angle_range 0.0 360.0 +!! apature_range 10.0 1.0 +!! +!! LIC_kernel_peak_range -0.8 0.8 +!! end snapshot_movie_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! movie_mode_ctl: view_matrices, rotation, apature, LIC_kernel +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module ctl_data_pvr_movie_IO +! + use m_precision + use calypso_mpi +! + use m_machine_parameter + use t_read_control_elements + use t_control_data_4_psf + use t_control_array_character + use t_control_array_integer + use t_control_array_real2 + use t_control_array_integer2 + use t_ctl_data_4_view_transfer + use t_ctl_data_view_transfers + use t_ctl_data_pvr_movie + use skip_comment_f +! + implicit none +! +! +! +! 3rd level for movie +! + character(len=kchara), parameter, private & + & :: hd_movie_mode = 'movie_mode_ctl' + character(len=kchara), parameter, private & + & :: hd_movie_num_frame = 'num_frames_ctl' +! + character(len=kchara), parameter, private & + & :: hd_movie_rot_axis = 'rotation_axis_ctl' +! + character(len=kchara), parameter, private & + & :: hd_start_view_control = 'start_view_control' + character(len=kchara), parameter, private & + & :: hd_end_view_control = 'end_view_control' + character(len=kchara), parameter, private & + & :: hd_mview_transform = 'view_transform_ctl' +! + character(len=kchara), parameter, private & + & :: hd_angle_range = 'angle_range' + character(len=kchara), parameter, private & + & :: hd_apature_range = 'apature_range' + character(len=kchara), parameter, private & + & :: hd_LIC_kernel_peak = 'LIC_kernel_peak_range' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_pvr_rotation_ctl & + & (id_control, hd_block, movie, c_buf) +! + use ctl_file_pvr_modelview_IO + use write_control_elements + use ctl_data_view_transfer_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_movie_ctl), intent(inout) :: movie + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(movie%i_pvr_rotation.gt.0) return + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call sel_read_ctl_modelview_file & + & (id_control, hd_start_view_control, izero, & + & movie%fname_view_start_ctl, movie%view_start_ctl, c_buf) + call sel_read_ctl_modelview_file & + & (id_control, hd_end_view_control, izero, & + & movie%fname_view_end_ctl, movie%view_end_ctl, c_buf) +! + call read_chara_ctl_type(c_buf, hd_movie_mode, & + & movie%movie_mode_ctl) +! + call read_integer_ctl_type(c_buf, hd_movie_num_frame, & + & movie%num_frames_ctl) + call read_chara_ctl_type(c_buf, hd_movie_rot_axis, & + & movie%rotation_axis_ctl) +! + call read_real2_ctl_type(c_buf, hd_angle_range, & + & movie%angle_range_ctl) + call read_real2_ctl_type(c_buf, hd_apature_range, & + & movie%apature_range_ctl) + call read_real2_ctl_type(c_buf, hd_LIC_kernel_peak, & + & movie%LIC_kernel_peak_range_ctl) +! + call read_mul_view_transfer_ctl & + & (id_control, hd_mview_transform, movie%mul_mmats_c, c_buf) + end do + movie%i_pvr_rotation = 1 +! + end subroutine read_pvr_rotation_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_pvr_rotation_ctl & + & (id_control, hd_block, movie, level) +! + use ctl_file_pvr_modelview_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_movie_ctl), intent(in) :: movie +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(movie%i_pvr_rotation .le. 0) return +! + maxlen = len_trim(hd_movie_mode) + maxlen = max(maxlen, len_trim(hd_movie_rot_axis)) + maxlen = max(maxlen, len_trim(hd_angle_range)) + maxlen = max(maxlen, len_trim(hd_apature_range)) + maxlen = max(maxlen, len_trim(hd_LIC_kernel_peak)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_chara_ctl_type(id_control, level, maxlen, & + & movie%movie_mode_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & movie%num_frames_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & movie%rotation_axis_ctl) +! + write(*,'(2a)', ADVANCE='NO') '! ', trim(hd_start_view_control) + call sel_write_ctl_modelview_file & + & (id_control, hd_start_view_control, & + & movie%fname_view_start_ctl, movie%view_start_ctl, level) + write(*,'(2a)', ADVANCE='NO') '! ', trim(hd_end_view_control) + call sel_write_ctl_modelview_file & + & (id_control, hd_end_view_control, & + & movie%fname_view_end_ctl, movie%view_end_ctl, level) +! + call write_mul_view_transfer_ctl & + & (id_control, hd_mview_transform, movie%mul_mmats_c, level) +! + call write_real2_ctl_type(id_control, level, maxlen, & + & movie%angle_range_ctl) + call write_real2_ctl_type(id_control, level, maxlen, & + & movie%apature_range_ctl) + call write_real2_ctl_type(id_control, level, maxlen, & + & movie%LIC_kernel_peak_range_ctl) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_pvr_rotation_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_rotation_ctl_label(hd_block, movie) +! + use ctl_file_pvr_modelview_IO + use ctl_data_view_transfer_IO +! + character(len=kchara), intent(in) :: hd_block + type(pvr_movie_ctl), intent(inout) :: movie +! +! + movie%block_name = hd_block + call init_view_transfer_ctl_label(hd_start_view_control, & + & movie%view_start_ctl) + call init_view_transfer_ctl_label(hd_end_view_control, & + & movie%view_end_ctl) + call init_multi_modeview_ctl(hd_mview_transform, & + & movie%mul_mmats_c) +! + call init_chara_ctl_item_label(hd_movie_mode, & + & movie%movie_mode_ctl) +! + call init_int_ctl_item_label(hd_movie_num_frame, & + & movie%num_frames_ctl) + call init_chara_ctl_item_label(hd_movie_rot_axis, & + & movie%rotation_axis_ctl) +! + call init_real2_ctl_item_label(hd_angle_range, & + & movie%angle_range_ctl) + call init_real2_ctl_item_label(hd_apature_range, & + & movie%apature_range_ctl) + call init_real2_ctl_item_label(hd_LIC_kernel_peak, & + & movie%LIC_kernel_peak_range_ctl) +! + end subroutine init_pvr_rotation_ctl_label +! +! --------------------------------------------------------------------- +! + end module ctl_data_pvr_movie_IO diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_view_transfer_IO.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_view_transfer_IO.f90 new file mode 100644 index 00000000..4fba282d --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_data_view_transfer_IO.f90 @@ -0,0 +1,340 @@ +!>@file ctl_data_view_transfer_IO.f90 +!!@brief module ctl_data_view_transfer_IO +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief Control inputs for PVR view parameter +!! +!!@verbatim +!! subroutine init_view_transfer_ctl_label(hd_block, mat) +!! subroutine read_view_transfer_ctl & +!! & (id_control, hd_block, mat, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(modeview_ctl), intent(inout) :: mat +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_view_transfer_ctl & +!! & (id_control, hd_block, mat, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(modeview_ctl), intent(in) :: mat +!! integer(kind = kint), intent(inout) :: level +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Input example +! +!! begin view_transform_ctl +!! +!! begin image_size_ctl +!! x_pixel_ctl 640 +!! y_pixel_ctl 480 +!! end image_size_ctl +!! +!! array look_at_point_ctl +!! look_at_point_ctl x 3.0 +!! look_at_point_ctl y -8.0 +!! look_at_point_ctl z 6.0 +!! end array look_at_point_ctl +!! +!! array eye_position_ctl +!! eye_position_ctl x 3.0 +!! eye_position_ctl y -8.0 +!! eye_position_ctl z 6.0 +!! end array eye_position_ctl +!! +!! array up_direction_ctl +!! up_direction_ctl x 0.0 +!! up_direction_ctl y 0.0 +!! up_direction_ctl z 1.0 +!! end array up_direction_ctl +!! +!! array view_rotation_vec_ctl +!! view_rotation_vec_ctl x 0.0 +!! view_rotation_vec_ctl y 0.0 +!! view_rotation_vec_ctl z 1.0 +!! end array view_rotation_vec_ctl +!! +!! view_rotation_deg_ctl 60.0 +!! +!! scale_factor_ctl 1.0 +!! array scale_factor_vec_ctl +!! scale_factor_vec_ctl x 0.0 +!! scale_factor_vec_ctl y 0.0 +!! scale_factor_vec_ctl z 1.0 +!! end array scale_factor_vec_ctl +!! +!! array eye_position_in_viewer_ctl +!! eye_position_in_viewer_ctl x 0.0 +!! eye_position_in_viewer_ctl y 0.0 +!! eye_position_in_viewer_ctl z 10.0 +!! end array eye_position_in_viewer_ctl +!! +!! array modelview_matrix_ctl +!! modelview_matrix_ctl 1 1 1.0 end +!! modelview_matrix_ctl 2 1 0.0 end +!! modelview_matrix_ctl 3 1 0.0 end +!! modelview_matrix_ctl 4 1 0.0 end +!! +!! modelview_matrix_ctl 1 2 0.0 end +!! modelview_matrix_ctl 2 2 1.0 end +!! modelview_matrix_ctl 3 2 0.0 end +!! modelview_matrix_ctl 4 2 0.0 end +!! +!! modelview_matrix_ctl 1 3 0.0 end +!! modelview_matrix_ctl 2 3 0.0 end +!! modelview_matrix_ctl 3 3 1.0 end +!! modelview_matrix_ctl 4 3 0.0 end +!! +!! modelview_matrix_ctl 1 4 0.0 end +!! modelview_matrix_ctl 2 4 0.0 end +!! modelview_matrix_ctl 3 4 0.0 end +!! modelview_matrix_ctl 4 4 1.0 end +!! end array modelview_matrix_ctl +!! +!! Orthogonal view....( perspective_near_ctl = perspective_far_ctl) +!! +!! projection_type_ctl Aitoff, xy_plane, xz_plane, yz_plane +!! begin projection_matrix_ctl +!! ... +!! end projection_matrix_ctl +!! +!! begin stereo_view_parameter_ctl +!! focal_distance_ctl 40.0 +!! eye_separation_ctl 0.5 +!! end stereo_view_parameter_ctl +!! +!! end view_transform_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim + module ctl_data_view_transfer_IO +! + use m_precision +! + use m_constants + use m_machine_parameter + use t_read_control_elements + use t_control_array_real + use t_control_array_charareal + use t_control_array_chara2real + use t_ctl_data_4_screen_pixel + use t_ctl_data_4_projection + use t_ctl_data_4_streo_view + use t_ctl_data_4_view_transfer + use skip_comment_f +! + implicit none +! +! 3rd level for view_transform_define + character(len=kchara), parameter, private & + & :: hd_image_size = 'image_size_ctl' + character(len=kchara), parameter, private & + & :: hd_model_mat = 'modelview_matrix_ctl' + character(len=kchara), parameter, private & + & :: hd_project_mat = 'projection_matrix_ctl' +! + character(len=kchara), parameter, private & + & :: hd_look_point = 'look_at_point_ctl' + character(len=kchara), parameter, private & + & :: hd_eye_position = 'eye_position_ctl' + character(len=kchara), parameter, private & + & :: hd_up_dir = 'up_direction_ctl' +! +! + character(len=kchara), parameter, private & + & :: hd_view_rot_deg = 'view_rotation_deg_ctl' + character(len=kchara), parameter, private & + & :: hd_view_rot_dir = 'view_rotation_vec_ctl' +! + character(len=kchara), parameter, private & + & :: hd_scale_factor = 'scale_factor_ctl' + character(len=kchara), parameter, private & + & :: hd_scale_fac_dir = 'scale_factor_vec_ctl' + character(len=kchara), parameter, private & + & :: hd_eye_in_view = 'eye_position_in_viewer_ctl' +! + character(len=kchara), parameter, private & + & :: hd_stereo_view = 'stereo_view_parameter_ctl' + character(len=kchara), parameter, private & + & :: hd_projection_type = 'projection_type_ctl' +! +! Old definision + character(len=kchara), parameter, private & + & :: hd_view_point = 'viewpoint_ctl' + character(len=kchara), parameter, private & + & :: hd_viewpt_in_view = 'viewpoint_in_viewer_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_view_transfer_ctl & + & (id_control, hd_block, mat, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(modeview_ctl), intent(inout) :: mat + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(mat%i_view_transform .gt. 0) return + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_projection_mat_ctl & + & (id_control, hd_project_mat, mat%proj, c_buf) + call read_image_size_ctl & + & (id_control, hd_image_size, mat%pixel, c_buf) + call read_stereo_view_ctl & + & (id_control, hd_stereo_view, mat%streo, c_buf) +! +! + call read_control_array_c_r(id_control, & + & hd_look_point, mat%lookpoint_ctl, c_buf) +! + call read_control_array_c_r(id_control, & + & hd_eye_position, mat%viewpoint_ctl, c_buf) + call read_control_array_c_r(id_control, & + & hd_view_point, mat%viewpoint_ctl, c_buf) +! + call read_control_array_c_r(id_control, & + & hd_up_dir, mat%up_dir_ctl, c_buf) +! + call read_control_array_c_r(id_control, & + & hd_view_rot_dir, mat%view_rot_vec_ctl, c_buf) + call read_control_array_c_r(id_control, & + & hd_scale_fac_dir, mat%scale_vector_ctl, c_buf) +! + call read_control_array_c_r(id_control, & + & hd_eye_in_view, mat%viewpt_in_viewer_ctl, c_buf) + call read_control_array_c_r(id_control, & + & hd_viewpt_in_view, mat%viewpt_in_viewer_ctl, c_buf) +! + call read_control_array_c2_r(id_control, & + & hd_model_mat, mat%modelview_mat_ctl, c_buf) +! + call read_real_ctl_type(c_buf, hd_view_rot_deg, & + & mat%view_rotation_deg_ctl) + call read_real_ctl_type(c_buf, hd_scale_factor, & + & mat%scale_factor_ctl) + call read_chara_ctl_type(c_buf, hd_projection_type, & + & mat%projection_type_ctl) + end do + mat%i_view_transform = 1 +! + end subroutine read_view_transfer_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_view_transfer_ctl & + & (id_control, hd_block, mat, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(modeview_ctl), intent(in) :: mat +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(mat%i_view_transform .le. 0) return +! + maxlen = len_trim(hd_view_rot_deg) + maxlen = max(maxlen, len_trim(hd_scale_factor)) + maxlen = max(maxlen, len_trim(hd_projection_type)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_chara_ctl_type(id_control, level, maxlen, & + & mat%projection_type_ctl) + call write_projection_mat_ctl & + & (id_control, hd_project_mat, mat%proj, level) + call write_image_size_ctl & + & (id_control, hd_image_size, mat%pixel, level) + call write_stereo_view_ctl & + & (id_control, hd_stereo_view, mat%streo, level) +! + call write_control_array_c_r(id_control, level, & + & mat%lookpoint_ctl) + call write_control_array_c_r(id_control, level, & + & mat%viewpoint_ctl) + call write_control_array_c_r(id_control, level, & + & mat%up_dir_ctl) +! + call write_control_array_c_r(id_control, level, & + & mat%view_rot_vec_ctl) + call write_control_array_c_r(id_control, level, & + & mat%scale_vector_ctl) + call write_control_array_c_r(id_control, level, & + & mat%viewpt_in_viewer_ctl) +! + call write_control_array_c2_r(id_control, level, & + & mat%modelview_mat_ctl) +! + call write_real_ctl_type(id_control, level, maxlen, & + & mat%view_rotation_deg_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & mat%scale_factor_ctl) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_view_transfer_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_view_transfer_ctl_label(hd_block, mat) +! + character(len=kchara), intent(in) :: hd_block +! + type(modeview_ctl), intent(inout) :: mat +! +! + mat%block_name = hd_block + call init_image_size_ctl_label(hd_image_size, mat%pixel) + call init_projection_mat_ctl_label(hd_project_mat, mat%proj) + call init_stereo_view_ctl_label(hd_stereo_view, mat%streo) +! + call init_c_r_ctl_array_label & + & (hd_look_point, mat%lookpoint_ctl) +! + call init_c_r_ctl_array_label & + & (hd_eye_position, mat%viewpoint_ctl) + call init_c_r_ctl_array_label & + & (hd_view_point, mat%viewpoint_ctl) +! + call init_c_r_ctl_array_label & + & (hd_up_dir, mat%up_dir_ctl) +! + call init_c_r_ctl_array_label & + & (hd_view_rot_dir, mat%view_rot_vec_ctl) + call init_c_r_ctl_array_label & + & (hd_scale_fac_dir, mat%scale_vector_ctl) +! + call init_c_r_ctl_array_label & + & (hd_eye_in_view, mat%viewpt_in_viewer_ctl) + call init_c_r_ctl_array_label & + & (hd_viewpt_in_view, mat%viewpt_in_viewer_ctl) +! + call init_c2_r_ctl_array_label & + & (hd_model_mat, mat%modelview_mat_ctl) +! + call init_real_ctl_item_label(hd_view_rot_deg, & + & mat%view_rotation_deg_ctl) + call init_real_ctl_item_label(hd_scale_factor, & + & mat%scale_factor_ctl) + call init_chara_ctl_item_label(hd_projection_type, & + & mat%projection_type_ctl) +! + end subroutine init_view_transfer_ctl_label +! +! --------------------------------------------------------------------- +! + end module ctl_data_view_transfer_IO diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_file_each_pvr_IO.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_file_each_pvr_IO.f90 new file mode 100644 index 00000000..bc31a156 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_file_each_pvr_IO.f90 @@ -0,0 +1,196 @@ +!>@file ctl_file_each_pvr_IO.f90 +!!@brief module ctl_file_each_pvr_IO +!! +!!@date Programmed by H.Matsui in May. 2006 +! +!>@brief Set PVR parameters from control files +!! +!!@verbatim +!! subroutine sel_read_control_pvr(id_control, hd_pvr_ctl, & +!! & fname_pvr_ctl, pvr_ctl_type, c_buf) +!! subroutine read_control_pvr_file(id_control, fname_pvr_ctl, & +!! & hd_pvr_ctl, pvr_ctl_type, c_buf) +!! subroutine read_control_pvr_update(id_control, fname_pvr_ctl, & +!! & hd_pvr_ctl, pvr_ctl_type) +!! integer(kind = kint), intent(in) :: id_control +!! character(len = kchara), intent(in) :: hd_pvr_ctl +!! character(len = kchara), intent(inout) :: fname_pvr_ctl +!! type(pvr_parameter_ctl), intent(inout) :: pvr_ctl_type +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine sel_write_control_pvr(id_control, hd_pvr_ctl, & +!! & fname_pvr_ctl, pvr_ctl_type, level) +!! subroutine write_control_pvr_file(id_control, fname_pvr_ctl, & +!! & hd_pvr_ctl, pvr_ctl_type) +!! integer(kind = kint), intent(in) :: id_control +!! character(len = kchara), intent(in) :: fname_pvr_ctl +!! character(len = kchara), intent(in) :: hd_pvr_ctl +!! type(pvr_parameter_ctl), intent(in) :: pvr_ctl_type +!! integer(kind = kint), intent(inout) :: level +!!@endverbatim +! + module ctl_file_each_pvr_IO +! + use m_precision +! + use t_control_data_4_pvr +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine sel_read_control_pvr(id_control, hd_pvr_ctl, & + & fname_pvr_ctl, pvr_ctl_type, c_buf) +! + use ctl_data_each_pvr_IO +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: hd_pvr_ctl + character(len = kchara), intent(inout) :: fname_pvr_ctl + type(pvr_parameter_ctl), intent(inout) :: pvr_ctl_type + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_file_flag(c_buf, hd_pvr_ctl)) then + fname_pvr_ctl = third_word(c_buf) +! + write(*,'(2a)') ' is read from ', trim(fname_pvr_ctl) + call read_control_pvr_file(id_control+2, fname_pvr_ctl, & + & hd_pvr_ctl, pvr_ctl_type, c_buf) + else if(check_begin_flag(c_buf, hd_pvr_ctl)) then + fname_pvr_ctl = 'NO_FILE' +! + write(*,*) 'is included.' + call read_pvr_ctl(id_control, hd_pvr_ctl, pvr_ctl_type, c_buf) + end if +! + end subroutine sel_read_control_pvr +! +! --------------------------------------------------------------------- +! + subroutine read_control_pvr_file(id_control, fname_pvr_ctl, & + & hd_pvr_ctl, pvr_ctl_type, c_buf) +! + use ctl_data_each_pvr_IO +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: fname_pvr_ctl + character(len = kchara), intent(in) :: hd_pvr_ctl + type(pvr_parameter_ctl), intent(inout) :: pvr_ctl_type + type(buffer_for_control), intent(inout) :: c_buf +! +! + c_buf%level = c_buf%level + 1 + open(id_control, file=fname_pvr_ctl, status='old') + do + call load_one_line_from_control(id_control, hd_pvr_ctl, c_buf) + if(c_buf%iend .gt. 0) exit +! + call read_pvr_ctl(id_control, hd_pvr_ctl, & + & pvr_ctl_type, c_buf) + if(pvr_ctl_type%i_pvr_ctl .gt. 0) exit + end do + close(id_control) +! + c_buf%level = c_buf%level - 1 +! + end subroutine read_control_pvr_file +! +! --------------------------------------------------------------------- +! + subroutine read_control_pvr_update(id_control, fname_pvr_ctl, & + & hd_pvr_ctl, pvr_ctl_type) +! + use ctl_data_each_pvr_IO + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: fname_pvr_ctl + character(len = kchara), intent(in) :: hd_pvr_ctl + type(pvr_parameter_ctl), intent(inout) :: pvr_ctl_type +! + type(buffer_for_control) :: c_buf1 +! + if(no_file_flag(fname_pvr_ctl)) return +! + c_buf1%level = 0 + open(id_control, file=fname_pvr_ctl, status='old') + pvr_ctl_type%i_pvr_ctl = 0 +! + do + call load_one_line_from_control(id_control, hd_pvr_ctl, c_buf1) + if(c_buf1%iend .gt. 0) exit +! + call read_pvr_update_flag & + & (id_control, hd_pvr_ctl, pvr_ctl_type, c_buf1) + if(pvr_ctl_type%i_pvr_ctl .gt. 0) exit + end do + close(id_control) + if(c_buf1%iend .gt. 0) pvr_ctl_type%i_pvr_ctl = - c_buf1%iend +! + end subroutine read_control_pvr_update +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine sel_write_control_pvr(id_control, hd_pvr_ctl, & + & fname_pvr_ctl, pvr_ctl_type, level) +! + use ctl_data_each_pvr_IO + use write_control_elements + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: fname_pvr_ctl + character(len = kchara), intent(in) :: hd_pvr_ctl + type(pvr_parameter_ctl), intent(in) :: pvr_ctl_type + integer(kind = kint), intent(inout) :: level +! +! + if(no_file_flag(fname_pvr_ctl)) then + write(*,'(a)') ' is included.' + call write_pvr_ctl(id_control, hd_pvr_ctl, & + & pvr_ctl_type, level) + else if(id_control .eq. id_monitor) then + write(*,'(2a)') ' should be written to file ... ', & + & trim(fname_pvr_ctl) + call write_pvr_ctl(id_control, hd_pvr_ctl, & + & pvr_ctl_type, level) + else + write(*,'(2a)') ' is written to file...', trim(fname_pvr_ctl) + call write_file_name_for_ctl_line(id_control, level, & + & hd_pvr_ctl, fname_pvr_ctl) + call write_control_pvr_file(id_control+2, fname_pvr_ctl, & + & hd_pvr_ctl, pvr_ctl_type) + end if +! + end subroutine sel_write_control_pvr +! +! --------------------------------------------------------------------- +! + subroutine write_control_pvr_file(id_control, fname_pvr_ctl, & + & hd_pvr_ctl, pvr_ctl_type) +! + use ctl_data_each_pvr_IO +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: fname_pvr_ctl + character(len = kchara), intent(in) :: hd_pvr_ctl + type(pvr_parameter_ctl), intent(in) :: pvr_ctl_type +! + integer(kind = kint) :: level +! +! + level = 0 + open(id_control, file=fname_pvr_ctl) + call write_pvr_ctl(id_control, hd_pvr_ctl, pvr_ctl_type, level) + close(id_control) +! + end subroutine write_control_pvr_file +! +! --------------------------------------------------------------------- +! + end module ctl_file_each_pvr_IO diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_file_pvr_light_IO.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_file_pvr_light_IO.f90 new file mode 100644 index 00000000..5eb8f2ff --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_file_pvr_light_IO.f90 @@ -0,0 +1,178 @@ +!>@file ctl_file_pvr_light_IO.f90 +!!@brief module ctl_file_pvr_light_IO +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief Control inputs for PVR lightin parameter file +!! +!!@verbatim +!! subroutine sel_read_ctl_pvr_light_file & +!! & (id_control, hd_block, file_name, light, c_buf) +!! subroutine sel_write_ctl_pvr_light_file & +!! & (id_control, hd_block, file_name, light, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_light_ctl), intent(in) :: light +!! character(len = kchara), intent(inout) :: file_name +!! integer(kind = kint), intent(inout) :: level +!! subroutine write_control_pvr_light_file(id_control, file_name, & +!! & hd_block, light) +!! integer(kind = kint), intent(in) :: id_control +!! character(len = kchara), intent(in) :: file_name +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_light_ctl), intent(in) :: light +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Input example +! +!! begin lighting_ctl +!! array position_of_lights 4 +!! position_of_lights 0.0 0.0 0.0 end +!! position_of_lights -10.0 0.0 -10.0 end +!! position_of_lights -10.0 0.0 0.0 end +!! position_of_lights 0.0 10.0 0.0 end +!! end array position_of_lights +!!! +!! ambient_coef_ctl 0.5 +!! diffuse_coef_ctl 5.6 +!! specular_coef_ctl 0.8 +!! end lighting_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +!! +! + module ctl_file_pvr_light_IO +! + use m_precision +! + use m_constants + use m_machine_parameter + use t_ctl_data_pvr_light + use t_read_control_elements +! + implicit none +! + private :: read_control_pvr_light_file +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine sel_read_ctl_pvr_light_file & + & (id_control, hd_block, file_name, light, c_buf) +! + use write_control_elements + use ctl_data_view_transfer_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + character(len = kchara), intent(inout) :: file_name + type(pvr_light_ctl), intent(inout) :: light + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_file_flag(c_buf, hd_block)) then + file_name = third_word(c_buf) +! + call write_one_ctl_file_message & + & (hd_block, c_buf%level, file_name) + call read_control_pvr_light_file(id_control+2, file_name, & + & hd_block, light, c_buf) + else if(check_begin_flag(c_buf, hd_block)) then + file_name = 'NO_FILE' +! + call write_included_message(hd_block, c_buf%level) + call read_lighting_ctl(id_control, hd_block, light, c_buf) + end if +! + end subroutine sel_read_ctl_pvr_light_file +! +! --------------------------------------------------------------------- +! + subroutine sel_write_ctl_pvr_light_file & + & (id_control, hd_block, file_name, light, level) +! + use skip_comment_f + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(pvr_light_ctl), intent(in) :: light + integer(kind = kint), intent(inout) :: level +! +! + if(no_file_flag(file_name)) then + call write_lighting_ctl(id_control, hd_block, light, level) + else if(id_control .eq. id_monitor) then + write(*,'(4a)') '! ', trim(hd_block), & + & ' should be written to file ... ', trim(file_name) + call write_lighting_ctl(id_control, hd_block, light, level) + else + write(*,'(4a)') 'Write file for ', trim(hd_block), & + & ' ... ', trim(file_name) + call write_control_pvr_light_file(id_control+2, file_name, & + & hd_block, light) + call write_file_name_for_ctl_line(id_control, level, & + & hd_block, file_name) + end if +! + end subroutine sel_write_ctl_pvr_light_file +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine read_control_pvr_light_file(id_control, file_name, & + & hd_block, light, c_buf) +! + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(pvr_light_ctl), intent(inout) :: light + type(buffer_for_control), intent(inout) :: c_buf +! +! + c_buf%level = c_buf%level + 1 + open(id_control, file = file_name, status='old') + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit +! + call read_lighting_ctl(id_control, hd_block, light, c_buf) + if(light%i_pvr_lighting .gt. 0) exit + end do + close(id_control) +! + c_buf%level = c_buf%level - 1 +! + end subroutine read_control_pvr_light_file +! +! --------------------------------------------------------------------- +! + subroutine write_control_pvr_light_file(id_control, file_name, & + & hd_block, light) +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(pvr_light_ctl), intent(in) :: light +! + integer(kind = kint) :: level +! +! + open(id_control, file = file_name) +! + level = 0 + call write_lighting_ctl(id_control, hd_block, light, level) + close(id_control) +! + end subroutine write_control_pvr_light_file +! +! --------------------------------------------------------------------- +! + end module ctl_file_pvr_light_IO diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_file_pvr_modelview_IO.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_file_pvr_modelview_IO.f90 new file mode 100644 index 00000000..71f7874e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ctl_file_pvr_modelview_IO.f90 @@ -0,0 +1,255 @@ +!>@file ctl_file_pvr_modelview_IO.f90 +!!@brief module ctl_file_pvr_modelview_IO +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief Control inputs for PVR view parameter +!! +!!@verbatim +!! subroutine sel_read_ctl_modelview_file & +!! & (id_control, hd_block, icou, file_name, mat, c_buf) +!! subroutine sel_write_ctl_modelview_file & +!! & (id_control, hd_block, file_name, mat, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(modeview_ctl), intent(in) :: mat +!! character(len = kchara), intent(inout) :: file_name +!! integer(kind = kint), intent(inout) :: level +!! subroutine write_control_modelview_file(id_control, file_name, & +!! & hd_block, mat) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! character(len = kchara), intent(in) :: file_name +!! type(modeview_ctl), intent(in) :: mat +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Input example +! +!! begin view_transform_ctl +!! +!! begin image_size_ctl +!! x_pixel_ctl 640 +!! y_pixel_ctl 480 +!! end image_size_ctl +!! +!! array look_at_point_ctl +!! look_at_point_ctl x 3.0 +!! look_at_point_ctl y -8.0 +!! look_at_point_ctl z 6.0 +!! end array look_at_point_ctl +!! +!! array eye_position_ctl +!! eye_position_ctl x 3.0 +!! eye_position_ctl y -8.0 +!! eye_position_ctl z 6.0 +!! end array eye_position_ctl +!! +!! array up_direction_ctl +!! up_direction_ctl x 0.0 +!! up_direction_ctl y 0.0 +!! up_direction_ctl z 1.0 +!! end array up_direction_ctl +!! +!! array view_rotation_vec_ctl +!! view_rotation_vec_ctl x 0.0 +!! view_rotation_vec_ctl y 0.0 +!! view_rotation_vec_ctl z 1.0 +!! end array view_rotation_vec_ctl +!! +!! view_rotation_deg_ctl 60.0 +!! +!! scale_factor_ctl 1.0 +!! array scale_factor_vec_ctl +!! scale_factor_vec_ctl x 0.0 +!! scale_factor_vec_ctl y 0.0 +!! scale_factor_vec_ctl z 1.0 +!! end array scale_factor_vec_ctl +!! +!! array eye_position_in_viewer_ctl +!! eye_position_in_viewer_ctl x 0.0 +!! eye_position_in_viewer_ctl y 0.0 +!! eye_position_in_viewer_ctl z 10.0 +!! end array eye_position_in_viewer_ctl +!! +!! array modelview_matrix_ctl +!! modelview_matrix_ctl 1 1 1.0 end +!! modelview_matrix_ctl 2 1 0.0 end +!! modelview_matrix_ctl 3 1 0.0 end +!! modelview_matrix_ctl 4 1 0.0 end +!! +!! modelview_matrix_ctl 1 2 0.0 end +!! modelview_matrix_ctl 2 2 1.0 end +!! modelview_matrix_ctl 3 2 0.0 end +!! modelview_matrix_ctl 4 2 0.0 end +!! +!! modelview_matrix_ctl 1 3 0.0 end +!! modelview_matrix_ctl 2 3 0.0 end +!! modelview_matrix_ctl 3 3 1.0 end +!! modelview_matrix_ctl 4 3 0.0 end +!! +!! modelview_matrix_ctl 1 4 0.0 end +!! modelview_matrix_ctl 2 4 0.0 end +!! modelview_matrix_ctl 3 4 0.0 end +!! modelview_matrix_ctl 4 4 1.0 end +!! end array modelview_matrix_ctl +!! +!! Orthogonal view....( perspective_near_ctl = perspective_far_ctl) +!! +!! begin projection_matrix_ctl +!! ... +!! end projection_matrix_ctl +!! +!! begin stereo_view_parameter_ctl +!! focal_distance_ctl 40.0 +!! eye_separation_ctl 0.5 +!! eye_separation_angle 35.0 +!! eye_separation_step_by_angle ON +!! end stereo_view_parameter_ctl +!! +!! end view_transform_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +!! +! + module ctl_file_pvr_modelview_IO +! + use m_precision +! + use m_constants + use m_machine_parameter + use t_ctl_data_4_view_transfer + use t_read_control_elements +! + implicit none +! + private :: read_control_modelview_file +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine sel_read_ctl_modelview_file & + & (id_control, hd_block, icou, file_name, mat, c_buf) +! + use ctl_data_view_transfer_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control, icou + character(len=kchara), intent(in) :: hd_block + character(len = kchara), intent(inout) :: file_name + type(modeview_ctl), intent(inout) :: mat + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_file_flag(c_buf, hd_block)) then + file_name = third_word(c_buf) +! + call write_multi_ctl_file_message(hd_block, icou, c_buf%level) + write(*,'(2a)') ' is read from ... ', trim(file_name) + call read_control_modelview_file(id_control+2, file_name, & + & hd_block, mat, c_buf) + else if(check_begin_flag(c_buf, hd_block)) then + file_name = 'NO_FILE' +! + write(*,'(a)') ' is included' + call read_view_transfer_ctl(id_control, hd_block, mat, c_buf) + end if +! + end subroutine sel_read_ctl_modelview_file +! +! --------------------------------------------------------------------- +! + subroutine sel_write_ctl_modelview_file & + & (id_control, hd_block, file_name, mat, level) +! + use skip_comment_f + use ctl_data_view_transfer_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(modeview_ctl), intent(in) :: mat + integer(kind = kint), intent(inout) :: level +! +! + if(no_file_flag(file_name)) then + write(*,'(3a)') '! ', trim(hd_block), ' is included' + call write_view_transfer_ctl(id_control, hd_block, mat, level) + else if(id_control .eq. id_monitor) then + write(*,'(4a)') '! ', trim(hd_block), & + & ' should be written to file ... ', trim(file_name) + call write_view_transfer_ctl(id_control, hd_block, mat, level) + else + write(*,'(4a)') 'Write file for ', trim(hd_block), & + & '... ', trim(file_name) + call write_control_modelview_file(id_control+2, file_name, & + & hd_block, mat) + call write_file_name_for_ctl_line(id_control, level, & + & hd_block, file_name) + end if +! + end subroutine sel_write_ctl_modelview_file +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine read_control_modelview_file(id_control, file_name, & + & hd_block, mat, c_buf) +! + use skip_comment_f + use ctl_data_view_transfer_IO +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(modeview_ctl), intent(inout) :: mat + type(buffer_for_control), intent(inout) :: c_buf +! +! + c_buf%level = c_buf%level + 1 + open(id_control, file = file_name, status='old') +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit +! + call read_view_transfer_ctl(id_control, hd_block, mat, c_buf) + if(mat%i_view_transform .gt. 0) exit + end do + close(id_control) +! + c_buf%level = c_buf%level - 1 +! + end subroutine read_control_modelview_file +! +! --------------------------------------------------------------------- +! + subroutine write_control_modelview_file(id_control, file_name, & + & hd_block, mat) +! + use ctl_data_view_transfer_IO +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(modeview_ctl), intent(in) :: mat +! + integer(kind = kint) :: level +! +! + write(*,*) trim(file_name) + open(id_control, file = file_name) +! + level = 0 + call write_view_transfer_ctl(id_control, hd_block, mat, level) + close(id_control) +! + end subroutine write_control_modelview_file +! +! --------------------------------------------------------------------- +! + end module ctl_file_pvr_modelview_IO diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/draw_pvr_colorbar.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/draw_pvr_colorbar.f90 new file mode 100644 index 00000000..1dc1478e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/draw_pvr_colorbar.f90 @@ -0,0 +1,356 @@ +!>@file draw_pvr_colorbar.f90 +!!@brief module draw_pvr_colorbar +!! +!!@author H. Matsui +!!@date Programmed in 2008 +! +! +!>@brief Draw color bar for PVR +!! +!!@verbatim +!! subroutine set_pvr_timelabel(time, num_pixel, n_pvr_pixel, & +!! & cbar_param, rgba_gl) +!! subroutine set_pvr_colorbar(num_pixel, n_pvr_pixel, & +!! & color_param, cbar_param, rgba_gl) +!! type(pvr_colormap_parameter), intent(in) :: color_param +!! type(pvr_colorbar_parameter), intent(in) :: cbar_param +!!@endverbatim +! + module draw_pvr_colorbar +! + use m_precision +! + use m_constants + use t_pvr_colormap_parameter +! + implicit none +! +! + private :: draw_bottom_pvr_colorbar, gen_bottom_colormark + private :: draw_left_pvr_colorbar, gen_right_colormark +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_pvr_timelabel(time, num_pixel, n_pvr_pixel, & + & cbar_param, rgba_gl) +! + use draw_pvr_colorbar_nums +! + integer(kind = kint), intent(in) :: num_pixel + integer(kind = kint), intent(in) :: n_pvr_pixel(2) + real(kind = kreal), intent(in) :: time +! + type(pvr_colorbar_parameter), intent(in) :: cbar_param +! + real(kind = kreal), intent(inout) :: rgba_gl(4,num_pixel) +! +! + call gen_time_label(cbar_param%iscale_font, time, & + & n_pvr_pixel, num_pixel, rgba_gl) +! + end subroutine set_pvr_timelabel +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_pvr_colorbar(num_pixel, n_pvr_pixel, & + & color_param, cbar_param, rgba_gl) +! + integer(kind = kint), intent(in) :: num_pixel + integer(kind = kint), intent(in) :: n_pvr_pixel(2) +! +! type(pvr_domain_outline), intent(in) :: outline + type(pvr_colormap_parameter), intent(in) :: color_param + type(pvr_colorbar_parameter), intent(in) :: cbar_param +! + real(kind = kreal), intent(inout) :: rgba_gl(4,num_pixel) +! +! +! if(cbar_param%cbar_range(2) .le. cbar_param%cbar_range(1)) then +! cbar_param%cbar_range(1:2) = outline%d_minmax_pvr(1:2) +! end if +! + if(cbar_param%flag_pvr_cbar_bottom) then + call draw_bottom_pvr_colorbar(cbar_param%iflag_opacity, & + & cbar_param%iflag_pvr_cbar_nums, & + & cbar_param%iflag_pvr_zero_mark, & + & cbar_param%iscale_font, cbar_param%ntick_pvr_colorbar, & + & cbar_param%cbar_range(1), n_pvr_pixel, & + & num_pixel, color_param, rgba_gl) + return + else + call draw_left_pvr_colorbar(cbar_param%iflag_opacity, & + & cbar_param%iflag_pvr_cbar_nums, & + & cbar_param%iflag_pvr_zero_mark, & + & cbar_param%iscale_font, cbar_param%ntick_pvr_colorbar, & + & cbar_param%cbar_range(1), n_pvr_pixel, & + & num_pixel, color_param, rgba_gl) + end if +! + end subroutine set_pvr_colorbar +! +! --------------------------------------------------------------------- +! + subroutine draw_bottom_pvr_colorbar & + & (iflag_opacity, iflag_cbar_numeric, iflag_zero_mark, & + & iscale, num_of_scale, c_minmax, npix_img, & + & ntot_pix, color_param, dimage) +! + use draw_pvr_colorbar_nums +! + integer(kind = kint), intent(in) :: iflag_opacity + integer(kind = kint), intent(in) :: iflag_cbar_numeric + integer(kind = kint), intent(in) :: iflag_zero_mark + real(kind = kreal), intent(in) :: c_minmax(2) + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: ntot_pix +! + type(pvr_colormap_parameter), intent(in) :: color_param +! + integer(kind = kint), intent(in) :: num_of_scale + integer(kind = kint), intent(in) :: iscale +! + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + integer(kind = kint):: isleeve_bar +! +! + isleeve_bar = l_bar_width() + 6 + 8 * 9 + isleeve_bar = isleeve_bar + 8 & + & - mod((isleeve_bar-ione),ifour) +! + call gen_bottom_colormark(iscale, c_minmax, npix_img, & + & isleeve_bar, ntot_pix, iflag_opacity, dimage, color_param) +! + if(iflag_cbar_numeric .gt. 0) then + call gen_bottom_cbar_label(iscale, num_of_scale, c_minmax, & + & npix_img, isleeve_bar, ntot_pix, dimage) +! + if(iflag_zero_mark .gt. 0) then + call gen_bottom_zero_label(iscale, c_minmax, npix_img, & + & isleeve_bar, ntot_pix, dimage) + end if + end if +! + end subroutine draw_bottom_pvr_colorbar +! +! --------------------------------------------------------------------- +! + subroutine draw_left_pvr_colorbar & + & (iflag_opacity, iflag_cbar_numeric, iflag_zero_mark, & + & iscale, num_of_scale, c_minmax, npix_img, & + & ntot_pix, color_param, dimage) +! + use draw_pvr_colorbar_nums +! + integer(kind = kint), intent(in) :: iflag_opacity + integer(kind = kint), intent(in) :: iflag_cbar_numeric + integer(kind = kint), intent(in) :: iflag_zero_mark + real(kind = kreal), intent(in) :: c_minmax(2) + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: ntot_pix +! + type(pvr_colormap_parameter), intent(in) :: color_param +! + integer(kind = kint), intent(in) :: num_of_scale + integer(kind = kint), intent(in) :: iscale +! + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + integer(kind = kint):: isleeve_bar +! +! + isleeve_bar = (l_bar_width() + 6 + 8 * 9) * iscale + isleeve_bar = isleeve_bar + ithree & + & - mod((isleeve_bar-ione),ifour) +! + call gen_right_colormark(iscale, c_minmax, npix_img, & + & isleeve_bar, ntot_pix, iflag_opacity, dimage, color_param) +! + if(iflag_cbar_numeric .gt. 0) then + call gen_right_cbar_label(iscale, num_of_scale, c_minmax, & + & npix_img, isleeve_bar, ntot_pix, dimage) +! + if(iflag_zero_mark .gt. 0) then + call gen_right_zero_label(iscale, c_minmax, npix_img, & + & isleeve_bar, ntot_pix, dimage) + end if + end if +! + end subroutine draw_left_pvr_colorbar +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine gen_bottom_colormark & + & (iscale, c_minmax, npix_img, isleeve_bar, & + & ntot_pix, iflag_opacity, dimage, color_param) +! + use set_color_4_pvr + use set_rgba_4_each_pixel + use draw_pvr_colorbar_nums +! + integer(kind = kint), intent(in) :: iflag_opacity + integer(kind = kint), intent(in) :: iscale + real(kind = kreal), intent(in) :: c_minmax(2) + integer(kind = kint), intent(in) :: isleeve_bar + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: ntot_pix + type(pvr_colormap_parameter), intent(in) :: color_param +! + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + real(kind = kreal) :: anb_opacity, opa_current + real(kind = kreal) :: value, color(3) + integer(kind = kint) :: i, j, inod + integer(kind = kint) :: num_of_features +! + integer(kind = kint) :: ist_h, jst_h, ied_h, jed_h +! +! + call corners_4_bottom_colorbar & + & (iscale, npix_img, isleeve_bar, ist_h, jst_h, ied_h, jed_h) +! + num_of_features = color_param%num_opacity_pnt + anb_opacity = color_param%pvr_opacity_param(1,num_of_features) + do i = ist_h, ied_h + value = c_minmax(1) + (c_minmax(2)-c_minmax(1)) & + & * dble(i-ist_h) / dble(ied_h-ist_h) +! + if(iflag_opacity .gt. 0) then + call compute_opacity & + & (color_param%id_pvr_color(3), anb_opacity, & + & color_param%num_opacity_pnt, color_param%pvr_opacity_param, & + & value, opa_current) + opa_current = opa_current / color_param%pvr_max_opacity + else + opa_current = 1.0d0 + end if +! + call value_to_rgb & + & (color_param%id_pvr_color(2), color_param%id_pvr_color(1), & + & color_param%num_pvr_datamap_pnt, & + & color_param%pvr_datamap_param, value, color) +! + do j = jst_h, jst_h+iscale*l_bar_width()/2-1 + inod = (j-1)*npix_img(1) + i + dimage(1:3,inod) = color(1:3) * opa_current + dimage(4,inod) = one + end do + do j = jst_h+iscale*l_bar_width()/2, jst_h+iscale*l_bar_width() + inod = (j-1)*npix_img(1) + i + dimage(1:3,inod) = color(1:3) + dimage(4,inod) = one + end do + end do +! + do i = -iscale/4, (iscale+1)/4 + do j = jst_h, jed_h + inod = (j-1)*npix_img(1) + ist_h+i + dimage(1:4,inod) = one + inod = (j-1)*npix_img(1) + ied_h+i + dimage(1:4,inod) = one + end do + end do +! + do j = -iscale/4, (iscale+1)/4 + do i = ist_h, ied_h + inod = i + (jst_h+j-1)*npix_img(1) + dimage(1:4,inod) = one + inod = i + (jed_h+j )*npix_img(1) + dimage(1:4,inod) = one + end do + end do +! + end subroutine gen_bottom_colormark +! +! --------------------------------------------------------------------- +! + subroutine gen_right_colormark & + & (iscale, c_minmax, npix_img, isleeve_bar, & + & ntot_pix, iflag_opacity, dimage, color_param) +! + use set_color_4_pvr + use set_rgba_4_each_pixel + use draw_pvr_colorbar_nums +! + integer(kind = kint), intent(in) :: iflag_opacity + integer(kind = kint), intent(in) :: iscale + real(kind = kreal), intent(in) :: c_minmax(2) + integer(kind = kint), intent(in) :: isleeve_bar + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: ntot_pix + type(pvr_colormap_parameter), intent(in) :: color_param +! + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + real(kind = kreal) :: anb_opacity, opa_current + real(kind = kreal) :: value, color(3) + integer(kind = kint) :: i, j, inod + integer(kind = kint) :: num_of_features + integer(kind = kint) :: ist, jst, ied, jed +! +! + call corners_4_right_colorbar & + & (iscale, npix_img, isleeve_bar, ist, jst, ied, jed) +! + num_of_features = color_param%num_opacity_pnt + anb_opacity = color_param%pvr_opacity_param(1,num_of_features) + do j = jst, jed + value = c_minmax(1) + (c_minmax(2)-c_minmax(1)) & + & * dble(j-jst) / dble(jed-jst) +! + if(iflag_opacity .gt. 0) then + call compute_opacity & + & (color_param%id_pvr_color(3), anb_opacity, & + & color_param%num_opacity_pnt, color_param%pvr_opacity_param, & + & value, opa_current) + opa_current = opa_current / color_param%pvr_max_opacity + else + opa_current = 1.0d0 + end if +! + call value_to_rgb & + & (color_param%id_pvr_color(2), color_param%id_pvr_color(1), & + & color_param%num_pvr_datamap_pnt, & + & color_param%pvr_datamap_param, value, color) +! + do i = ist, ist+iscale*l_bar_width()/2-1 + inod = j*npix_img(1) + i + 1 + dimage(1:3,inod) = color(1:3) + dimage(4,inod) = one + end do + do i = ist+iscale*l_bar_width()/2, ist+iscale*l_bar_width()-1 + inod = j*npix_img(1) + i + 1 + dimage(1:3,inod) = color(1:3) * opa_current + dimage(4,inod) = one + end do + end do +! + do i = -iscale/4, (iscale+1)/4 + do j = jst, jed + inod = j*npix_img(1) + ist + i + dimage(1:4,inod) = one + inod = j*npix_img(1) + ied + i + 1 + dimage(1:4,inod) = one + end do + end do +! + do j = -iscale/4, (iscale+1)/4 + do i = ist-1, ied + inod = (jst+j)*npix_img(1) + i + 1 + dimage(1:4,inod) = one + inod = (jed+j)*npix_img(1) + i + 1 + dimage(1:4,inod) = one + end do + end do +! + end subroutine gen_right_colormark +! +! --------------------------------------------------------------------- +! + end module draw_pvr_colorbar diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/draw_pvr_colorbar_nums.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/draw_pvr_colorbar_nums.f90 new file mode 100644 index 00000000..1003f1d6 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/draw_pvr_colorbar_nums.f90 @@ -0,0 +1,396 @@ +!>@file draw_pvr_colorbar_nums.f90 +!!@brief module draw_pvr_colorbar_nums +!! +!!@author H. Matsui +!!@date Programmed in 2008 +! +! +!>@brief Construct number bitmaps +!! +!!@verbatim +!! integer(kind = kint) function l_bar_width() +!! subroutine corners_4_right_colorbar & +!! & (iscale, npix_img, isleeve_bar, ist, jst, ied, jed) +!! subroutine corners_4_bottom_colorbar & +!! & (iscale, npix_img, isleeve_bar, ist, jst, ied, jed) +!! +!! subroutine gen_right_cbar_label(iscale, num_of_scale, c_minmax, & +!! & npix_img, isleeve_bar, ntot_pix, dimage) +!! subroutine gen_right_zero_label(iscale, c_minmax, npix_img, & +!! & isleeve_bar, ntot_pix, dimage) +!! subroutine gen_bottom_cbar_label(iscale, num_of_scale, c_minmax,& +!! & npix_img, isleeve_bar, ntot_pix, dimage) +!! subroutine gen_bottom_zero_label(iscale, c_minmax, npix_img, & +!! & isleeve_bar, ntot_pix, dimage) +!! +!! subroutine gen_time_label(iscale, time, npix_img, & +!! & ntot_pix, dimage) +!! subroutine set_one_label(char1, iscale, ist_px, ist_py, & +!! & npix_img, ntot_pix, dimage) +!!@endverbatim +! + module draw_pvr_colorbar_nums +! + use m_precision +! + use m_constants + use set_color_4_pvr +! + implicit none +! + integer(kind = kint), parameter, private :: BAR_WIDTH = iten + integer(kind = kint), parameter, private :: NUM_LENGTH = inine + integer(kind = kint), parameter, private :: NUM_TIMELABEL = 14 +! + private :: set_numeric_labels +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + integer(kind = kint) function l_bar_width() + l_bar_width = BAR_WIDTH + end function l_bar_width +! +! --------------------------------------------------------------------- +! + subroutine corners_4_right_colorbar & + & (iscale, npix_img, isleeve_bar, ist, jst, ied, jed) +! + integer(kind = kint), intent(in) :: iscale + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: isleeve_bar +! + integer(kind = kint), intent(inout) :: ist, jst, ied, jed +! + ist = npix_img(1) - isleeve_bar + ied = ist + BAR_WIDTH*iscale + jst = (npix_img(2) - 20) / 10 + 10 - 6*iscale + jed = (npix_img(2) - 20) / 10*5 + jst +! + end subroutine corners_4_right_colorbar +! +! --------------------------------------------------------------------- +! + subroutine corners_4_bottom_colorbar & + & (iscale, npix_img, isleeve_bar, ist, jst, ied, jed) +! + integer(kind = kint), intent(in) :: iscale + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: isleeve_bar +! + integer(kind = kint), intent(inout) :: ist, jst, ied, jed +! +! + ist = 1.5 * isleeve_bar + ied = npix_img(1) - 1.5 * isleeve_bar + jst = 16 + 12*iscale + 20 + jed = jst + BAR_WIDTH*iscale +! + end subroutine corners_4_bottom_colorbar +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine gen_right_cbar_label(iscale, num_of_scale, c_minmax, & + & npix_img, isleeve_bar, ntot_pix, dimage) +! + integer(kind = kint), intent(in) :: num_of_scale + real(kind = kreal), intent(in) :: c_minmax(2) + integer(kind = kint), intent(in) :: iscale, isleeve_bar + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: ntot_pix + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + real(kind = kreal) :: value + real(kind = kreal) :: rhgt + integer(kind = kint) :: i, j, k, inod + integer(kind = kint) :: ist, jst, ied, jed + integer(kind = kint) :: start_px(2) + character(len=NUM_LENGTH) :: numeric +! +! + call corners_4_right_colorbar & + & (iscale, npix_img, isleeve_bar, ist, jst, ied, jed) + do k = 1, num_of_scale + value = (c_minmax(2)-c_minmax(1)) & + & * dble(k-1) / dble(num_of_scale-1) + c_minmax(1) +! + rhgt = dble(jed-jst) * dble(k-1) / dble(num_of_scale-1) + start_px(1) = ist + iscale * BAR_WIDTH + ithree + start_px(2) = jst + int(rhgt, KIND(start_px(1))) +! + write(numeric,'(1pe9.2)') value + call set_numeric_labels(NUM_LENGTH, numeric, iscale, start_px, & + & npix_img, ntot_pix, dimage) +! + do j = -iscale/4, (iscale+1)/4 + do i = ist, ied + 4 + inod = (start_px(2)+j) * npix_img(1) + i + 1 + dimage(1:4,inod) = one + end do + end do + end do +! + end subroutine gen_right_cbar_label +! +! --------------------------------------------------------------------- +! + subroutine gen_right_zero_label(iscale, c_minmax, npix_img, & + & isleeve_bar, ntot_pix, dimage) +! + real(kind = kreal), intent(in) :: c_minmax(2) + integer(kind = kint), intent(in) :: iscale, isleeve_bar + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: ntot_pix + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + real(kind = kreal) :: zero_rgb + real(kind = kreal) :: rhgt + integer(kind = kint) :: i, j, inod + integer(kind = kint) :: ist, jst, ied, jed + integer(kind = kint) :: start_px(2) + character(len=NUM_LENGTH) :: numeric +! +! + call corners_4_right_colorbar & + & (iscale, npix_img, isleeve_bar, ist, jst, ied, jed) +! + zero_rgb = (zero - c_minmax(1)) / (c_minmax(2) - c_minmax(1)) +! + rhgt = zero_rgb * dble(jed-jst) + start_px(1) = ist + iscale * BAR_WIDTH + ithree + start_px(2) = jst + int(rhgt, KIND(ntot_pix)) +! + write(numeric,'(1pe9.2)') zero + call set_numeric_labels(NUM_LENGTH, numeric, iscale, start_px, & + & npix_img, ntot_pix, dimage) +! + do j = -iscale/4, (iscale+1)/4 + do i = ist, ied + 4 + inod = (j+start_px(2)) * npix_img(1) + i + 1 + dimage(1:4,inod) = one + end do + end do +! + end subroutine gen_right_zero_label +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine gen_bottom_cbar_label(iscale, num_of_scale, c_minmax, & + & npix_img, isleeve_bar, ntot_pix, dimage) +! + integer(kind = kint), intent(in) :: num_of_scale + real(kind = kreal), intent(in) :: c_minmax(2) + integer(kind = kint), intent(in) :: iscale, isleeve_bar + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: ntot_pix + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + real(kind = kreal) :: value + real(kind = kreal) :: rhgt + integer(kind = kint) :: i, j, k, inod + integer(kind = kint) :: ist_h, jst_h, ied_h, jed_h + integer(kind = kint) :: start_px(2) + character(len=NUM_LENGTH) :: numeric +! +! + call corners_4_bottom_colorbar & + & (iscale, npix_img, isleeve_bar, ist_h, jst_h, ied_h, jed_h) +! + do k = 1, num_of_scale + value = (c_minmax(2)-c_minmax(1)) & + & * dble(k-1) / dble(num_of_scale-1) + c_minmax(1) +! + rhgt = dble(ied_h-ist_h) * dble(k-1) / dble(num_of_scale-1) + start_px(1) = ist_h - iscale*NUM_LENGTH*4 & + & + int(rhgt, KIND(start_px(1))) + start_px(2) = jst_h - 12 * iscale - 5 +! + write(numeric,'(1pe9.2)') value + call set_numeric_labels(NUM_LENGTH, numeric, iscale, start_px, & + & npix_img, ntot_pix, dimage) +! + do i = -iscale/4, (iscale+1)/4 + do j = jst_h-4, jed_h + inod = (j-1) * npix_img(1) & + & + ist_h + i + int(rhgt, KIND(start_px(1))) + dimage(1:4,inod) = one + end do + end do + end do +! + end subroutine gen_bottom_cbar_label +! +! --------------------------------------------------------------------- +! + subroutine gen_bottom_zero_label(iscale, c_minmax, npix_img, & + & isleeve_bar, ntot_pix, dimage) +! + real(kind = kreal), intent(in) :: c_minmax(2) + integer(kind = kint), intent(in) :: iscale, isleeve_bar + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: ntot_pix + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + real(kind = kreal) :: zero_rgb + real(kind = kreal) :: rhgt + integer(kind = kint) :: j, i, inod + integer(kind = kint) :: ist_h, jst_h, ied_h, jed_h + integer(kind = kint) :: start_px(2) + character(len=NUM_LENGTH) :: numeric +! +! + call corners_4_bottom_colorbar & + & (iscale, npix_img, isleeve_bar, ist_h, jst_h, ied_h, jed_h) +! + zero_rgb = (zero - c_minmax(1)) / (c_minmax(2) - c_minmax(1)) +! + rhgt = zero_rgb * dble(ied_h-ist_h) + start_px(1) = ist_h - iscale*NUM_LENGTH*4 & + & + int(rhgt, KIND(start_px(1))) + start_px(2) = jst_h - 12 * iscale - 5 +! + write(numeric,'(1pe9.2)') zero + call set_numeric_labels(NUM_LENGTH, numeric, iscale, start_px, & + & npix_img, ntot_pix, dimage) +! + do i = -iscale/4, (iscale+1)/4 + do j = jst_h-4, jed_h + inod = (j-1) * npix_img(1) & + & + ist_h + i + int(rhgt, KIND(start_px(1))) + dimage(1:4,inod) = one + end do + end do +! + end subroutine gen_bottom_zero_label +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine gen_time_label(iscale, time, npix_img, & + & ntot_pix, dimage) +! + real(kind = kreal), intent(in) :: time + integer(kind = kint), intent(in) :: iscale + integer(kind = kint), intent(in) :: npix_img(2) + integer(kind = kint), intent(in) :: ntot_pix + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + integer(kind = kint) :: start_px(2) + character(len=NUM_TIMELABEL) :: t_label +! +! + start_px(1) = npix_img(1) - 8 * (NUM_TIMELABEL+1) * iscale + start_px(2) = npix_img(2) - iten - 12 * iscale +! + write(t_label,'(a3,1pe11.4)') 't =', time + call set_numeric_labels(NUM_TIMELABEL, t_label, iscale, & + & start_px, npix_img, ntot_pix, dimage) +! + end subroutine gen_time_label +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_numeric_labels(length, numeric, iscale, start_px, & + & npix_img, ntot_pix, dimage) +! + use pvr_font_texture +! + integer(kind = kint), intent(in) :: length + character(len=1), intent(in) :: numeric(length) + integer(kind = kint), intent(in) :: iscale + integer(kind = kint), intent(in) :: start_px(2) + integer(kind = kint), intent(in) :: ntot_pix + integer(kind = kint), intent(in) :: npix_img(2) + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + integer(kind = kint) :: m, ist_px, ist_py + character(len=1) :: char1 +! +! + ist_px = start_px(1) + ist_py = start_px(2) - 6*iscale + do m = 1, length + write(char1,'(a1)') numeric(m) + call set_one_label(char1, iscale, ist_px, ist_py, & + & npix_img, ntot_pix, dimage) + ist_px = ist_px + 8 * iscale + end do +! + end subroutine set_numeric_labels +! +! --------------------------------------------------------------------- +! + subroutine set_one_label(char1, iscale, ist_px, ist_py, & + & npix_img, ntot_pix, dimage) +! + use pvr_font_texture +! + character(len=1), intent(in) :: char1 + integer(kind = kint), intent(in) :: ist_px, ist_py +! + integer(kind = kint), intent(in) :: iscale + integer(kind = kint), intent(in) :: ntot_pix + integer(kind = kint), intent(in) :: npix_img(2) +! + real(kind = kreal), intent(inout) :: dimage(4,ntot_pix) +! + integer(kind = kint) :: i, j, k, ic, jc + integer(kind = kint) :: i_font(8,12) + real(kind = kreal) :: r_font(10,14) +! +! + call gen_font8_12(char1, i_font) +! + r_font(1:10,1:14) = 0.0d0 +! + do i = 1, 8 + do j = 1, 12 + r_font(i, j ) = 0.2 * real(i_font(i,j)) + r_font(i+2,j ) = 0.2 * real(i_font(i,j)) + r_font(i, j+2) = 0.2 * real(i_font(i,j)) +! r_font(i+2,j+2) = 0.2 * real(i_font(i,j)) + end do + end do + do i = 1, 8 + do j = 1, 12 + r_font(i, j+1) = 0.4 * real(i_font(i,j)) + r_font(i+2,j+1) = 0.4 * real(i_font(i,j)) + r_font(i+1,j ) = 0.4 * real(i_font(i,j)) + r_font(i+1,j+2) = 0.4 * real(i_font(i,j)) + end do + end do + do i = 1, 8 + do j = 1, 12 + r_font(i+2,j+2) = 0.6 * real(i_font(i,j)) + end do + end do + do i = 1, 8 + do j = 1, 12 + r_font(i+1,j+1) = 1.0 * real(i_font(i,j)) + end do + end do +! + do i = 1, 10*iscale + do j = 1, 14*iscale +! k = ( (ist_py+j-1)*npix_img(1)+ist_px + i) + k = ( (ist_py+j+1)*npix_img(1)+ist_px + i) + if(k .gt. ntot_pix) cycle + ic = (i-1) / iscale + 1 + jc = 14 - (j-1) / iscale + dimage(1:3,k) = dimage(1:3,k) + r_font(ic,jc) & + & * (one - two*dimage(1:3,k)) + dimage(4,k) = r_font(ic,jc) + end do + end do +! + end subroutine set_one_label +! +! --------------------------------------------------------------------- +! + end module draw_pvr_colorbar_nums diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/each_anaglyph_PVR.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/each_anaglyph_PVR.f90 new file mode 100644 index 00000000..4a357ed4 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/each_anaglyph_PVR.f90 @@ -0,0 +1,224 @@ +!>@file each_anaglyph_PVR.f90 +!!@brief module each_anaglyph_PVR +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +! +!>@brief Main module for each volume rendering +!! +!!@verbatim +!! subroutine each_PVR_anaglyph & +!! & (istep_pvr, time, elps_PVR, mesh, group, jacs, & +!! & nod_fld, tracer, fline, sf_grp_4_sf, field_pvr, & +!! & pvr_param, pvr_proj, pvr_rgb, SR_sig, SR_r) +!! subroutine anaglyph_rendering_w_rotation(istep_pvr, time, & +!! & elps_PVR, mesh, group, jacs, nod_fld, tracer, fline, & +!! & sf_grp_4_sf, field_pvr, pvr_param, pvr_bound, & +!! & pvr_proj, pvr_rgb, SR_sig, SR_r, SR_i) +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(mesh_data), intent(in) :: geofem +!! type(viz_area_parameter), intent(in) :: area_def +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(jacobians_type), intent(in) :: jacs +!! type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +!! type(pvr_field_data), intent(inout) :: field_pvr +!! type(PVR_control_params), intent(inout) :: pvr_param +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! type(PVR_projection_data), intent(inout) :: pvr_proj(2) +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!! type(send_recv_status), intent(inout) :: SR_sig +!! type(send_recv_real_buffer), intent(inout) :: SR_r +!! type(send_recv_int_buffer), intent(inout) :: SR_i +!!@endverbatim +! + module each_anaglyph_PVR +! + use m_precision + use calypso_mpi +! + use m_constants + use m_machine_parameter + use m_geometry_constants +! + use t_mesh_data + use t_phys_data + use t_jacobians + use t_particle_trace + use t_fieldline +! + use t_surf_grp_list_each_surf + use t_rendering_vr_image + use t_control_params_4_pvr + use t_surf_grp_4_pvr_domain + use t_pvr_ray_startpoints + use t_pvr_image_array + use t_geometries_in_pvr_screen + use t_pvr_field_data + use t_mesh_SR +! + use set_default_pvr_params + use set_position_pvr_screen + use mesh_outline_4_pvr + use generate_vr_image + use rendering_streo_vr_image +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine each_PVR_anaglyph & + & (istep_pvr, time, elps_PVR, mesh, group, jacs, & + & nod_fld, tracer, fline, sf_grp_4_sf, field_pvr, & + & pvr_param, pvr_proj, pvr_rgb, SR_sig, SR_r) +! + use cal_pvr_modelview_mat + use rendering_vr_image +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time +! + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +! + type(pvr_field_data), intent(inout) :: field_pvr + type(PVR_control_params), intent(inout) :: pvr_param + type(PVR_projection_data), intent(inout) :: pvr_proj(2) + type(pvr_image_type), intent(inout) :: pvr_rgb + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r +! +! + if(iflag_debug .gt. 0) write(*,*) 'cal_field_4_pvr' + call cal_field_4_each_pvr & + & (mesh%node, mesh%ele, jacs%g_FEM, jacs%jac_3d, nod_fld, & + & pvr_param%field_def, field_pvr) +! + if(iflag_debug .gt. 0) write(*,*) 'set_default_pvr_data_params' + call set_default_pvr_data_params & + & (pvr_param%outline, pvr_param%color) +! +! Left eye + call alloc_pvr_left_eye_image(pvr_rgb) + call rendering_with_fixed_view & + & (istep_pvr, time, elps_PVR, mesh, group, tracer, fline, & + & sf_grp_4_sf, field_pvr, pvr_param, pvr_proj(1), pvr_rgb, & + & SR_sig, SR_r) + call store_left_eye_image(pvr_rgb) +! +! right eye + call rendering_with_fixed_view & + & (istep_pvr, time, elps_PVR, mesh, group, tracer, fline, & + & sf_grp_4_sf, field_pvr, pvr_param, pvr_proj(2), pvr_rgb, & + & SR_sig, SR_r) + call add_left_eye_image(pvr_rgb) + call dealloc_pvr_left_eye_image(pvr_rgb) +! + end subroutine each_PVR_anaglyph +! +! --------------------------------------------------------------------- +! + subroutine anaglyph_rendering_w_rotation(istep_pvr, time, & + & elps_PVR, mesh, group, jacs, nod_fld, tracer, fline, & + & sf_grp_4_sf, field_pvr, pvr_param, pvr_bound, & + & pvr_proj, pvr_rgb, SR_sig, SR_r, SR_i) +! + use m_work_time + use t_rotation_pvr_images + use write_multi_PVR_image + use set_PVR_view_and_image + use set_default_pvr_params + use output_image_sel_4_png + use rendering_vr_image +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time +! + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +! + type(pvr_field_data), intent(inout) :: field_pvr + type(PVR_control_params), intent(inout) :: pvr_param + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(PVR_projection_data), intent(inout) :: pvr_proj(2) + type(pvr_image_type), intent(inout) :: pvr_rgb + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r + type(send_recv_int_buffer), intent(inout) :: SR_i +! + integer(kind = kint) :: i_rot + type(rotation_pvr_images) :: rot_imgs1 +! +! + if(iflag_debug .gt. 0) write(*,*) 'cal_field_4_pvr' + call cal_field_4_each_pvr & + & (mesh%node, mesh%ele, jacs%g_FEM, jacs%jac_3d, nod_fld, & + & pvr_param%field_def, field_pvr) +! + if(iflag_debug .gt. 0) write(*,*) 'set_default_pvr_data_params' + call set_default_pvr_data_params & + & (pvr_param%outline, pvr_param%color) +! + if(my_rank .eq. 0) write(*,*) 'init_rot_pvr_image_arrays' + call init_rot_pvr_image_arrays & + & (pvr_param%movie_def, pvr_rgb, rot_imgs1) +! +! + call alloc_pvr_left_eye_image(pvr_rgb) + do i_rot = 1, pvr_param%movie_def%num_frame +! Left eye + call rot_multi_view_projection_mats(ione, i_rot, & + & pvr_param, pvr_proj(1)%screen) + call rendering_at_once & + & (istep_pvr, time, elps_PVR, mesh, group, tracer, fline, & + & sf_grp_4_sf, field_pvr, pvr_param, pvr_bound, & + & pvr_proj(1), pvr_rgb, SR_sig, SR_r, SR_i) + call store_left_eye_image(pvr_rgb) +! +! Right eye + call rot_multi_view_projection_mats(itwo, i_rot, & + & pvr_param, pvr_proj(2)%screen) + call rendering_at_once & + & (istep_pvr, time, elps_PVR, mesh, group, tracer, fline, & + & sf_grp_4_sf, field_pvr, pvr_param, pvr_bound, & + & pvr_proj(2), pvr_rgb, SR_sig, SR_r, SR_i) + call add_left_eye_image(pvr_rgb) + call copy_pvr_image_data(pvr_rgb, rot_imgs1%rot_pvr_rgb(i_rot)) + end do + call dealloc_pvr_left_eye_image(pvr_rgb) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+1) +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+2) + call output_rotation_PVR_images(istep_pvr, & + & pvr_param%movie_def%num_frame, rot_imgs1%rot_pvr_rgb(1)) + call dealloc_rot_pvr_image_arrays(pvr_param%movie_def, rot_imgs1) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+2) + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+1) +! + end subroutine anaglyph_rendering_w_rotation +! +! --------------------------------------------------------------------- +! + end module each_anaglyph_PVR diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/each_volume_rendering.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/each_volume_rendering.f90 new file mode 100644 index 00000000..8736dad0 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/each_volume_rendering.f90 @@ -0,0 +1,346 @@ +!>@file each_volume_rendering.f90 +!!@brief module each_volume_rendering +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +! +!>@brief Main module for each volume rendering +!! +!!@verbatim +!! subroutine init_each_PVR_image(num_img, pvr_param, pvr_rgb) +!! subroutine each_PVR_initialize(mesh, group, & +!! & pvr_param, pvr_bound) +!! integer(kind = kint), intent(in) :: i_pvr, num_img +!! type(mesh_geometry), intent(in) :: mesh +!! type(mesh_groups), intent(in) :: group +!! type(PVR_control_params), intent(inout) :: pvr_param +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! subroutine dealloc_PVR_initialize & +!! & (num_proj, pvr_param, pvr_bound, pvr_proj) +!! integer(kind = kint), intent(in) :: num_proj +!! type(PVR_control_params), intent(inout) :: pvr_param +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! type(PVR_projection_data), intent(inout) :: pvr_proj(num_proj) +!! +!! subroutine each_PVR_rendering & +!! & (istep_pvr, time, num_img, elps_PVR, geofem, jacs, & +!! & nod_fld, tracer, fline, sf_grp_4_sf, field_pvr, & +!! & pvr_param, pvr_proj, pvr_rgb, SR_sig, SR_r) +!! subroutine each_PVR_rendering_w_rot(istep_pvr, time, elps_PVR, & +!! & geofem, jacs, nod_fld, tracer, fline, sf_grp_4_sf, & +!! & field_pvr, pvr_param, pvr_bound, pvr_rgb, pvr_proj, & +!! & SR_sig, SR_r, SR_i) +!! subroutine each_PVR_quilt_rendering_w_rot & +!! & (istep_pvr, time, num_img, elps_PVR, geofem, jacs, & +!! & nod_fld, tracer, fline, sf_grp_4_sf, field_pvr, & +!! & pvr_param, pvr_bound, pvr_proj, pvr_rgb, & +!! & SR_sig, SR_r, SR_i) +!! type(elapsed_lables), intent(in) :: elps_PVR, elps_LIC +!! type(mesh_data), intent(in) :: geofem +!! type(viz_area_parameter), intent(in) :: area_def +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(jacobians_type), intent(in) :: jacs +!! type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +!! type(pvr_field_data), intent(inout) :: field_pvr +!! type(PVR_control_params), intent(inout) :: pvr_param +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! type(PVR_projection_data), intent(inout) :: pvr_proj(2) +!! type(pvr_image_type), intent(inout) :: pvr_rgb(2) +!! type(send_recv_status), intent(inout) :: SR_sig +!! type(send_recv_real_buffer), intent(inout) :: SR_r +!! type(send_recv_int_buffer), intent(inout) :: SR_i +!!@endverbatim +! + module each_volume_rendering +! + use m_precision + use calypso_mpi +! + use m_constants + use m_machine_parameter + use m_geometry_constants +! + use t_mesh_data + use t_phys_data + use t_jacobians + use t_particle_trace + use t_fieldline +! + use t_surf_grp_list_each_surf + use t_rendering_vr_image + use t_control_params_4_pvr + use t_surf_grp_4_pvr_domain + use t_pvr_ray_startpoints + use t_pvr_image_array + use t_geometries_in_pvr_screen + use t_pvr_field_data + use t_mesh_SR +! + use set_default_pvr_params + use set_position_pvr_screen + use mesh_outline_4_pvr + use generate_vr_image + use rendering_streo_vr_image +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine init_each_PVR_image(num_img, pvr_param, pvr_rgb) +! + integer(kind = kint), intent(in) :: num_img + type(PVR_control_params), intent(in) :: pvr_param + type(pvr_image_type), intent(inout) :: pvr_rgb(num_img) +! + integer(kind = kint) :: i_img +! +! + do i_img = 1, num_img + call alloc_pvr_image_array & + & (pvr_param%multi_view(1)%n_pvr_pixel, pvr_rgb(i_img)) + end do +! + end subroutine init_each_PVR_image +! +! --------------------------------------------------------------------- +! + subroutine each_PVR_initialize(mesh, group, & + & pvr_param, pvr_bound) +! + use t_control_data_pvr_sections + use set_pvr_control + use find_pvr_surf_domain + use set_iflag_for_used_ele +! + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group +! + type(PVR_control_params), intent(inout) :: pvr_param + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +! +! + call alloc_iflag_pvr_used_ele(mesh%ele, pvr_param%draw_param) + call s_set_iflag_for_used_ele(mesh%ele, group%ele_grp, & + & pvr_param%area_def%nele_grp_area_pvr, & + & pvr_param%area_def%id_ele_grp_area_pvr, & + & pvr_param%draw_param%iflag_used_ele) +! + call find_each_pvr_surf_domain(mesh%ele, mesh%surf, & + & pvr_param%draw_param, pvr_bound) +! + call pvr_mesh_outline(mesh%node, pvr_param%outline) + call check_pvr_parameters(pvr_param%outline, & + & pvr_param%num_multi_views, pvr_param%multi_view, & + & pvr_param%color) +! + call set_pixel_on_pvr_screen(pvr_param%multi_view(1), & + & pvr_param%pixel) +! + end subroutine each_PVR_initialize +! +! --------------------------------------------------------------------- +! + subroutine dealloc_PVR_initialize & + & (num_proj, pvr_param, pvr_bound, pvr_proj) +! + integer(kind = kint), intent(in) :: num_proj + type(PVR_control_params), intent(inout) :: pvr_param + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(PVR_projection_data), intent(inout) :: pvr_proj(num_proj) +! + integer(kind = kint) :: i_proj +! + do i_proj = 1, num_proj + call deallocate_item_pvr_ray_start(pvr_proj(i_proj)%start_save) + call deallocate_pvr_ray_start(pvr_proj(i_proj)%start_fix) + call dealloc_pvr_stencil_buffer(pvr_proj(i_proj)%stencil) + end do +! + call dealloc_pvr_surf_domain_item(pvr_bound) + call dealloc_pixel_position_pvr(pvr_param%pixel) + call dealloc_iflag_pvr_used_ele(pvr_param%draw_param) +! + end subroutine dealloc_PVR_initialize +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine each_PVR_rendering & + & (istep_pvr, time, num_img, elps_PVR, geofem, jacs, & + & nod_fld, tracer, fline, sf_grp_4_sf, field_pvr, & + & pvr_param, pvr_proj, pvr_rgb, SR_sig, SR_r) +! + use cal_pvr_modelview_mat + use rendering_vr_image +! + integer(kind = kint), intent(in) :: num_img + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time +! + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs +! + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf + type(pvr_field_data), intent(inout) :: field_pvr + type(PVR_control_params), intent(inout) :: pvr_param + type(PVR_projection_data), intent(inout) :: pvr_proj(num_img) + type(pvr_image_type), intent(inout) :: pvr_rgb(num_img) + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r +! + integer(kind = kint) :: i_img +! + if(iflag_debug .gt. 0) write(*,*) 'cal_field_4_pvr' + call cal_field_4_each_pvr(geofem%mesh%node, geofem%mesh%ele, & + & jacs%g_FEM, jacs%jac_3d, nod_fld, & + & pvr_param%field_def, field_pvr) +! + if(iflag_debug .gt. 0) write(*,*) 'set_default_pvr_data_params' + call set_default_pvr_data_params & + & (pvr_param%outline, pvr_param%color) +! + do i_img = 1, num_img + call rendering_with_fixed_view(istep_pvr, time, elps_PVR, & + & geofem%mesh, geofem%group, tracer, fline, sf_grp_4_sf, & + & field_pvr, pvr_param, pvr_proj(i_img), pvr_rgb(i_img), & + & SR_sig, SR_r) + end do +! + end subroutine each_PVR_rendering +! +! --------------------------------------------------------------------- +! + subroutine each_PVR_rendering_w_rot(istep_pvr, time, elps_PVR, & + & geofem, jacs, nod_fld, tracer, fline, sf_grp_4_sf, & + & field_pvr, pvr_param, pvr_bound, pvr_rgb, pvr_proj, & + & SR_sig, SR_r, SR_i) +! + use cal_pvr_modelview_mat +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time +! + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +! + type(pvr_field_data), intent(inout) :: field_pvr + type(PVR_control_params), intent(inout) :: pvr_param + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(PVR_projection_data), intent(inout) :: pvr_proj + type(pvr_image_type), intent(inout) :: pvr_rgb + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r + type(send_recv_int_buffer), intent(inout) :: SR_i +! +! + if(iflag_debug .gt. 0) write(*,*) 'cal_field_4_pvr' + call calypso_mpi_barrier + call cal_field_4_each_pvr(geofem%mesh%node, geofem%mesh%ele, & + & jacs%g_FEM, jacs%jac_3d, nod_fld, & + & pvr_param%field_def, field_pvr) +! + if(iflag_debug .gt. 0) write(*,*) 'set_default_pvr_data_params' + call set_default_pvr_data_params & + & (pvr_param%outline, pvr_param%color) +! +! + call rendering_with_rotation & + & (istep_pvr, time, elps_PVR, geofem%mesh, geofem%group, & + & tracer, fline, sf_grp_4_sf, field_pvr, pvr_rgb, pvr_param, & + & pvr_bound, pvr_proj, SR_sig, SR_r, SR_i) +! + end subroutine each_PVR_rendering_w_rot +! +! --------------------------------------------------------------------- +! + subroutine each_PVR_quilt_rendering_w_rot & + & (istep_pvr, time, num_img, elps_PVR, geofem, jacs, & + & nod_fld, tracer, fline, sf_grp_4_sf, field_pvr, & + & pvr_param, pvr_bound, pvr_proj, pvr_rgb, & + & SR_sig, SR_r, SR_i) +! + use m_work_time + use set_PVR_view_and_image + use rendering_vr_image + use write_PVR_image +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time + integer(kind = kint), intent(in) :: num_img +! + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +! + type(pvr_field_data), intent(inout) :: field_pvr + type(PVR_control_params), intent(inout) :: pvr_param + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(PVR_projection_data), intent(inout) :: pvr_proj(num_img) + type(pvr_image_type), intent(inout) :: pvr_rgb(num_img) + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r + type(send_recv_int_buffer), intent(inout) :: SR_i +! + integer(kind = kint) :: i_img, i_rot +! + if(iflag_debug .gt. 0) write(*,*) 'cal_field_4_pvr' + call calypso_mpi_barrier + call cal_field_4_each_pvr(geofem%mesh%node, geofem%mesh%ele, & + & jacs%g_FEM, jacs%jac_3d, nod_fld, & + & pvr_param%field_def, field_pvr) +! + if(iflag_debug .gt. 0) write(*,*) 'set_default_pvr_data_params' + call set_default_pvr_data_params & + & (pvr_param%outline, pvr_param%color) +! + do i_rot = 1, pvr_param%movie_def%num_frame + do i_img = 1, num_img + call rot_multi_view_projection_mats(i_img, i_rot, & + & pvr_param, pvr_proj(i_img)%screen) + call rendering_at_once(istep_pvr, time, elps_PVR, & + & geofem%mesh, geofem%group, tracer, fline, sf_grp_4_sf, & + & field_pvr, pvr_param, pvr_bound, pvr_proj(i_img), & + & pvr_rgb(i_img), SR_sig, SR_r, SR_i) + end do + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+1) +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+2) + call set_output_rot_sequence_image(istep_pvr, i_rot, & + & pvr_rgb(1)%id_pvr_file_type, pvr_rgb(1)%pvr_prefix, & + & num_img, pvr_param%stereo_def%n_column_row_view, & + & pvr_rgb) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+2) + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+1) + end do +! + end subroutine each_PVR_quilt_rendering_w_rot +! +! --------------------------------------------------------------------- +! + end module each_volume_rendering diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/elapsed_labels_4_PVR.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/elapsed_labels_4_PVR.f90 new file mode 100644 index 00000000..950e23dc --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/elapsed_labels_4_PVR.f90 @@ -0,0 +1,183 @@ +!>@file elapsed_labels_4_PVR.f90 +!!@brief module elapsed_labels_4_PVR +!! +!!@author H. Matsui +!!@date Programmed in April, 2013 +! +!>@brief Initialize elepsed time monitoring +!! +!!@verbatim +!! subroutine elpsed_label_4_PVR(elps_PVR, elps) +!! subroutine reset_elapse_after_init_PVR(elps_PVR, elps) +!! type(elapsed_lables), intent(inout) :: elps_PVR +!! type(elapsed_time_data), intent(inout) :: elps +!! +!! subroutine elpsed_label_4_LIC(elps_LIC, elps) +!! subroutine reset_elapse_after_init_LIC(elps_LIC, elps) +!! type(elapsed_lables), intent(inout) :: elps_LIC +!! type(elapsed_time_data), intent(inout) :: elps +!! +!! subroutine elpsed_label_4_MAP(elps_map, elps) +!! subroutine reset_elapse_after_init_MAP(elps_map, elps) +!! type(elapsed_lables), intent(inout) :: elps_map +!! type(elapsed_time_data), intent(inout) :: elps +!!@endverbatim +! + module elapsed_labels_4_PVR +! + use m_precision + use m_work_time +! + implicit none +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine elpsed_label_4_PVR(elps_PVR, elps) +! + type(elapsed_lables), intent(inout) :: elps_PVR + type(elapsed_time_data), intent(inout) :: elps +! + integer(kind = kint), parameter :: num_append = 12 +! +! + call append_elapsed_timer(num_append, elps_PVR%ist_elapsed, & + & elps_PVR%ied_elapsed, elps) +! + elps%labels(elps_PVR%ist_elapsed+1) & + & = 'Volume rendering w/o file output ' + elps%labels(elps_PVR%ist_elapsed+2) & + & = 'Volume rendering file output ' + elps%labels(elps_PVR%ist_elapsed+3) & + & = 'V. Rendering ray trace ' + elps%labels(elps_PVR%ist_elapsed+4) & + & = 'V. Rendering subimage composit ' +! + elps%labels(elps_PVR%ist_elapsed+5) & + & = 'bcast_pvr_controls ' + elps%labels(elps_PVR%ist_elapsed+6) & + & = 'set_pvr_controls ' + elps%labels(elps_PVR%ist_elapsed+7) & + & = 'each_PVR_initialize ' + elps%labels(elps_PVR%ist_elapsed+8) & + & = 's_const_comm_tbl_img_output ' + elps%labels(elps_PVR%ist_elapsed+9) & + & = 's_const_comm_tbl_img_composit ' + elps%labels(elps_PVR%ist_elapsed+10) & + & = 'calypso_SR_type_int pvr_init ' + elps%labels(elps_PVR%ist_elapsed+11) & + & = 'calypso_SR_type_1 pvr_init ' + elps%labels(elps_PVR%ist_elapsed+12) & + & = 'set_image_stacking_and_recv ' +! + elps_PVR%flag_elapsed = .TRUE. +! + end subroutine elpsed_label_4_PVR +! +!----------------------------------------------------------------------- +! + subroutine reset_elapse_after_init_PVR(elps_PVR, elps) +! + type(elapsed_lables), intent(inout) :: elps_PVR + type(elapsed_time_data), intent(inout) :: elps +! + if(elps_PVR%flag_elapsed .eqv. .FALSE.) return + call reset_elapsed_timer(elps_PVR%ist_elapsed+1, & + & elps_PVR%ied_elapsed, elps) +! + end subroutine reset_elapse_after_init_PVR +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine elpsed_label_4_LIC(elps_LIC, elps) +! + type(elapsed_lables), intent(inout) :: elps_LIC + type(elapsed_time_data), intent(inout) :: elps +! + integer(kind = kint), parameter :: num_append = 9 +! +! + call append_elapsed_timer(num_append, elps_LIC%ist_elapsed, & + & elps_LIC%ied_elapsed, elps) +! + elps%labels(elps_LIC%ist_elapsed+1) & + & = 'LIC V. rendering w/o file output ' + elps%labels(elps_LIC%ist_elapsed+2) & + & = 'LIC V. rendering file output ' + elps%labels(elps_LIC%ist_elapsed+3) & + & = 'LIC V. Rendering ray trace ' + elps%labels(elps_LIC%ist_elapsed+4) & + & = 'Line integration for LIC ' + elps%labels(elps_LIC%ist_elapsed+5) & + & = 'LIC V. Rendering subimage composit ' + elps%labels(elps_LIC%ist_elapsed+6) & + & = 'LIC V. Rendering domain repartition ' + elps%labels(elps_LIC%ist_elapsed+7) & + & = 'LIC data transfer to new domain ' + elps%labels(elps_LIC%ist_elapsed+8) & + & = 'FEM_mesh_initialization for LIC mesh ' + elps%labels(elps_LIC%ist_elapsed+9) & + & = 'Data IO for line integration counts ' +! + elps_LIC%flag_elapsed = .TRUE. +! + end subroutine elpsed_label_4_LIC +! +!----------------------------------------------------------------------- +! + subroutine reset_elapse_after_init_LIC(elps_LIC, elps) +! + type(elapsed_lables), intent(in) :: elps_LIC + type(elapsed_time_data), intent(inout) :: elps +! + if(elps_LIC%flag_elapsed .eqv. .FALSE.) return + call reset_elapsed_timer(elps_LIC%ist_elapsed+1, & + & elps_LIC%ied_elapsed, elps) +! + end subroutine reset_elapse_after_init_LIC +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine elpsed_label_4_MAP(elps_map, elps) +! + type(elapsed_lables), intent(inout) :: elps_map + type(elapsed_time_data), intent(inout) :: elps +! + integer(kind = kint), parameter :: num_append = 3 +! +! + call append_elapsed_timer(num_append, elps_map%ist_elapsed, & + & elps_map%ied_elapsed, elps) +! + elps%labels(elps_map%ist_elapsed+1) & + & = 'Collect map data ' + elps%labels(elps_map%ist_elapsed+2) & + & = 'Interpolate data on map ' + elps%labels(elps_map%ist_elapsed+3) & + & = 'Output Map image ' +! + elps_map%flag_elapsed = .TRUE. +! + end subroutine elpsed_label_4_MAP +! +!----------------------------------------------------------------------- +! + subroutine reset_elapse_after_init_MAP(elps_map, elps) +! + type(elapsed_lables), intent(in) :: elps_map + type(elapsed_time_data), intent(inout) :: elps +! + if(elps_map%flag_elapsed .eqv. .FALSE.) return + call reset_elapsed_timer(elps_map%ist_elapsed+2, & + & elps_map%ist_elapsed+2, elps) +! + end subroutine reset_elapse_after_init_MAP +! +!----------------------------------------------------------------------- +! + end module elapsed_labels_4_PVR diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/find_pvr_surf_domain.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/find_pvr_surf_domain.f90 new file mode 100644 index 00000000..aa84c6b8 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/find_pvr_surf_domain.f90 @@ -0,0 +1,331 @@ +!>@file find_pvr_surf_domain.f90 +!!@brief module find_pvr_surf_domain +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!>@brief Construct subdomain surface information for PVR +!! +!!@verbatim +!! subroutine find_each_pvr_surf_domain & +!! & (ele, surf, draw_param, pvr_bound) +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(rendering_parameter), intent(in) :: draw_param +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! subroutine set_pvr_domain_surface_data(n_pvr_pixel, node, surf, & +!! & modelview_mat, projection_mat, pvr_bound) +!! type(node_data), intent(in) :: node +!! type(surface_data), intent(in) :: surf +!! integer(kind = kint), intent(in) :: n_pvr_pixel(2) +!! real(kind = kreal), intent(in) :: modelview_mat(4,4) +!! real(kind = kreal), intent(in) :: projection_mat(4,4) +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! subroutine norm_on_model_pvr_domains(node, surf, modelview_mat, & +!! & num_pvr_surf, item_pvr_surf_domain, & +!! & screen_norm_pvr_domain) +!! type(node_data), intent(in) :: node +!! type(surface_data), intent(in) :: surf +!! real(kind = kreal), intent(in) :: modelview_mat(4,4) +!! integer(kind = kint), intent(in) :: num_pvr_surf +!! integer(kind = kint), intent(in) & +!! & :: item_pvr_surf_domain(2,num_pvr_surf) +!! real(kind = kreal), intent(inout) & +!! & :: screen_norm_pvr_domain(3,num_pvr_surf) +!! subroutine deallocate_pvr_surf_domain(num_pvr, pvr_bound) +!!@endverbatim +! + module find_pvr_surf_domain +! + use m_precision +! + use m_constants + use m_geometry_constants + use t_geometry_data + use t_surface_data +! + implicit none +! + integer(kind = kint), allocatable, private :: imark_sf(:) +! + private :: range_on_screen_pvr_domains + private :: range_on_pixel_pvr_domains +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine find_each_pvr_surf_domain & + & (ele, surf, draw_param, pvr_bound) +! + use t_control_params_4_pvr + use t_surf_grp_4_pvr_domain + use t_geometries_in_pvr_screen + use find_selected_domain_bd + use pvr_surface_enhancement +! + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(rendering_parameter), intent(in) :: draw_param +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +! + integer(kind = kint) :: num_pvr_sf_local +! +! + allocate(imark_sf(surf%numsurf)) +!$omp parallel workshare + imark_sf(1:surf%numsurf) = 0 +!$omp end parallel workshare +! + call mark_selected_domain_bd & + & (ele%numele, surf%numsurf, surf%isf_4_ele, & + & draw_param%iflag_used_ele, imark_sf) + call count_selected_domain_bd & + & (surf%numsurf, imark_sf, num_pvr_sf_local) +! + call alloc_pvr_surf_domain_item(num_pvr_sf_local, pvr_bound) +! + call s_find_selected_domain_bd(ele%numele, surf%numsurf, & + & surf%iele_4_surf, imark_sf, draw_param%iflag_used_ele, & + & pvr_bound%num_pvr_surf, pvr_bound%item_pvr_surf) +! + deallocate(imark_sf) +! + end subroutine find_each_pvr_surf_domain +! +! ----------------------------------------------------------------------- +! + subroutine set_pvr_domain_surface_data(n_pvr_pixel, node, surf, & + & modelview_mat, projection_mat, pvr_bound) +! + use t_control_params_4_pvr + use t_surf_grp_4_pvr_domain + use ordering_pvr_sf_domain_grp +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf + integer(kind = kint), intent(in) :: n_pvr_pixel(2) + real(kind = kreal), intent(in) :: modelview_mat(4,4) + real(kind = kreal), intent(in) :: projection_mat(4,4) +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +! +! +!$omp parallel + call range_on_screen_pvr_domains & + & (node, surf, modelview_mat, projection_mat, & + & pvr_bound%num_pvr_surf, pvr_bound%item_pvr_surf, & + & pvr_bound%screen_posi, pvr_bound%screen_w, & + & pvr_bound%screen_xrng, pvr_bound%screen_yrng, & + & pvr_bound%screen_zrng) + call range_on_pixel_pvr_domains & + & (n_pvr_pixel, pvr_bound%num_pvr_surf, & + & pvr_bound%screen_xrng, pvr_bound%screen_yrng, & + & pvr_bound%isurf_xrng, pvr_bound%jsurf_yrng) +!$omp end parallel +! + call s_ordering_pvr_sf_domain_grp(pvr_bound) +! + end subroutine set_pvr_domain_surface_data +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine norm_on_model_pvr_domains(node, surf, modelview_mat, & + & num_pvr_surf, item_pvr_surf_domain, & + & screen_norm_pvr_domain) +! + use cal_fline_in_cube + use set_position_pvr_screen +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf + real(kind = kreal), intent(in) :: modelview_mat(4,4) +! + integer(kind = kint), intent(in) :: num_pvr_surf + integer(kind = kint), intent(in) & + & :: item_pvr_surf_domain(2,num_pvr_surf) +! + real(kind = kreal), intent(inout) & + & :: screen_norm_pvr_domain(3,num_pvr_surf) +! + integer(kind = kint) :: inum, iele, k1, isurf + real(kind = kreal) :: x31(3), x42(3), vlen + real(kind = kreal) :: xx4_model_sf(4,num_linear_sf,nsurf_4_ele) +! +! +!$omp parallel do private(inum,iele,k1,isurf,xx4_model_sf,x31,x42,vlen) + do inum = 1, num_pvr_surf + iele = item_pvr_surf_domain(1,inum) + k1 = item_pvr_surf_domain(2,inum) + isurf = abs(surf%isf_4_ele(iele,k1)) +! + call position_on_each_ele_sfs_wone & + & (surf, node%numnod, node%xx, iele, xx4_model_sf) + call overwte_to_modelview_each_ele(modelview_mat, & + & (num_linear_sf*nsurf_4_ele), xx4_model_sf(1,1,1)) + x31(1:3) = xx4_model_sf(1:3,3,k1) - xx4_model_sf(1:3,1,k1) + x42(1:3) = xx4_model_sf(1:3,4,k1) - xx4_model_sf(1:3,2,k1) +! + screen_norm_pvr_domain(1,inum) & + & = (x31(2)*x42(3) - x31(3)*x42(2)) & + & * dble(surf%isf_4_ele(iele,k1) /isurf) + screen_norm_pvr_domain(2,inum) & + & = (x31(3)*x42(1) - x31(1)*x42(3)) & + & * dble(surf%isf_4_ele(iele,k1) /isurf) + screen_norm_pvr_domain(3,inum) & + & = (x31(1)*x42(2) - x31(2)*x42(1)) & + & * dble(surf%isf_4_ele(iele,k1) /isurf) +! + vlen = sqrt(screen_norm_pvr_domain(1,inum)**2 & + & + screen_norm_pvr_domain(2,inum)**2 & + & + screen_norm_pvr_domain(3,inum)**2) +! + if(vlen .gt. zero) then + screen_norm_pvr_domain(1,inum) & + & = screen_norm_pvr_domain(1,inum) / vlen + screen_norm_pvr_domain(2,inum) & + & = screen_norm_pvr_domain(2,inum) / vlen + screen_norm_pvr_domain(3,inum) & + & = screen_norm_pvr_domain(3,inum) / vlen + end if + end do +!$omp end parallel do +! + end subroutine norm_on_model_pvr_domains +! +! ----------------------------------------------------------------------- +! + subroutine range_on_screen_pvr_domains & + & (node, surf, modelview_mat, projection_mat, & + & num_pvr_surf, item_pvr_surf_domain, & + & screen_posi_pvr_domain, screen_w_pvr_domain, & + & screen_xrng_pvr_domain, screen_yrng_pvr_domain, & + & screen_zrng_pvr_domain) +! + use cal_fline_in_cube + use set_position_pvr_screen +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf +! + real(kind = kreal), intent(in) :: modelview_mat(4,4) + real(kind = kreal), intent(in) :: projection_mat(4,4) +! + integer(kind = kint), intent(in) :: num_pvr_surf + integer(kind = kint), intent(in) & + & :: item_pvr_surf_domain(2,num_pvr_surf) +! + real(kind = kreal), intent(inout) & + & :: screen_posi_pvr_domain(3,num_pvr_surf) + real(kind = kreal), intent(inout) & + & :: screen_w_pvr_domain(num_pvr_surf) +! + real(kind = kreal), intent(inout) & + & :: screen_xrng_pvr_domain(2,num_pvr_surf) + real(kind = kreal), intent(inout) & + & :: screen_yrng_pvr_domain(2,num_pvr_surf) + real(kind = kreal), intent(inout) & + & :: screen_zrng_pvr_domain(2,num_pvr_surf) +! + integer(kind = kint) :: inum, iele, k1, isurf + real(kind = kreal) :: x1(3), x2(3), x3(3), x4(3), w(4) + real(kind = kreal) :: xx4_model_sf(4,num_linear_sf,nsurf_4_ele) +! +! +!$omp do private (inum,iele,k1,isurf,xx4_model_sf,x1,x2,x3,x4,w) + do inum = 1, num_pvr_surf + iele = item_pvr_surf_domain(1,inum) + k1 = item_pvr_surf_domain(2,inum) + isurf = abs(surf%isf_4_ele(iele,k1)) +! + call position_on_each_ele_sfs_wone & + & (surf, node%numnod, node%xx, iele, xx4_model_sf) + call project_once_each_element(modelview_mat, projection_mat, & + & (num_linear_sf*nsurf_4_ele), xx4_model_sf(1,1,1)) + x1(1:3) = xx4_model_sf(1:3,1,k1) + x2(1:3) = xx4_model_sf(1:3,2,k1) + x3(1:3) = xx4_model_sf(1:3,3,k1) + x4(1:3) = xx4_model_sf(1:3,4,k1) + w(1:4) = xx4_model_sf(4,1:4,k1) +! + screen_posi_pvr_domain(1:3,inum) & + & = (x1(1:3) + x2(1:3) + x3(1:3) + x4(1:3)) / four + screen_w_pvr_domain(inum) = (w(1)+w(2)+w(3)+w(4)) / four +! + screen_xrng_pvr_domain(1,inum) = min(x1(1),x2(1),x3(1),x4(1)) + screen_xrng_pvr_domain(2,inum) = max(x1(1),x2(1),x3(1),x4(1)) + screen_yrng_pvr_domain(1,inum) = min(x1(2),x2(2),x3(2),x4(2)) + screen_yrng_pvr_domain(2,inum) = max(x1(2),x2(2),x3(2),x4(2)) + screen_zrng_pvr_domain(1,inum) = min(x1(3),x2(3),x3(3),x4(3)) + screen_zrng_pvr_domain(2,inum) = max(x1(3),x2(3),x3(3),x4(3)) + end do +!$omp end do +! + end subroutine range_on_screen_pvr_domains +! +! ----------------------------------------------------------------------- +! + subroutine range_on_pixel_pvr_domains(n_pvr_pixel, num_pvr_surf, & + & screen_xrng_pvr_domain, screen_yrng_pvr_domain, & + & isurf_xrng_pvr_domain, jsurf_yrng_pvr_domain) +! + integer(kind = kint), intent(in) :: n_pvr_pixel(2) +! + integer(kind = kint), intent(in) :: num_pvr_surf + real(kind = kreal), intent(in) & + & :: screen_xrng_pvr_domain(2,num_pvr_surf) + real(kind = kreal), intent(in) & + & :: screen_yrng_pvr_domain(2,num_pvr_surf) +! + integer(kind = kint), intent(inout) & + & :: isurf_xrng_pvr_domain(2,num_pvr_surf) + integer(kind = kint), intent(inout) & + & :: jsurf_yrng_pvr_domain(2,num_pvr_surf) +! + integer(kind = kint) :: inum +! +! +!$omp do private (inum) + do inum = 1, num_pvr_surf + isurf_xrng_pvr_domain(1,inum) & + & = nint( (screen_xrng_pvr_domain(1,inum) + one) & + & * half * dble(n_pvr_pixel(1)) ) + isurf_xrng_pvr_domain(2,inum) & + & = nint( (screen_xrng_pvr_domain(2,inum) + one) & + & * half * dble(n_pvr_pixel(1)) ) + jsurf_yrng_pvr_domain(1,inum) & + & = nint( (screen_yrng_pvr_domain(1,inum) + one) & + & * half * dble(n_pvr_pixel(2)) ) + jsurf_yrng_pvr_domain(2,inum) & + & = nint( (screen_yrng_pvr_domain(2,inum) + one) & + & * half * dble(n_pvr_pixel(2)) ) +! + isurf_xrng_pvr_domain(1,inum) & + & = max(isurf_xrng_pvr_domain(1,inum),ione) + isurf_xrng_pvr_domain(1,inum) & + & = min(isurf_xrng_pvr_domain(1,inum),n_pvr_pixel(1)) + isurf_xrng_pvr_domain(2,inum) & + & = max(isurf_xrng_pvr_domain(2,inum),ione) + isurf_xrng_pvr_domain(2,inum) & + & = min(isurf_xrng_pvr_domain(2,inum),n_pvr_pixel(1)) +! + jsurf_yrng_pvr_domain(1,inum) & + & = max(jsurf_yrng_pvr_domain(1,inum),ione) + jsurf_yrng_pvr_domain(1,inum) & + & = min(jsurf_yrng_pvr_domain(1,inum),n_pvr_pixel(2)) + jsurf_yrng_pvr_domain(2,inum) & + & = max(jsurf_yrng_pvr_domain(2,inum),ione) + jsurf_yrng_pvr_domain(2,inum) & + & = min(jsurf_yrng_pvr_domain(2,inum),n_pvr_pixel(2)) + end do +!$omp end do +! + end subroutine range_on_pixel_pvr_domains +! +! ----------------------------------------------------------------------- +! + end module find_pvr_surf_domain diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/generate_vr_image.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/generate_vr_image.f90 new file mode 100644 index 00000000..e51bb861 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/generate_vr_image.f90 @@ -0,0 +1,173 @@ +!>@file generate_vr_image.f90 +!! module generate_vr_image +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structures for position in the projection coordinate +!! +!!@verbatim +!! subroutine transfer_to_screen(node, surf, pixel_xy, & +!! & n_pvr_pixel, pvr_bound, pvr_screen, pvr_start) +!! type(node_data), intent(in) :: node +!! type(surface_data), intent(in) :: surf +!! type(pvr_view_parameter), intent(inout) :: view_param +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! type(pvr_pixel_position_type), intent(inout) :: pixel_xy +!! type(pvr_ray_start_type), intent(inout) :: pvr_start +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!!@endverbatim +! + module generate_vr_image +! + use m_precision + use m_machine_parameter + use m_constants +! + use calypso_mpi +! + use t_control_params_4_pvr + use t_geometries_in_pvr_screen + use t_surf_grp_4_pvr_domain + use t_pvr_ray_startpoints + use t_pvr_image_array +! + implicit none +! + private :: s_set_pvr_ray_start_point +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine transfer_to_screen(node, surf, pixel_xy, & + & n_pvr_pixel, pvr_bound, pvr_screen, pvr_start) +! + use m_geometry_constants + use t_geometry_data + use t_surface_data + use set_position_pvr_screen + use find_pvr_surf_domain + use pvr_axis_label +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf + type(pvr_pixel_position_type), intent(in) :: pixel_xy + integer(kind = kint), intent(in) :: n_pvr_pixel(2) +! + type(pvr_projected_position), intent(inout) :: pvr_screen + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + call axis_direction_in_screen(pvr_screen) + call norm_on_model_pvr_domains & + & (node, surf, pvr_screen%modelview_mat, & + & pvr_bound%num_pvr_surf, pvr_bound%item_pvr_surf, & + & pvr_bound%screen_norm) +! + call set_pvr_domain_surface_data(n_pvr_pixel, node, surf, & + & pvr_screen%modelview_mat, pvr_screen%projection_mat, & + & pvr_bound) +! + if(iflag_debug .gt. 0) write(*,*) 's_set_pvr_ray_start_point' + call s_set_pvr_ray_start_point(node, surf, & + & pvr_bound, pixel_xy, pvr_screen, pvr_start) +! + end subroutine transfer_to_screen +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine s_set_pvr_ray_start_point(node, surf, & + & pvr_bound, pixel_xy, pvr_screen, pvr_start) +! + use m_geometry_constants + use t_geometry_data + use t_surface_data + use count_pvr_ray_start_point + use set_position_pvr_screen + use set_pvr_ray_start_point + use cal_field_on_surf_viz +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf +! + type(pvr_bounds_surf_ctl), intent(in) :: pvr_bound + type(pvr_pixel_position_type), intent(in) :: pixel_xy + type(pvr_projected_position), intent(in) :: pvr_screen +! + type(pvr_ray_start_type), intent(inout) :: pvr_start +! + integer(kind = kint) :: num_ray_local +! +! + call allocate_num_pvr_ray_start & + & (pvr_bound%num_pvr_surf, pvr_start) +! + call count_temporal_pvr_ray_start & + & (pvr_bound%num_pvr_surf, pvr_bound%screen_norm, & + & pvr_bound%isurf_xrng, pvr_bound%jsurf_yrng, ray_vec4, & + & pvr_start%ntot_tmp_pvr_ray, pvr_start%istack_tmp_pvr_ray_st) +! + call allocate_tmp_pvr_ray_start(pvr_start) +! + call count_each_pvr_ray_start(node, surf, & + & pvr_screen%modelview_mat, pvr_screen%projection_mat, & + & pixel_xy%num_pixel_x, pixel_xy%num_pixel_y, & + & pixel_xy%pixel_point_x, pixel_xy%pixel_point_y, & + & pvr_bound%num_pvr_surf, pvr_bound%item_pvr_surf, & + & pvr_bound%screen_norm, pvr_bound%isurf_xrng, & + & pvr_bound%jsurf_yrng, ray_vec4, num_ray_local, & + & pvr_start%istack_pvr_ray_sf, pvr_start%ntot_tmp_pvr_ray, & + & pvr_start%istack_tmp_pvr_ray_st, pvr_start%ipix_start_tmp, & + & pvr_start%iflag_start_tmp, pvr_start%xi_start_tmp) +! + call allocate_item_pvr_ray_start(num_ray_local, pvr_start) + call allocate_item_pvr_ray_pixels(pvr_start) +! + if(iflag_debug .gt. 0) write(*,*) 'set_each_pvr_ray_start' + if(pvr_start%num_pvr_ray .gt. 0) then + call set_each_pvr_ray_start(node, surf, & + & pixel_xy%num_pixel_x, pixel_xy%num_pixel_y, & + & pvr_bound%num_pvr_surf, pvr_bound%item_pvr_surf, & + & pvr_bound%screen_norm, pvr_screen%viewpoint_vec, ray_vec4, & + & pvr_start%ntot_tmp_pvr_ray, pvr_start%istack_tmp_pvr_ray_st, & + & pvr_start%ipix_start_tmp, pvr_start%iflag_start_tmp, & + & pvr_start%xi_start_tmp, pvr_start%istack_pvr_ray_sf, & + & pvr_start%num_pvr_ray, pvr_start%id_pixel_start, & + & pvr_start%isf_pvr_ray_start, pvr_start%xi_pvr_start, & + & pvr_start%xx4_pvr_start, pvr_start%xx4_pvr_ray_start) +! + call project_once_each_ele_w_smp & + & (pvr_screen%modelview_mat, pvr_screen%projection_mat, & + & pvr_start%num_pvr_ray, pvr_start%xx4_pvr_ray_start) +! + call set_each_ray_projected_start(surf, & + & pixel_xy%num_pixel_x, pixel_xy%num_pixel_y, & + & pixel_xy%pixel_point_x, pixel_xy%pixel_point_y, & + & pvr_bound%num_pvr_surf, pvr_bound%item_pvr_surf, & + & pvr_bound%screen_norm, ray_vec4, & + & pvr_start%ntot_tmp_pvr_ray, pvr_start%istack_tmp_pvr_ray_st, & + & pvr_start%ipix_start_tmp, pvr_start%iflag_start_tmp, & + & pvr_start%istack_pvr_ray_sf, pvr_start%num_pvr_ray, & + & pvr_start%xx4_pvr_ray_start) +! +! if(iflag_debug .gt. 0) then +! call check_pvr_ray_startpoint & +! & (pixel_xy%num_pixel_x, pixel_xy%num_pixel_y, & +! & pvr_start%num_pvr_ray, pvr_start%id_pixel_start) +! end if +! call set_pvr_ray_trace_check & +! & (pixel_xy%num_pixel_x, pixel_xy%num_pixel_y, & +! & pvr_start%num_pvr_ray, pvr_start%id_pixel_start, & +! & pvr_start%id_pixel_check) + end if +! + end subroutine s_set_pvr_ray_start_point +! +! --------------------------------------------------------------------- +! + end module generate_vr_image diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/m_elapsed_labels_4_VIZ.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/m_elapsed_labels_4_VIZ.f90 new file mode 100644 index 00000000..3ea64ca2 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/m_elapsed_labels_4_VIZ.f90 @@ -0,0 +1,24 @@ +!>@file m_elapsed_labels_4_VIZ.f90 +!!@brief module m_elapsed_labels_4_VIZ +!! +!!@author H. Matsui +!!@date Programmed in April, 2013 +! +!>@brief Initialize elepsed time monitoring +!! +!!@verbatim +!!@endverbatim +! + module m_elapsed_labels_4_VIZ +! + use m_precision + use m_work_time +! + use t_elapsed_labels_4_VIZ +! + implicit none +! + logical, parameter :: flag_detailed1 = .TRUE. + type(elapsed_labels_4_VIZ), save :: elps_viz1 +! + end module m_elapsed_labels_4_VIZ diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/m_pvr_control_labels.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/m_pvr_control_labels.f90 new file mode 100644 index 00000000..d7937266 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/m_pvr_control_labels.f90 @@ -0,0 +1,120 @@ +!>@file m_pvr_control_labels.f90 +!! module m_pvr_control_labels +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!> @brief Structures for parameteres for volume rendering +!! +!!@verbatim +!! subroutine pvr_isosurf_dir_list_array(array_c) +!! subroutine pvr_surf_enhance_mode_array(array_c) +!! +!! subroutine pvr_movie_mode_list_array(array_c) +!! subroutine lic_movie_mode_list_array(array_c) +!! type(ctl_array_chara), intent(inout) :: array_c +!!@endverbatim +! + module m_pvr_control_labels +! + use m_precision + use m_constants +! + implicit none +! + character(len = kchara), parameter & + & :: LABEL_INCREASE = 'increase' + character(len = kchara), parameter & + & :: LABEL_DECREASE = 'decrease' +! +! + character(len = kchara), parameter :: LABEL_EDGE = 'boarder' + character(len = kchara), parameter & + & :: LABEL_FORWARD = 'forward_surface' + character(len = kchara), parameter & + & :: LABEL_REVERSE = 'reverse_surface' + character(len = kchara), parameter & + & :: LABEL_BOTH = 'both_surface' +! +! + character(len=kchara), parameter :: FLAG_ZOOM = 'zoom' + character(len=kchara), parameter & + & :: FLAG_ROTATE_MOVIE = 'rotation' + character(len=kchara), parameter & + & :: FLAG_START_END_VIEW = 'view_matrices' + character(len=kchara), parameter & + & :: FLAG_LIC_KERNEL = 'LIC_kernel' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine pvr_isosurf_dir_list_array(array_c) + use t_control_array_character + type(ctl_array_chara), intent(inout) :: array_c +! + array_c%array_name = ' ' + array_c%num = 0 + call alloc_control_array_chara(array_c) +! + call append_c_to_ctl_array(LABEL_INCREASE, array_c) + call append_c_to_ctl_array(LABEL_DECREASE, array_c) +! + end subroutine pvr_isosurf_dir_list_array +! +! ---------------------------------------------------------------------- +! + subroutine pvr_surf_enhance_mode_array(array_c) + use t_control_array_character + type(ctl_array_chara), intent(inout) :: array_c +! + array_c%array_name = ' ' + array_c%num = 0 + call alloc_control_array_chara(array_c) +! + call append_c_to_ctl_array(LABEL_BOTH, array_c) + call append_c_to_ctl_array(LABEL_FORWARD, array_c) + call append_c_to_ctl_array(LABEL_REVERSE, array_c) + call append_c_to_ctl_array(LABEL_EDGE, array_c) +! + end subroutine pvr_surf_enhance_mode_array +! +! ---------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine pvr_movie_mode_list_array(array_c) + use t_control_array_character + type(ctl_array_chara), intent(inout) :: array_c +! + array_c%array_name = ' ' + array_c%num = 0 + call alloc_control_array_chara(array_c) +! + call append_c_to_ctl_array(FLAG_ROTATE_MOVIE, array_c) + call append_c_to_ctl_array(FLAG_ZOOM, array_c) + call append_c_to_ctl_array(FLAG_START_END_VIEW, array_c) +! + end subroutine pvr_movie_mode_list_array +! +! ---------------------------------------------------------------------- +! + subroutine lic_movie_mode_list_array(array_c) + use t_control_array_character + type(ctl_array_chara), intent(inout) :: array_c +! + array_c%array_name = ' ' + array_c%num = 0 + call alloc_control_array_chara(array_c) +! + call append_c_to_ctl_array(FLAG_ROTATE_MOVIE, array_c) + call append_c_to_ctl_array(FLAG_ZOOM, array_c) + call append_c_to_ctl_array(FLAG_START_END_VIEW, array_c) + call append_c_to_ctl_array(FLAG_LIC_KERNEL, array_c) +! + end subroutine lic_movie_mode_list_array +! +! ---------------------------------------------------------------------- +! + end module m_pvr_control_labels diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/mesh_outline_4_pvr.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/mesh_outline_4_pvr.f90 new file mode 100644 index 00000000..ca2393c3 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/mesh_outline_4_pvr.f90 @@ -0,0 +1,137 @@ +!>@file mesh_outline_4_pvr.f90 +!! module mesh_outline_4_pvr +!! +!!@author H. Matsui +!!@date Programmed in May, 2006 +! +!> @brief Set mesh outline for PVR +!! +!!@verbatim +!! subroutine pvr_mesh_outline(node, outline) +!! type(node_data), intent(in) :: node +!! type(pvr_domain_outline), intent(inout) :: outline +!!@endverbatim +! + module mesh_outline_4_pvr +! + use m_precision + use m_constants + use m_machine_parameter + use calypso_mpi +! + use t_surf_grp_4_pvr_domain +! + implicit none +! +! + real(kind = kreal), allocatable :: xx_minmax_l(:,:,:) + real(kind = kreal), allocatable :: xx_minmax_tbl(:,:,:) + private :: xx_minmax_l, xx_minmax_tbl + private :: cal_mesh_outline_pvr +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine pvr_mesh_outline(node, outline) +! + use t_geometry_data +! + type(node_data), intent(in) :: node + type(pvr_domain_outline), intent(inout) :: outline +! + allocate( xx_minmax_l(2,3,nprocs) ) + allocate( xx_minmax_tbl(2,3,nprocs) ) + xx_minmax_l = 0.0d0 + xx_minmax_tbl = 0.0d0 +! + call cal_mesh_outline_pvr(node%numnod, node%xx, outline) +! + if (iflag_debug .gt. 0) then + write(*,*) 'xx_min_g', outline%xx_minmax_g(1,1:3) + write(*,*) 'xx_max_g', outline%xx_minmax_g(2,1:3) + write(*,*) 'center_g', outline%center_g(1:3) + write(*,*) 'rmax_g', outline%rmax_g + end if +! + deallocate(xx_minmax_l, xx_minmax_tbl) +! + end subroutine pvr_mesh_outline +! +! ----------------------------------------------------------------------- +! + subroutine cal_mesh_outline_pvr(numnod, xx, outline) +! + use calypso_mpi_real +! + integer(kind = kint), intent(in) :: numnod + real(kind = kreal), intent(in) :: xx(numnod,3) +! + type(pvr_domain_outline), intent(inout) :: outline +! + integer(kind = kint_gl) :: np6 + integer(kind = kint) :: inod, ip + real(kind = kreal) :: rmax_l, r_from_ct +! +! + ip = my_rank + 1 +! + xx_minmax_l(1,1:3,ip) = xx(1,1:3) + xx_minmax_l(2,1:3,ip) = xx(1,1:3) + do inod = 2, numnod + xx_minmax_l(1,1,ip) = min(xx_minmax_l(1,1,ip), xx(inod,1)) + xx_minmax_l(1,2,ip) = min(xx_minmax_l(1,2,ip), xx(inod,2)) + xx_minmax_l(1,3,ip) = min(xx_minmax_l(1,3,ip), xx(inod,3)) + xx_minmax_l(2,1,ip) = max(xx_minmax_l(2,1,ip), xx(inod,1)) + xx_minmax_l(2,2,ip) = max(xx_minmax_l(2,2,ip), xx(inod,2)) + xx_minmax_l(2,3,ip) = max(xx_minmax_l(2,3,ip), xx(inod,3)) + end do +! + np6 = isix * nprocs + xx_minmax_tbl = 0.0d0 + call calypso_mpi_allreduce_real(xx_minmax_l(1,1,1), & + & xx_minmax_tbl(1,1,1), np6, MPI_SUM) +! + outline%xx_minmax_g(1,1:3) = xx_minmax_tbl(1,1:3,1) + outline%xx_minmax_g(2,1:3) = xx_minmax_tbl(2,1:3,1) + do ip = 2, nprocs + outline%xx_minmax_g(1,1:3) = min(outline%xx_minmax_g(1,1:3), & + & xx_minmax_tbl(1,1:3,ip) ) + outline%xx_minmax_g(2,1:3) = max(outline%xx_minmax_g(1,1:3), & + & xx_minmax_tbl(2,1:3,ip) ) + end do +! + outline%center_g(1:3) = (outline%xx_minmax_g(1,1:3) & + & + outline%xx_minmax_g(2,1:3)) / two +! +! + inod = 1 + rmax_l = sqrt( (xx(inod,1) - outline%center_g(1)) & + & *(xx(inod,1) - outline%center_g(1)) & + & + (xx(inod,2) - outline%center_g(2)) & + & *(xx(inod,2) - outline%center_g(2)) & + & + (xx(inod,3) - outline%center_g(3)) & + & *(xx(inod,3) - outline%center_g(3)) ) +! +! +! + do inod = 2, numnod + r_from_ct = sqrt( (xx(inod,1) - outline%center_g(1)) & + & *(xx(inod,1) - outline%center_g(1)) & + & + (xx(inod,2) - outline%center_g(2)) & + & *(xx(inod,2) - outline%center_g(2)) & + & + (xx(inod,3) - outline%center_g(3)) & + & *(xx(inod,3) - outline%center_g(3)) ) + rmax_l = max(rmax_l, r_from_ct) + end do +! + call calypso_mpi_allreduce_one_real(rmax_l, outline%rmax_g, & + & MPI_MAX) +! + end subroutine cal_mesh_outline_pvr +! +! ---------------------------------------------------------------------- +! + end module mesh_outline_4_pvr diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/mpi_write_quilt_BMP_file.F90 b/src/Fortran_libraries/VIZ_src/volume_rendering/mpi_write_quilt_BMP_file.F90 new file mode 100644 index 00000000..dea49220 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/mpi_write_quilt_BMP_file.F90 @@ -0,0 +1,258 @@ +!>@file mpi_write_quilt_BMP_file.F90 +!!@brief module mpi_write_quilt_BMP_file +!! +!!@author H. Matsui +!!@date Programmed on May., 2021 +!! +!>@brief Quilt format bitmap data IO USING MPI-IO +!! +!!@verbatim +!! subroutine sel_write_pvr_image_files(quilt_d) +!! type(MPI_quilt_bitmap_IO), intent(in) :: quilt_d +!! subroutine mpi_write_quilt_BMP_file(file_prefix, & +!! & n_column_row, num_image_lc, icou_each_pe, & +!! & npixel_x, npixel_y, images) +!! subroutine mpi_write_quilt_gz_BMP_file(file_prefix, & +!! & n_column_row, num_image_lc, icou_each_pe, & +!! & npixel_x, npixel_y, images) +!! character(len=kchara), intent(in) :: file_prefix +!! integer(kind = kint), intent(in) :: n_column_row(2) +!! integer(kind = kint), intent(in) :: num_image_lc +!! integer(kind = kint), intent(in) :: icou_each_pe(num_image_lc) +!! integer(kind = kint), intent(in) :: npixel_x, npixel_y +!! type(each_rgb_image), intent(in) :: images(num_image_lc) +!!@endverbatim +! + module mpi_write_quilt_BMP_file +! + use m_precision + use m_constants + use calypso_mpi + use t_MPI_quilt_bitmap_IO +! + implicit none +! + character(len=1), allocatable, private :: bgr_line(:,:) +! + private :: s_mpi_write_quilt_BMP_file + private :: mpi_write_quilt_gz_BMP_file +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine sel_write_pvr_image_files(quilt_d) +! + use output_image_sel_4_png +! + type(MPI_quilt_bitmap_IO), intent(in) :: quilt_d +! +! + if(quilt_d%image_seq_format .eq. iflag_QUILT_BMP) then + call s_mpi_write_quilt_BMP_file & + & (quilt_d%image_seq_prefix, quilt_d%n_column_row, & + & quilt_d%num_image_lc, quilt_d%icou_each_pe, & + & quilt_d%npixel_xy(1), quilt_d%npixel_xy(2), quilt_d%images) + else if(quilt_d%image_seq_format .eq. iflag_QUILT_BMP_GZ) then + call mpi_write_quilt_gz_BMP_file & + & (quilt_d%image_seq_prefix, quilt_d%n_column_row, & + & quilt_d%num_image_lc, quilt_d%icou_each_pe, & + & quilt_d%npixel_xy(1), quilt_d%npixel_xy(2), quilt_d%images) + else + call sel_write_seq_image_files & + & (quilt_d%num_image_lc, quilt_d%icou_each_pe, quilt_d%images) + end if +! + end subroutine sel_write_pvr_image_files +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine s_mpi_write_quilt_BMP_file(file_prefix, & + & n_column_row, num_image_lc, icou_each_pe, & + & npixel_x, npixel_y, images) +! + use m_calypso_mpi_IO + use MPI_ascii_data_IO + use t_calypso_mpi_IO_param + use write_bmp_image +! + character(len=kchara), intent(in) :: file_prefix + integer(kind = kint), intent(in) :: n_column_row(2) + integer(kind = kint), intent(in) :: num_image_lc + integer(kind = kint), intent(in) :: icou_each_pe(num_image_lc) +! + integer(kind = kint), intent(in) :: npixel_x, npixel_y + type(each_rgb_image), intent(in) :: images(num_image_lc) +! + type(calypso_MPI_IO_params), save :: IO_param + integer(kind = MPI_OFFSET_KIND) :: ioffset + integer :: ilength +! + integer(kind = kint) :: icou, ix, iy, ip, j + character(len=kchara) :: file_name + integer :: ntot_pixel_x, ntot_pixel_y +! + ntot_pixel_x = int(n_column_row(1)*npixel_x) + ntot_pixel_y = int(n_column_row(2)*npixel_y) + allocate(bgr_line(3,npixel_x)) +! + file_name = add_bmp_suffix(file_prefix) + if(my_rank .eq. 0) write(*,*) 'Write Quilt Bitmap: ', & + & trim(file_name) + call open_write_mpi_file(file_name, IO_param) + call mpi_write_charahead(IO_param, 54, & + & BMP_header(ntot_pixel_x, ntot_pixel_y)) +! + do icou = 1, num_image_lc + ip = icou_each_pe(icou) - 1 + ix = mod(ip,n_column_row(1)) + iy = ip / n_column_row(1) + ilength = 3*int(npixel_x) + do j = 1, npixel_y + bgr_line(1,1:npixel_x) = images(icou)%rgb(3,1:npixel_x,j) + bgr_line(2,1:npixel_x) = images(icou)%rgb(2,1:npixel_x,j) + bgr_line(3,1:npixel_x) = images(icou)%rgb(1,1:npixel_x,j) +! + ioffset = IO_param%ioff_gl & + & + ilength * (ix + n_column_row(1) * ((j-1) + iy*npixel_y)) + call mpi_write_one_chara_b & + & (IO_param%id_file, ioffset, ilength, bgr_line(1,1)) + end do + end do + call close_mpi_file(IO_param) + call calypso_MPI_barrier +! + deallocate(bgr_line) +! + end subroutine s_mpi_write_quilt_BMP_file +! +! ---------------------------------------------------------------------- +! + subroutine mpi_write_quilt_gz_BMP_file(file_prefix, & + & n_column_row, num_image_lc, icou_each_pe, & + & npixel_x, npixel_y, images) +! + use m_calypso_mpi_IO + use MPI_ascii_data_IO + use t_calypso_mpi_IO_param + use t_buffer_4_gzip + use zlib_convert_text + use data_convert_by_zlib + use calypso_mpi_int8 + use transfer_to_long_integers + use write_bmp_image + use set_parallel_file_name +! + character(len=kchara), intent(in) :: file_prefix + integer(kind = kint), intent(in) :: n_column_row(2) + integer(kind = kint), intent(in) :: num_image_lc + integer(kind = kint), intent(in) :: icou_each_pe(num_image_lc) +! + integer(kind = kint), intent(in) :: npixel_x, npixel_y + type(each_rgb_image), intent(in) :: images(num_image_lc) +! + type(buffer_4_gzip) :: zbuf_head + type(buffer_4_gzip), allocatable :: zbuf(:,:) + integer(kind = kint_gl), allocatable :: istack_zbuf(:) + integer(kind = kint_gl), allocatable :: nlen_zbuf_gl(:) +! + type(calypso_MPI_IO_params), save :: IO_param + integer(kind = MPI_OFFSET_KIND) :: ioffset + integer :: ilength +! + integer(kind = kint) :: icou, ix, iy, i_img, j, kk + character(len=kchara) :: file_name, gz_name + integer :: ntot_pixel_x, ntot_pixel_y +! +! + ntot_pixel_x = int(n_column_row(1)*npixel_x) + ntot_pixel_y = int(n_column_row(2)*npixel_y) + allocate(bgr_line(3,npixel_x)) + allocate(zbuf(npixel_y,num_image_lc)) + allocate(istack_zbuf(0:npixel_y*n_column_row(1)*n_column_row(2))) + allocate(nlen_zbuf_gl(npixel_y*n_column_row(1)*n_column_row(2))) +! + istack_zbuf(0) = 0 +!$omp parallel workshare + istack_zbuf(1:npixel_y*n_column_row(1)*n_column_row(2)) = 0 + nlen_zbuf_gl(1:npixel_y*n_column_row(1)*n_column_row(2)) = 0 +!$omp end parallel workshare +! + file_name = add_bmp_suffix(file_prefix) + gz_name = add_gzip_extension(file_name) + if(my_rank .eq. 0) write(*,*) 'Write gzipped Quilt Bitmap: ', & + & trim(gz_name) + call open_write_mpi_file(gz_name, IO_param) +! + if(my_rank .eq. 0) then + call defleate_characters & + & (54, BMP_header(ntot_pixel_x, ntot_pixel_y), zbuf_head) + ioffset = IO_param%ioff_gl + call calypso_mpi_seek_write_gz & + & (IO_param%id_file, ioffset, zbuf_head) + call dealloc_zip_buffer(zbuf_head) + end if + call calypso_mpi_bcast_one_int8(zbuf_head%ilen_gzipped, 0) + IO_param%ioff_gl = IO_param%ioff_gl + zbuf_head%ilen_gzipped +! +! + ilength = 3*int(npixel_x) + do icou = 1, num_image_lc + i_img = icou_each_pe(icou) + ix = mod(i_img-1,n_column_row(1)) + iy = (i_img-1) / n_column_row(1) + do j = 1, npixel_y + kk = ix+1 + (j-1) * n_column_row(1) & + & + iy * n_column_row(1) * npixel_y + bgr_line(1,1:npixel_x) = images(icou)%rgb(3,1:npixel_x,j) + bgr_line(2,1:npixel_x) = images(icou)%rgb(2,1:npixel_x,j) + bgr_line(3,1:npixel_x) = images(icou)%rgb(1,1:npixel_x,j) +! + call gzip_defleate_characters_b & + & (cast_long(ilength), bgr_line(1,1), zbuf(j,icou)) + istack_zbuf(kk) = zbuf(j,icou)%ilen_gzipped + end do + end do +! + call calypso_mpi_allreduce_int8(istack_zbuf(1), nlen_zbuf_gl(1), & + & cast_long(npixel_y*n_column_row(1)*n_column_row(2)), MPI_SUM) + do kk = 1, npixel_y*n_column_row(1)*n_column_row(2) + istack_zbuf(kk) = istack_zbuf(kk-1) + nlen_zbuf_gl(kk) + end do +! + do icou = 1, num_image_lc + i_img = icou_each_pe(icou) + ix = mod(i_img-1,n_column_row(1)) + iy = (i_img-1) / n_column_row(1) + do j = 1, npixel_y + kk = ix+1 + (j-1) * n_column_row(1) & + & + iy * n_column_row(1) * npixel_y + ioffset = IO_param%ioff_gl + istack_zbuf(kk-1) + call calypso_mpi_seek_write_gz & + & (IO_param%id_file, ioffset, zbuf(j,icou)) + end do + end do + call close_mpi_file(IO_param) +! +!$omp parallel private(icou) + do icou = 1, num_image_lc +!$omp do private(j) + do j = 1, npixel_y + call dealloc_zip_buffer(zbuf(j,icou)) + end do +!$omp end do nowait + end do +!$omp end parallel + call calypso_MPI_barrier +! + deallocate(zbuf, nlen_zbuf_gl, istack_zbuf) + deallocate(bgr_line) +! + end subroutine mpi_write_quilt_gz_BMP_file +! +! ---------------------------------------------------------------------- +! + end module mpi_write_quilt_BMP_file diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/multi_volume_renderings.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/multi_volume_renderings.f90 new file mode 100644 index 00000000..a0855bfd --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/multi_volume_renderings.f90 @@ -0,0 +1,257 @@ +!>@file multi_volume_renderings.f90 +!!@brief module multi_volume_renderings +!! +!!@date Programmed by H.Matsui in May. 2006 +!! Modified by H.Matsui in May, 2021 +! +!>@brief Main routines for volume renderings +!! +!!@verbatim +!! subroutine set_PVR_view_and_images(num_pvr, num_pvr_images, & +!! & elps_PVR, mesh, PVR_sort, pvr_rgb, pvr_param, & +!! & pvr_bound, pvr_proj, m_SR) +!! integer(kind = kint), intent(in) :: num_pvr, num_pvr_images +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(mesh_geometry), intent(in) :: mesh +!! type(sort_PVRs_by_type), intent(in) :: PVR_sort +!! type(pvr_image_type), intent(in) :: pvr_rgb(num_pvr_images) +!! type(PVR_control_params), intent(in) :: pvr_param(num_pvr) +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound(num_pvr) +!! type(PVR_projection_data), intent(inout) & +!! & :: pvr_proj(num_pvr_images) +!! type(mesh_SR), intent(inout) :: m_SR +!! +!! subroutine PVR_fixview_rendering(istep_pvr, time, elps_PVR, & +!! & geofem, jacs, nod_fld, & +!! & tracer, fline, pvr, m_SR) +!! subroutine PVR_movie_visualize(istep_pvr, time, elps_PVR, & +!! & geofem, jacs, nod_fld, & +!! & tracer, fline, pvr, m_SR) +!! subroutine PVR_quilt_movie_visualize & +!! & (istep_pvr, time, elps_PVR, geofem, jacs, & +!! & nod_fld, tracer, fline, pvr, m_SR) +!! integer(kind = kint), intent(in) :: istep_pvr +!! real(kind = kreal), intent(in) :: time +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(mesh_data), intent(in) :: geofem +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(jacobians_type), intent(in) :: jacs +!! type(volume_rendering_module), intent(inout) :: pvr +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module multi_volume_renderings +! + use m_precision + use calypso_mpi +! + use m_constants + use m_machine_parameter + use m_geometry_constants + use m_work_time +! + use t_mesh_data + use t_phys_data + use t_jacobians + use t_particle_trace + use t_fieldline +! + use t_volume_rendering + use t_surf_grp_list_each_surf + use t_rendering_vr_image + use t_control_params_4_pvr + use t_surf_grp_4_pvr_domain + use t_pvr_ray_startpoints + use t_pvr_image_array + use t_pvr_field_data + use t_geometries_in_pvr_screen + use t_control_data_pvrs + use t_mesh_SR +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_PVR_view_and_images(num_pvr, num_pvr_images, & + & elps_PVR, mesh, PVR_sort, pvr_rgb, pvr_param, & + & pvr_bound, pvr_proj, m_SR) +! + use set_PVR_view_and_image +! + integer(kind = kint), intent(in) :: num_pvr, num_pvr_images + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(sort_PVRs_by_type), intent(in) :: PVR_sort + type(pvr_image_type), intent(in) :: pvr_rgb(num_pvr_images) + type(PVR_control_params), intent(in) :: pvr_param(num_pvr) +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound(num_pvr) + type(PVR_projection_data), intent(inout) & + & :: pvr_proj(num_pvr_images) + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_pvr, ist_pvr, ied_pvr + integer(kind = kint) :: ist_img, num_img +! +! +! single image + ist_pvr = PVR_sort%istack_PVR_modes(0) + 1 + ied_pvr = PVR_sort%istack_PVR_modes(1) + do i_pvr = ist_pvr, ied_pvr + ist_img = PVR_sort%istack_pvr_images(i_pvr-1) + call single_PVR_view_matrices & + & (elps_PVR, mesh, pvr_rgb(ist_img+1), pvr_param(i_pvr), & + & pvr_bound(i_pvr), pvr_proj(ist_img+1), m_SR) + end do +! +! stereo rendering + ist_pvr = PVR_sort%istack_PVR_modes(1) + 1 + ied_pvr = PVR_sort%istack_PVR_modes(2) + do i_pvr = ist_pvr, ied_pvr + ist_img = PVR_sort%istack_pvr_images(i_pvr-1) + num_img = PVR_sort%istack_pvr_images(i_pvr ) - ist_img + call quilt_PVR_view_matrices(num_img, elps_PVR, mesh, & + & pvr_rgb(ist_img+1), pvr_param(i_pvr), & + & pvr_bound(i_pvr), pvr_proj(ist_img+1), m_SR) + end do +! + end subroutine set_PVR_view_and_images +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine PVR_fixview_rendering(istep_pvr, time, elps_PVR, & + & geofem, jacs, nod_fld, & + & tracer, fline, pvr, m_SR) +! + use cal_pvr_modelview_mat + use each_volume_rendering + use each_anaglyph_PVR +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs +! + type(volume_rendering_module), intent(inout) :: pvr + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_pvr, ist_pvr, ied_pvr + integer(kind = kint) :: ist_img, num_img +! +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+1) + ist_pvr = pvr%PVR_sort%istack_PVR_modes(0) + 1 + ied_pvr = pvr%PVR_sort%istack_PVR_modes(2) + do i_pvr = ist_pvr, ied_pvr + ist_img = pvr%PVR_sort%istack_pvr_images(i_pvr-1) + num_img = pvr%PVR_sort%istack_pvr_images(i_pvr ) - ist_img + if(pvr%pvr_param(i_pvr)%movie_def%iflag_movie_mode & + & .ne. IFLAG_NO_MOVIE) cycle +! + call each_PVR_rendering(istep_pvr, time, num_img, elps_PVR, & + & geofem, jacs, nod_fld, tracer, fline, pvr%sf_grp_4_sf, & + & pvr%field_pvr(i_pvr), pvr%pvr_param(i_pvr), & + & pvr%pvr_proj(ist_img+1), pvr%pvr_rgb(ist_img+1), & + & m_SR%SR_sig, m_SR%SR_r) + end do + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+1) +! + end subroutine PVR_fixview_rendering +! +! --------------------------------------------------------------------- +! + subroutine PVR_movie_visualize(istep_pvr, time, elps_PVR, & + & geofem, jacs, nod_fld, & + & tracer, fline, pvr, m_SR) +! + use each_volume_rendering +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs +! + type(volume_rendering_module), intent(inout) :: pvr + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_pvr, ist_pvr, ied_pvr, ist_img +! +! + ist_pvr = pvr%PVR_sort%istack_PVR_modes(2) + 1 + ied_pvr = pvr%PVR_sort%istack_PVR_modes(3) + do i_pvr = ist_pvr, ied_pvr + ist_img = pvr%PVR_sort%istack_pvr_images(i_pvr-1) + call each_PVR_rendering_w_rot(istep_pvr, time, elps_PVR, & + & geofem, jacs, nod_fld, tracer, fline, pvr%sf_grp_4_sf, & + & pvr%field_pvr(i_pvr), pvr%pvr_param(i_pvr), & + & pvr%pvr_bound(i_pvr), pvr%pvr_rgb(ist_img+1), & + & pvr%pvr_proj(ist_img+1), m_SR%SR_sig, m_SR%SR_r, m_SR%SR_i) + end do +! + end subroutine PVR_movie_visualize +! +! --------------------------------------------------------------------- +! + subroutine PVR_quilt_movie_visualize & + & (istep_pvr, time, elps_PVR, geofem, jacs, & + & nod_fld, tracer, fline, pvr, m_SR) +! + use each_volume_rendering +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs +! + type(volume_rendering_module), intent(inout) :: pvr + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_pvr, ist_pvr, ied_pvr + integer(kind = kint) :: ist_img, num_img +! +! + ist_pvr = pvr%PVR_sort%istack_PVR_modes(3) + 1 + ied_pvr = pvr%PVR_sort%istack_PVR_modes(4) + do i_pvr = ist_pvr, ied_pvr + ist_img = pvr%PVR_sort%istack_pvr_images(i_pvr-1) + num_img = pvr%PVR_sort%istack_pvr_images(i_pvr ) - ist_img + if(pvr%pvr_param(i_pvr)%movie_def%iflag_movie_mode & + & .eq. IFLAG_NO_MOVIE) cycle + if(pvr%pvr_param(i_pvr)%stereo_def%flag_quilt) then +! + call each_PVR_quilt_rendering_w_rot & + & (istep_pvr, time, num_img, elps_PVR, geofem, jacs, & + & nod_fld, tracer, fline, pvr%sf_grp_4_sf, & + & pvr%field_pvr(i_pvr), pvr%pvr_param(i_pvr), & + & pvr%pvr_bound(i_pvr), pvr%pvr_proj(ist_img+1), & + & pvr%pvr_rgb(ist_img+1), m_SR%SR_sig, & + & m_SR%SR_r, m_SR%SR_i) + end if + end do +! + end subroutine PVR_quilt_movie_visualize +! +! --------------------------------------------------------------------- +! + end module multi_volume_renderings diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ordering_pvr_sf_domain_grp.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ordering_pvr_sf_domain_grp.f90 new file mode 100644 index 00000000..389ee5ef --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ordering_pvr_sf_domain_grp.f90 @@ -0,0 +1,176 @@ +!ordering_pvr_sf_domain_grp.f90 +! module ordering_pvr_sf_domain_grp +! +! programmed by H.Matsui on Aug., 2011 +! +! subroutine s_ordering_pvr_sf_domain_grp(pvr_bound) +! subroutine dealloc_ordering_pvr_domain_grp +! + module ordering_pvr_sf_domain_grp +! + use m_precision + use m_constants +! + implicit none +! +! + integer(kind = kint), allocatable :: i_org(:) + integer(kind = kint), allocatable :: itmp(:) + real(kind = kreal), allocatable :: ztmp(:) +! + private :: i_org, itmp, ztmp + private :: alloc_ordering_pvr_domain_grp +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine s_ordering_pvr_sf_domain_grp(pvr_bound) +! + use t_surf_grp_4_pvr_domain + use quicksort +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +! + integer(kind = kint) :: inum +! +! + call alloc_ordering_pvr_domain_grp(pvr_bound%num_pvr_surf) +! +!$omp parallel do + do inum = 1, pvr_bound%num_pvr_surf + ztmp(inum) = pvr_bound%screen_posi(3,inum) + i_org(inum) = inum + end do +!$omp end parallel do +! + if(pvr_bound%num_pvr_surf .gt. 1) then + call quicksort_real_w_index(pvr_bound%num_pvr_surf, ztmp, & + & ione, pvr_bound%num_pvr_surf, i_org) + end if +! +! + call swap_int_items_sf_grp(itwo, pvr_bound%num_pvr_surf, & + & pvr_bound%item_pvr_surf) +! + call swap_int_items_sf_grp(itwo, pvr_bound%num_pvr_surf, & + & pvr_bound%isurf_xrng) + call swap_int_items_sf_grp(itwo, pvr_bound%num_pvr_surf, & + & pvr_bound%jsurf_yrng) +! +! + call swap_real_items_sf_grp(ithree, pvr_bound%num_pvr_surf, & + & pvr_bound%screen_posi) + call swap_real_items_sf_grp(ithree, pvr_bound%num_pvr_surf, & + & pvr_bound%screen_norm) +! + call swap_real_items_sf_grp(ione, pvr_bound%num_pvr_surf, & + & pvr_bound%screen_w) +! + call swap_real_items_sf_grp(itwo, pvr_bound%num_pvr_surf, & + & pvr_bound%screen_xrng) + call swap_real_items_sf_grp(itwo, pvr_bound%num_pvr_surf, & + & pvr_bound%screen_yrng) + call swap_real_items_sf_grp(itwo, pvr_bound%num_pvr_surf, & + & pvr_bound%screen_zrng) +! + call dealloc_ordering_pvr_domain_grp +! + end subroutine s_ordering_pvr_sf_domain_grp +! +! ----------------------------------------------------------------------- +! + subroutine alloc_ordering_pvr_domain_grp(num_pvr_surf) +! + integer(kind = kint), intent(in) :: num_pvr_surf +! + if(allocated(itmp)) return +! + allocate(itmp(num_pvr_surf)) + allocate(ztmp(num_pvr_surf)) + allocate(i_org(num_pvr_surf)) +! + end subroutine alloc_ordering_pvr_domain_grp +! +! ----------------------------------------------------------------------- +! + subroutine dealloc_ordering_pvr_domain_grp +! + if(allocated(itmp)) deallocate(itmp, ztmp, i_org) +! + end subroutine dealloc_ordering_pvr_domain_grp +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine swap_int_items_sf_grp(nd, num, item) +! + integer(kind = kint), intent(in) :: nd, num + integer(kind = kint), intent(inout) :: item(nd,num) +! + integer(kind = kint) :: id +! + do id = 1, nd + call swap_int_4_sf_grp(nd, num, id, item) + end do +! + end subroutine swap_int_items_sf_grp +! +! ----------------------------------------------------------------------- +! + subroutine swap_real_items_sf_grp(nd, num, ritem) +! + integer(kind = kint), intent(in) :: nd, num + real(kind = kreal), intent(inout) :: ritem(nd,num) +! + integer(kind = kint) :: id +! + do id = 1, nd + call swap_real_4_sf_grp(nd, num, id, ritem) + end do +! + end subroutine swap_real_items_sf_grp +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine swap_int_4_sf_grp(nd, num, id, item) +! + integer(kind = kint), intent(in) :: nd, num, id + integer(kind = kint), intent(inout) :: item(nd,num) +! + integer(kind = kint) :: inum, i +! +! +! + itmp(1:num) = item(id,1:num) + do inum = 1, num + i = i_org(inum) + item(id,inum) = itmp(i) + end do +! + end subroutine swap_int_4_sf_grp +! +! ----------------------------------------------------------------------- +! + subroutine swap_real_4_sf_grp(nd, num, id, ritem) +! + integer(kind = kint), intent(in) :: nd, num, id + real(kind = kreal), intent(inout) :: ritem(nd,num) +! + integer(kind = kint) :: inum, i +! +! + ztmp(1:num) = ritem(id,1:num) + do inum = 1, num + i = i_org(inum) + ritem(id,inum) = ztmp(i) + end do +! + end subroutine swap_real_4_sf_grp +! +! ----------------------------------------------------------------------- +! + end module ordering_pvr_sf_domain_grp diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/pvr_axis_label.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/pvr_axis_label.f90 new file mode 100644 index 00000000..91fcc659 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/pvr_axis_label.f90 @@ -0,0 +1,168 @@ +!>@file pvr_axis_label.f90 +!! module pvr_axis_label +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!> @brief Structures for parameteres for volume rendering +!! +!!@verbatim +!! subroutine axis_direction_in_screen(pvr_screen) +!! type(pvr_projected_position), intent(inout) :: pvr_screen +!! subroutine set_pvr_axislabel(num_pixel, n_pvr_pixel, iscale, & +!! & pvr_screen, rgba_gl) +!! integer(kind = kint), intent(in) :: num_pixel +!! integer(kind = kint), intent(in) :: iscale +!! integer(kind = kint), intent(in) :: n_pvr_pixel(2) +!! type(pvr_projected_position), intent(in) :: pvr_screen +!! real(kind = kreal), intent(inout) :: rgba_gl(4,num_pixel) +!!@endverbatim +! + module pvr_axis_label +! + use m_precision + use m_constants +! + implicit none +! +! + real(kind = kreal), parameter :: axis_vect(3,3) & + = reshape((/1,0,0, 0,1,0, 0,0,1/), shape=(/3,3/)) + character(len=1), parameter :: axis_label(3) = (/'x','y','z'/) +! + private :: axis_vect + private :: find_draw_axis_order +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine axis_direction_in_screen(pvr_screen) +! + use t_geometries_in_pvr_screen + use set_position_pvr_screen +! + type(pvr_projected_position), intent(inout) :: pvr_screen +! +! + call cal_position_pvr_modelview(pvr_screen%modelview_mat, & + & ithree, axis_vect, pvr_screen%axis_view) + call find_draw_axis_order & + & (pvr_screen%axis_view, pvr_screen%axis_order) + call overwte_position_pvr_screen(pvr_screen%projection_mat, & + & ithree, pvr_screen%axis_view) +! + end subroutine axis_direction_in_screen +! +! --------------------------------------------------------------------- +! + subroutine set_pvr_axislabel(num_pixel, n_pvr_pixel, iscale, & + & pvr_screen, rgba_gl) +! + use t_control_params_4_pvr + use t_geometries_in_pvr_screen + use set_position_pvr_screen + use draw_pvr_colorbar_nums +! + integer(kind = kint), intent(in) :: num_pixel + integer(kind = kint), intent(in) :: iscale + integer(kind = kint), intent(in) :: n_pvr_pixel(2) +! + type(pvr_projected_position), intent(in) :: pvr_screen +! + real(kind = kreal), intent(inout) :: rgba_gl(4,num_pixel) +! + integer(kind = kint) :: i, j, l, n, m, i2, j2 + integer(kind = kint) :: length, ist_px, ist_py, inod + real(kind = kreal) :: rlen, rhgt + real(kind = kreal) :: r, rmax +! +! + rmax = zero + do m = 1, 3 + n = pvr_screen%axis_order(m) + r = sqrt( pvr_screen%axis_view(n,1)**2 & + & + pvr_screen%axis_view(n,2)**2) + rmax = max(rmax,r) + end do +! + length = 30 * iscale +! length = int(0.13 * rmax * min(n_pvr_pixel(1),n_pvr_pixel(2))) + rmax = one / rmax + do m = 1, 3 + ist_px = int(length * 1.3, KIND(ist_px)) + ist_py = int(length * 1.3, KIND(ist_py)) + n = pvr_screen%axis_order(m) + do j2 = -iscale/4, (iscale+1)/4 + do i2 = -iscale/4, (iscale+1)/4 + do l = 0, length + rlen = l * pvr_screen%axis_view(n,1) * rmax + rhgt = l * pvr_screen%axis_view(n,2) * rmax + i = ist_px + int(rlen, KIND(i)) + j = ist_py + int(rhgt, KIND(j)) + inod = (j+j2)*n_pvr_pixel(1) + (i+i2) + 1 + rgba_gl(n,inod) = one + rgba_gl(4,inod) = one + end do + end do + end do + rlen = (length+10) * pvr_screen%axis_view(n,1) * rmax + rhgt = (length+12) * pvr_screen%axis_view(n,2) * rmax + ist_px = ist_px + int(rlen, KIND(ist_px)) + ist_py = ist_py + int(rhgt, KIND(ist_py)) +! + call set_one_label(axis_label(n), iscale, ist_px, ist_py, & + & n_pvr_pixel, num_pixel, rgba_gl) + end do +! + end subroutine set_pvr_axislabel +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine find_draw_axis_order(axis_view, axis_order) +! + real(kind = kreal) :: axis_view(3,4) + integer(kind = kint) :: axis_order(3) +! + integer(kind = kint) :: i +! + do i = 1, 3 + if (axis_view(1,3) .lt. axis_view(2,3) & + & .and. axis_view(1,3) .lt. axis_view(3,3)) then + axis_order(1) = 1 + if (axis_view(2,3) .lt. axis_view(3,3)) then + axis_order(2) = 2 + axis_order(3) = 3 + else + axis_order(2) = 3 + axis_order(3) = 2 + end if + else if (axis_view(2,3) .lt. axis_view(3,3)) then + axis_order(1) = 2 + if (axis_view(1,3) .lt. axis_view(3,3)) then + axis_order(2) = 1 + axis_order(3) = 3 + else + axis_order(2) = 3 + axis_order(3) = 1 + end if + else + axis_order(1) = 3 + if (axis_view(1,3) .lt. axis_view(2,3)) then + axis_order(2) = 1 + axis_order(3) = 2 + else + axis_order(2) = 2 + axis_order(3) = 1 + end if + end if + end do +! + end subroutine find_draw_axis_order +! +! --------------------------------------------------------------------- +! + end module pvr_axis_label diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/pvr_font_texture.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/pvr_font_texture.f90 new file mode 100644 index 00000000..4796fdae --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/pvr_font_texture.f90 @@ -0,0 +1,835 @@ +! +! module pvr_font_texture +! + module pvr_font_texture +! +! Written by H. Matsui on July, 2006 +! + use m_constants +! + use m_precision +! + implicit none +! + integer(kind = kint), parameter :: ift5_0(25) = (/ 0,1,1,1,0, & + & 0,1,0,1,0, & + & 0,1,0,1,0, & + & 0,1,0,1,0, & + & 0,1,1,1,0 /) + + integer(kind = kint), parameter :: ift5_1(25) = (/ 0,1,1,0,0, & + & 0,0,1,0,0, & + & 0,0,1,0,0, & + & 0,0,1,0,0, & + & 0,1,1,1,0 /) + + integer(kind = kint), parameter :: ift5_2(25) = (/ 0,1,1,1,0, & + & 0,0,0,1,0, & + & 0,1,1,1,0, & + & 0,1,0,0,0, & + & 0,1,1,1,0 /) + + integer(kind = kint), parameter :: ift5_3(25) = (/ 0,1,1,1,0, & + & 0,0,0,1,0, & + & 0,1,1,1,0, & + & 0,0,0,1,0, & + & 0,1,1,1,0 /) + + integer(kind = kint), parameter :: ift5_4(25) = (/ 0,0,1,1,0, & + & 0,1,0,1,0, & + & 0,1,1,1,0, & + & 0,0,0,1,0, & + & 0,0,0,1,0 /) + + integer(kind = kint), parameter :: ift5_5(25) = (/ 0,1,1,1,0, & + & 0,1,0,0,0, & + & 0,1,1,1,0, & + & 0,0,0,1,0, & + & 0,1,1,1,0 /) + + integer(kind = kint), parameter :: ift5_6(25) = (/ 0,1,1,1,0, & + & 0,1,0,0,0, & + & 0,1,1,1,0, & + & 0,1,0,1,0, & + & 0,1,1,1,0 /) + + integer(kind = kint), parameter :: ift5_7(25) = (/ 0,1,1,1,0, & + & 0,0,0,1,0, & + & 0,0,0,1,0, & + & 0,0,0,1,0, & + & 0,0,0,1,0 /) + + integer(kind = kint), parameter :: ift5_8(25) = (/ 0,1,1,1,0, & + & 0,1,0,1,0, & + & 0,1,1,1,0, & + & 0,1,0,1,0, & + & 0,1,1,1,0 /) + + integer(kind = kint), parameter :: ift5_9(25) = (/ 0,1,1,1,0, & + & 0,1,0,1,0, & + & 0,1,1,1,0, & + & 0,0,0,1,0, & + & 0,1,1,1,0 /) + + integer(kind = kint), parameter :: ift5_e(25) = (/ 0,1,1,1,0, & + & 0,1,0,0,0, & + & 0,1,1,1,0, & + & 0,1,0,0,0, & + & 0,1,1,1,0 /) + + integer(kind = kint), parameter :: ift5_d(25) = (/ 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,1,1,0,0, & + & 0,1,1,0,0 /) + + integer(kind = kint), parameter :: ift5_a(25) = (/ 0,0,0,0,0, & + & 0,0,1,0,0, & + & 0,1,1,1,0, & + & 0,0,1,0,0, & + & 0,0,0,0,0 /) + + integer(kind = kint), parameter :: ift5_s(25) = (/ 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,1,1,1,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0 /) + + integer(kind = kint), parameter :: ift5_q(25) = (/ 0,0,0,0,0, & + & 0,1,1,1,0, & + & 0,0,0,0,0, & + & 0,1,1,1,0, & + & 0,0,0,0,0 /) + + integer(kind = kint), parameter :: ift5_x(25) = (/ 1,0,0,0,1, & + & 0,1,0,1,0, & + & 0,0,1,0,0, & + & 0,1,0,1,0, & + & 1,0,0,0,1 /) + + integer(kind = kint), parameter :: ift5_y(25) = (/ 1,0,0,0,1, & + & 0,1,0,1,0, & + & 0,0,1,0,0, & + & 0,1,0,0,0, & + & 1,0,0,0,0 /) + + integer(kind = kint), parameter :: ift5_z(25) = (/ 1,1,1,1,1, & + & 0,0,0,1,0, & + & 0,0,1,0,0, & + & 0,1,0,0,0, & + & 1,1,1,1,1 /) + + integer(kind = kint), parameter :: ift5_t(25) = (/ 0,0,1,0,0, & + & 1,1,1,1,1, & + & 0,0,1,0,0, & + & 0,0,1,0,0, & + & 0,0,1,1,0 /) + +! + + integer(kind = kint), parameter :: ift7_0(49) = (/0,1,1,1,1,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,1,1,1,1,0/) + + integer(kind = kint), parameter :: ift7_1(49) = (/0,0,0,1,0,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,0,1,0,0,0/) + + integer(kind = kint), parameter :: ift7_2(49) = (/0,1,1,1,1,1,0, & + & 0,0,0,0,0,1,0, & + & 0,0,0,0,0,1,0, & + & 0,1,1,1,1,1,0, & + & 0,1,0,0,0,0,0, & + & 0,1,0,0,0,0,0, & + & 0,1,1,1,1,1,0/) + + integer(kind = kint), parameter :: ift7_3(49) = (/0,1,1,1,1,1,0, & + & 0,0,0,0,0,1,0, & + & 0,0,0,0,0,1,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,0,0,1,0, & + & 0,0,0,0,0,1,0, & + & 0,1,1,1,1,1,0/) + + integer(kind = kint), parameter :: ift7_4(49) = (/0,0,1,0,1,0,0, & + & 0,1,0,0,1,0,0, & + & 0,1,0,0,1,0,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,0,1,0,0, & + & 0,0,0,0,1,0,0, & + & 0,0,0,0,1,0,0/) + + integer(kind = kint), parameter :: ift7_5(49) = (/0,1,1,1,1,1,0, & + & 0,1,0,0,0,0,0, & + & 0,1,0,0,0,0,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,0,0,1,0, & + & 0,0,0,0,0,1,0, & + & 0,1,1,1,1,1,0/) + + integer(kind = kint), parameter :: ift7_6(49) = (/0,1,1,1,1,1,0, & + & 0,1,0,0,0,0,0, & + & 0,1,0,0,0,0,0, & + & 0,1,1,1,1,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,1,1,1,1,0/) + + integer(kind = kint), parameter :: ift7_7(49) = (/0,1,1,1,1,1,0, & + & 0,0,0,0,0,1,0, & + & 0,0,0,0,0,1,0, & + & 0,0,0,0,1,0,0, & + & 0,0,0,0,1,0,0, & + & 0,0,0,0,1,0,0, & + & 0,0,0,0,1,0,0/) + + integer(kind = kint), parameter :: ift7_8(49) = (/0,1,1,1,1,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,1,1,1,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,1,1,1,1,0/) + + integer(kind = kint), parameter :: ift7_9(49) = (/0,1,1,1,1,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,0,0,0,1,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,0,0,1,0, & + & 0,0,0,0,0,1,0, & + & 0,1,1,1,1,1,0/) + + integer(kind = kint), parameter :: ift7_e(49) = (/0,1,1,1,1,1,0, & + & 0,1,0,0,0,0,0, & + & 0,1,0,0,0,0,0, & + & 0,1,1,1,1,1,0, & + & 0,1,0,0,0,0,0, & + & 0,1,0,0,0,0,0, & + & 0,1,1,1,1,1,0/) + + integer(kind = kint), parameter :: ift7_d(49) = (/0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0, & + & 0,0,1,1,0,0,0, & + & 0,0,1,1,0,0,0/) + + integer(kind = kint), parameter :: ift7_a(49) = (/0,0,0,0,0,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,0,1,0,0,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,1,0,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,0,0,0,0,0/) + + integer(kind = kint), parameter :: ift7_s(49) = (/0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0/) + + integer(kind = kint), parameter :: ift7_q(49) = (/0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0/) +! +! + integer(kind = kint), parameter :: ift7_x(49) = (/0,0,0,0,0,0,0, & + & 0,1,0,0,0,1,0, & + & 0,0,1,0,1,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,1,0,1,0,0, & + & 0,1,0,0,0,1,0, & + & 0,0,0,0,0,0,0/) +! + integer(kind = kint), parameter :: ift7_y(49) = (/0,0,0,0,0,0,0, & + & 0,1,0,0,0,1,0, & + & 0,0,1,1,1,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,1,0,0,0,0, & + & 0,1,0,0,0,0,0, & + & 0,0,0,0,0,0,0/) +! + integer(kind = kint), parameter :: ift7_z(49) = (/0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,0,1,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,1,0,0,0,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,0,0,0,0/) +! + integer(kind = kint), parameter :: ift7_t(49) = (/0,0,0,0,0,0,0, & + & 0,0,0,1,0,0,0, & + & 0,1,1,1,1,1,0, & + & 0,0,0,1,0,0,0, & + & 0,0,0,1,0,0,0, & + & 0,0,0,1,1,0,0, & + & 0,0,0,0,0,0,0/) +! +! +! + integer(kind=kint), parameter :: ift8_0(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,0,0,1,0,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,0,0,0,0,1,0, & + & 0,0,1,0,0,1,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_1(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_2(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,0,0,1,0,0, & + & 0,1,0,0,0,0,1,0, & + & 0,0,0,0,0,0,1,0, & + & 0,0,0,0,0,1,1,0, & + & 0,0,0,0,1,1,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,1,0,0,0,0, & + & 0,1,1,0,0,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_3(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,1,1,1,0,0,0, & + & 0,1,0,0,0,1,0,0, & + & 0,0,0,0,0,0,1,0, & + & 0,0,0,0,0,1,0,0, & + & 0,0,1,1,1,1,0,0, & + & 0,0,0,0,0,1,0,0, & + & 0,0,0,0,0,0,1,0, & + & 0,0,0,0,0,0,1,0, & + & 0,1,0,0,0,1,0,0, & + & 0,0,1,1,1,0,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_4(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,0,1,0,0,0, & + & 0,0,1,0,1,0,0,0, & + & 0,1,0,0,1,0,0,0, & + & 0,1,0,0,1,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_5(96) = (/0,0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,0,1,1,0,0,0, & + & 0,1,1,0,0,1,0,0, & + & 0,1,0,0,0,0,1,0, & + & 0,0,0,0,0,0,1,0, & + & 0,0,0,0,0,0,1,0, & + & 0,1,0,0,0,1,0,0, & + & 0,0,1,1,1,0,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_6(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,0,0,1,0,0, & + & 0,1,1,0,0,0,1,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,1,1,1,1,0,0, & + & 0,1,0,0,0,1,1,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,1,0,0,1,1,0, & + & 0,0,1,1,1,1,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_7(96) = (/0,0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,0,0,0,0,0,1,0, & + & 0,0,0,0,0,0,1,0, & + & 0,0,0,0,0,1,1,0, & + & 0,0,0,0,1,1,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,0,1,0,0,0,0, & + & 0,0,1,1,0,0,0,0, & + & 0,0,1,0,0,0,0,0, & + & 0,0,1,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_8(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,0,0,1,0,0, & + & 0,1,0,0,0,0,1,0, & + & 0,0,1,0,0,1,0,0, & + & 0,0,1,1,1,1,0,0, & + & 0,0,1,0,0,1,0,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,1,0,0,1,1,0, & + & 0,0,1,1,1,1,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_9(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,0,0,1,0,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,0,0,0,1,1,0, & + & 0,0,1,1,1,0,1,0, & + & 0,0,0,0,0,0,1,0, & + & 0,0,0,0,0,0,1,0, & + & 0,1,1,0,0,1,1,0, & + & 0,0,1,1,1,1,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_e(96) = (/0,0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,1,1,1,1,0,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,0,0,0,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_d(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_a(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,1,1,1,1,1,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,1,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_s(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0/) + + integer(kind=kint), parameter :: ift8_q(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0/) +! +! + integer(kind=kint), parameter :: ift8_x(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,1,0,0,1,1,0, & + & 0,0,1,1,0,1,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,1,0,1,0,0, & + & 0,1,1,0,0,1,1,0, & + & 0,1,0,0,0,0,1,0, & + & 0,0,0,0,0,0,0,0/) +! + integer(kind=kint), parameter :: ift8_y(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,1,0,0,0,0,1,0, & + & 0,1,1,0,0,1,1,0, & + & 0,0,1,1,0,1,1,0, & + & 0,0,0,1,1,1,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,1,0,0,0,0, & + & 0,1,1,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0/) +! + integer(kind=kint), parameter :: ift8_z(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,0,0,0,0,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,0,0,0,0,1,1,0, & + & 0,0,0,0,1,1,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,1,1,0,0,0,0, & + & 0,1,1,0,0,0,0,0, & + & 0,1,1,1,1,1,1,0, & + & 0,0,0,0,0,0,0,0/) +! + integer(kind=kint), parameter :: ift8_t(96) = (/0,0,0,0,0,0,0,0, & + & 0,0,0,1,0,0,0,0, & + & 0,0,0,1,0,0,0,0, & + & 0,1,1,1,1,1,0,0, & + & 0,0,0,1,0,0,0,0, & + & 0,0,0,1,0,0,0,0, & + & 0,0,0,1,0,0,0,0, & + & 0,0,0,1,0,0,0,0, & + & 0,0,0,1,0,0,0,0, & + & 0,0,0,1,1,0,0,0, & + & 0,0,0,0,1,1,0,0, & + & 0,0,0,0,0,0,0,0/) +! + private :: ift5_0, ift5_1, ift5_2, ift5_3, ift5_4, ift5_5, ift5_6 + private :: ift5_7, ift5_8, ift5_9, ift5_e, ift5_d, ift5_a, ift5_s + private :: ift5_x, ift5_y, ift5_z, ift5_t, ift5_q + private :: ift7_0, ift7_1, ift7_2, ift7_3, ift7_4, ift7_5, ift7_6 + private :: ift7_7, ift7_8, ift7_9, ift7_e, ift7_d, ift7_a, ift7_s + private :: ift7_x, ift7_y, ift7_z, ift7_t, ift7_q + private :: ift8_0, ift8_1, ift8_2, ift8_3, ift8_4, ift8_5, ift8_6 + private :: ift8_7, ift8_8, ift8_9, ift8_e, ift8_d, ift8_a, ift8_s + private :: ift8_x, ift8_y, ift8_z, ift8_t, ift8_q +! +! subroutine gen_font5(chara, font_out) +! subroutine gen_font7(chara, font_out) +! subroutine gen_font8_12(chara, font_out) +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine gen_font5(chara, font_out) +! + character(len = 1), intent(in) :: chara + integer(kind = kint), intent(inout) :: font_out(5,5) +! + integer(kind = kint) :: j +! +! + if (chara .eq. '0') then + do j = 1, 5 + font_out(1:5,j) = ift5_0( (5*j-4):(5*j) ) + end do + else if (chara .eq. '1') then + do j = 1, 5 + font_out(1:5,j) = ift5_1( (5*j-4):(5*j) ) + end do + else if (chara .eq. '2') then + do j = 1, 5 + font_out(1:5,j) = ift5_2( (5*j-4):(5*j) ) + end do + else if (chara .eq. '3') then + do j = 1, 5 + font_out(1:5,j) = ift5_3( (5*j-4):(5*j) ) + end do + else if (chara .eq. '4') then + do j = 1, 5 + font_out(1:5,j) = ift5_4( (5*j-4):(5*j) ) + end do + else if (chara .eq. '5') then + do j = 1, 5 + font_out(1:5,j) = ift5_5( (5*j-4):(5*j) ) + end do + else if (chara .eq. '6') then + do j = 1, 5 + font_out(1:5,j) = ift5_6( (5*j-4):(5*j) ) + end do + else if (chara .eq. '7') then + do j = 1, 5 + font_out(1:5,j) = ift5_7( (5*j-4):(5*j) ) + end do + else if (chara .eq. '8') then + do j = 1, 5 + font_out(1:5,j) = ift5_8( (5*j-4):(5*j) ) + end do + else if (chara .eq. '9') then + do j = 1, 5 + font_out(1:5,j) = ift5_9( (5*j-4):(5*j) ) + end do + else if (chara .eq. 'e' .or. chara .eq. 'E') then + do j = 1, 5 + font_out(1:5,j) = ift5_e( (5*j-4):(5*j) ) + end do + else if (chara .eq. '.') then + do j = 1, 5 + font_out(1:5,j) = ift5_d( (5*j-4):(5*j) ) + end do + else if (chara .eq. '+') then + do j = 1, 5 + font_out(1:5,j) = ift5_a( (5*j-4):(5*j) ) + end do + else if (chara .eq. '-') then + do j = 1, 5 + font_out(1:5,j) = ift5_s( (5*j-4):(5*j) ) + end do + else if (chara .eq. '=') then + do j = 1, 5 + font_out(1:5,j) = ift5_q( (5*j-4):(5*j) ) + end do + else if (chara .eq. 'x') then + do j = 1, 5 + font_out(1:5,j) = ift5_x( (5*j-4):(5*j) ) + end do + else if (chara .eq. 'y') then + do j = 1, 5 + font_out(1:5,j) = ift5_y( (5*j-4):(5*j) ) + end do + else if (chara .eq. 'z') then + do j = 1, 5 + font_out(1:5,j) = ift5_z( (5*j-4):(5*j) ) + end do + else if (chara .eq. 't') then + do j = 1, 5 + font_out(1:5,j) = ift5_t( (5*j-4):(5*j) ) + end do + else if (chara .eq. ' ') then + do j = 1, 5 + font_out(1:5,j) = 0 + end do + end if +! + end subroutine gen_font5 +! +! --------------------------------------------------------------------- +! + subroutine gen_font7(chara, font_out) +! + character(len = 1), intent(in) :: chara + integer(kind = kint), intent(inout) :: font_out(7,7) +! + integer(kind = kint) :: j +! +! + if (chara .eq. '0') then + do j = 1, 7 + font_out(1:7,j) = ift7_0( (7*j-6):(7*j) ) + end do + else if (chara .eq. '1') then + do j = 1, 7 + font_out(1:7,j) = ift7_1( (7*j-6):(7*j) ) + end do + else if (chara .eq. '2') then + do j = 1, 7 + font_out(1:7,j) = ift7_2( (7*j-6):(7*j) ) + end do + else if (chara .eq. '3') then + do j = 1, 7 + font_out(1:7,j) = ift7_3( (7*j-6):(7*j) ) + end do + else if (chara .eq. '4') then + do j = 1, 7 + font_out(1:7,j) = ift7_4( (7*j-6):(7*j) ) + end do + else if (chara .eq. '5') then + do j = 1, 7 + font_out(1:7,j) = ift7_5( (7*j-6):(7*j) ) + end do + else if (chara .eq. '6') then + do j = 1, 7 + font_out(1:7,j) = ift7_6( (7*j-6):(7*j) ) + end do + else if (chara .eq. '7') then + do j = 1, 7 + font_out(1:7,j) = ift7_7( (7*j-6):(7*j) ) + end do + else if (chara .eq. '8') then + do j = 1, 7 + font_out(1:7,j) = ift7_8( (7*j-6):(7*j) ) + end do + else if (chara .eq. '9') then + do j = 1, 7 + font_out(1:7,j) = ift7_9( (7*j-6):(7*j) ) + end do + else if (chara .eq. 'e' .or. chara .eq. 'E') then + do j = 1, 7 + font_out(1:7,j) = ift7_e( (7*j-6):(7*j) ) + end do + else if (chara .eq. '.') then + do j = 1, 7 + font_out(1:7,j) = ift7_d( (7*j-6):(7*j) ) + end do + else if (chara .eq. '+') then + do j = 1, 7 + font_out(1:7,j) = ift7_a( (7*j-6):(7*j) ) + end do + else if (chara .eq. '-') then + do j = 1, 7 + font_out(1:7,j) = ift7_s( (7*j-6):(7*j) ) + end do + else if (chara .eq. '=') then + do j = 1, 7 + font_out(1:7,j) = ift7_q( (7*j-6):(7*j) ) + end do + else if (chara .eq. 'x') then + do j = 1, 7 + font_out(1:7,j) = ift7_x( (7*j-6):(7*j) ) + end do + else if (chara .eq. 'y') then + do j = 1, 7 + font_out(1:7,j) = ift7_y( (7*j-6):(7*j) ) + end do + else if (chara .eq. 'z') then + do j = 1, 7 + font_out(1:7,j) = ift7_z( (7*j-6):(7*j) ) + end do + else if (chara .eq. 't') then + do j = 1, 7 + font_out(1:7,j) = ift7_t( (7*j-6):(7*j) ) + end do + else if (chara .eq. ' ') then + do j = 1, 17 + font_out(1:7,j) = 0 + end do + end if +! + end subroutine gen_font7 +! +! --------------------------------------------------------------------- +! + subroutine gen_font8_12(chara, font_out) +! + character(len = 1), intent(in) :: chara + integer(kind = kint), intent(inout) :: font_out(8,12) +! + integer(kind = kint) :: j +! +! + if (chara .eq. '0') then + do j = 1, 12 + font_out(1:8,j) = ift8_0( (8*j-7):(8*j) ) + end do + else if (chara .eq. '1') then + do j = 1, 12 + font_out(1:8,j) = ift8_1( (8*j-7):(8*j) ) + end do + else if (chara .eq. '2') then + do j = 1, 12 + font_out(1:8,j) = ift8_2( (8*j-7):(8*j) ) + end do + else if (chara .eq. '3') then + do j = 1, 12 + font_out(1:8,j) = ift8_3( (8*j-7):(8*j) ) + end do + else if (chara .eq. '4') then + do j = 1, 12 + font_out(1:8,j) = ift8_4( (8*j-7):(8*j) ) + end do + else if (chara .eq. '5') then + do j = 1, 12 + font_out(1:8,j) = ift8_5( (8*j-7):(8*j) ) + end do + else if (chara .eq. '6') then + do j = 1, 12 + font_out(1:8,j) = ift8_6( (8*j-7):(8*j) ) + end do + else if (chara .eq. '7') then + do j = 1, 12 + font_out(1:8,j) = ift8_7( (8*j-7):(8*j) ) + end do + else if (chara .eq. '8') then + do j = 1, 12 + font_out(1:8,j) = ift8_8( (8*j-7):(8*j) ) + end do + else if (chara .eq. '9') then + do j = 1, 12 + font_out(1:8,j) = ift8_9( (8*j-7):(8*j) ) + end do + else if (chara .eq. 'e' .or. chara .eq. 'E') then + do j = 1, 12 + font_out(1:8,j) = ift8_e( (8*j-7):(8*j) ) + end do + else if (chara .eq. '.') then + do j = 1, 12 + font_out(1:8,j) = ift8_d( (8*j-7):(8*j) ) + end do + else if (chara .eq. '+') then + do j = 1, 12 + font_out(1:8,j) = ift8_a( (8*j-7):(8*j) ) + end do + else if (chara .eq. '-') then + do j = 1, 12 + font_out(1:8,j) = ift8_s( (8*j-7):(8*j) ) + end do + else if (chara .eq. '=') then + do j = 1, 12 + font_out(1:8,j) = ift8_q( (8*j-7):(8*j) ) + end do + else if (chara .eq. 'x') then + do j = 1, 12 + font_out(1:8,j) = ift8_x( (8*j-7):(8*j) ) + end do + else if (chara .eq. 'y') then + do j = 1, 12 + font_out(1:8,j) = ift8_y( (8*j-7):(8*j) ) + end do + else if (chara .eq. 'z') then + do j = 1, 12 + font_out(1:8,j) = ift8_z( (8*j-7):(8*j) ) + end do + else if (chara .eq. 't') then + do j = 1, 12 + font_out(1:8,j) = ift8_t( (8*j-7):(8*j) ) + end do + else if (chara .eq. ' ') then + do j = 1, 12 + font_out(1:8,j) = 0 + end do + end if +! + end subroutine gen_font8_12 +! +! --------------------------------------------------------------------- +! + end module pvr_font_texture diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/pvr_surface_enhancement.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/pvr_surface_enhancement.f90 new file mode 100644 index 00000000..a683775a --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/pvr_surface_enhancement.f90 @@ -0,0 +1,160 @@ +!>@file pvr_surface_enhancement.f90 +!! module pvr_surface_enhancement +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Set flag and opacities to enhance surfaces +!! +!!@verbatim +!! subroutine set_pvr_bc_enhanse_flag & +!! & (surf_grp, num_enhanse_grp, enhanse_grp, draw_type, & +!! & fixed_opacity, iflag_enhanse, enhansed_opacity) +!! real(kind = kreal) function opacity_by_surf_grp & +!! & (isurf, surf, surf_grp, sf_grp_4_sf, & +!! & modelview_mat, iflag_enhanse, enhansed_opacity) +!! type(surface_data), intent(in) :: surf +!! type(surface_group_data), intent(in) :: surf_grp +!! type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +!!@endverbatim +! + module pvr_surface_enhancement +! + use m_precision + use m_constants + use m_machine_parameter + use m_geometry_constants + use t_surface_data + use t_surf_grp_list_each_surf + use t_group_data + use t_surface_group_normals + use t_surface_group_connect + use t_control_params_4_pvr +! + use calypso_mpi +! + implicit none +! + integer(kind = kint), parameter :: IFLAG_NONE = 0 + integer(kind = kint), parameter :: IFLAG_SHOW_EDGE = 2 + integer(kind = kint), parameter :: IFLAG_SHOW_REVERSE = -1 + integer(kind = kint), parameter :: IFLAG_SHOW_BOTH = 10 + integer(kind = kint), parameter :: IFLAG_SHOW_FORWARD = 1 +! + real(kind = kreal), parameter, private :: coef_op = 4.0e-2 +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_pvr_bc_enhanse_flag & + & (surf_grp, num_enhanse_grp, enhanse_grp, draw_type, & + & fixed_opacity, iflag_enhanse, enhansed_opacity) +! + use t_control_params_4_pvr + use m_pvr_control_labels + use skip_comment_f +! + type(surface_group_data), intent(in) :: surf_grp + integer(kind = kint), intent(in) :: num_enhanse_grp + character(len=kchara), intent(in) :: enhanse_grp(num_enhanse_grp) + character(len=kchara), intent(in) :: draw_type(num_enhanse_grp) + real(kind = kreal), intent(in) :: fixed_opacity(num_enhanse_grp) + integer(kind = kint), intent(inout) & + & :: iflag_enhanse(surf_grp%num_grp) + real(kind = kreal), intent(inout) & + & :: enhansed_opacity(surf_grp%num_grp) +! + integer(kind = kint) :: igrp, jgrp +! +! + iflag_enhanse(1:surf_grp%num_grp) = IFLAG_NONE + do jgrp = 1, num_enhanse_grp + do igrp = 1, surf_grp%num_grp + if(cmp_no_case(enhanse_grp(jgrp), & + & surf_grp%grp_name(igrp))) then + if(cmp_no_case(draw_type(jgrp), LABEL_EDGE)) then + iflag_enhanse(igrp) = IFLAG_SHOW_EDGE + else if(cmp_no_case(draw_type(jgrp), LABEL_BOTH)) then + iflag_enhanse(igrp) = IFLAG_SHOW_BOTH + else if(cmp_no_case(draw_type(jgrp), LABEL_FORWARD)) then + iflag_enhanse(igrp) = IFLAG_SHOW_FORWARD + else if(cmp_no_case(draw_type(jgrp), LABEL_REVERSE)) then + iflag_enhanse(igrp) = IFLAG_SHOW_REVERSE + end if + enhansed_opacity(igrp) = fixed_opacity(jgrp) + exit + end if + end do + end do +! + end subroutine set_pvr_bc_enhanse_flag +! +! --------------------------------------------------------------------- +! + real(kind = kreal) function opacity_by_surf_grp & + & (isurf, surf, surf_grp, sf_grp_4_sf, & + & modelview_mat, iflag_enhanse, enhansed_opacity) +! + use set_position_pvr_screen +! + integer(kind = kint), intent(in) :: isurf + type(surface_data), intent(in) :: surf + type(surface_group_data), intent(in) :: surf_grp + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf + real(kind = kreal), intent(in) :: modelview_mat(4,4) + integer(kind = kint), intent(in) & + & :: iflag_enhanse(surf_grp%num_grp) + real(kind = kreal), intent(in) & + & :: enhansed_opacity(surf_grp%num_grp) +! + integer(kind = kint) :: igrp, ist, ied, inum + real(kind = kreal) :: size_v, ratio, arccos_sf + real(kind = kreal) :: norm_sf_model(4), tmp_normal(3) +! +! + opacity_by_surf_grp = zero + ist = sf_grp_4_sf%istack_grp_surf(isurf-1) + 1 + ied = sf_grp_4_sf%istack_grp_surf(isurf ) + if(ied .lt. ist) return +! + arccos_sf = zero + do inum = ist, ied + igrp = sf_grp_4_sf%igrp_4_surf(inum) +! + tmp_normal(1:3) = surf%vnorm_surf(isurf,1:3) + norm_sf_model(1:4) = zero + call chenge_direction_pvr_modelview(modelview_mat, & + & ione, tmp_normal(1), norm_sf_model(1)) + if(norm_sf_model(3) .eq. zero) norm_sf_model(3) = 1e-6 +! + size_v = sqrt(norm_sf_model(1)*norm_sf_model(1) & + & + norm_sf_model(2)*norm_sf_model(2) & + & + norm_sf_model(3)*norm_sf_model(3)) + ratio = coef_op * size_v / norm_sf_model(3) +! + if(iflag_enhanse(igrp) .eq. IFLAG_SHOW_EDGE) then + if(abs(ratio) .gt. ONE) then + arccos_sf = max(enhansed_opacity(igrp), arccos_sf) + end if + else if(iflag_enhanse(igrp) .eq. IFLAG_SHOW_BOTH) then + arccos_sf = max(enhansed_opacity(igrp), arccos_sf) + else if(iflag_enhanse(igrp) .eq. IFLAG_SHOW_FORWARD) then + if(ratio .lt. zero) then + arccos_sf = max(enhansed_opacity(igrp), arccos_sf) + end if + else if(iflag_enhanse(igrp) .eq. IFLAG_SHOW_REVERSE) then + if(ratio .ge. zero) then + arccos_sf = max(enhansed_opacity(igrp), arccos_sf) + end if + end if + end do + opacity_by_surf_grp = arccos_sf +! + end function opacity_by_surf_grp +! +! --------------------------------------------------------------------- +! + end module pvr_surface_enhancement diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/ray_trace_4_each_image.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/ray_trace_4_each_image.f90 new file mode 100644 index 00000000..e177098e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/ray_trace_4_each_image.f90 @@ -0,0 +1,696 @@ +!>@file ray_trace_4_each_image.f90 +!!@brief module ray_trace_4_each_image +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!>@brief structure of control data for multiple volume rendering +!! +!!@verbatim +!! subroutine s_ray_trace_4_each_image(mesh, group, tracer, fline, & +!! & sf_grp_4_sf, field_pvr, pvr_screen, & +!! & draw_param, color_param, pvr_start) +!! type(mesh_geometry), intent(in) :: mesh +!! type(mesh_groups), intent(in) :: group +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +!! type(pvr_field_data), intent(in) :: field_pvr +!! type(pvr_projected_position), intent(in) :: pvr_screen +!! type(rendering_parameter), intent(in) :: draw_param +!! type(pvr_colormap_parameter), intent(in) :: color_param +!! type(pvr_ray_start_type), intent(inout) :: pvr_start +!!@endverbatim + module ray_trace_4_each_image +! + use m_precision +! + use m_constants + use m_geometry_constants + use calypso_mpi + use set_rgba_4_each_pixel +! + use t_mesh_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_particle_trace + use t_fieldline + use t_surf_grp_list_each_surf + use t_control_params_4_pvr + use t_pvr_colormap_parameter + use t_pvr_field_data + use t_geometries_in_pvr_screen +! + implicit none +! + private :: ray_trace_each_pixel +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_ray_trace_4_each_image(mesh, group, tracer, fline, & + & sf_grp_4_sf, field_pvr, pvr_screen, & + & draw_param, color_param, pvr_start) +! + use t_pvr_ray_startpoints +! + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +! + type(pvr_field_data), intent(in) :: field_pvr + type(pvr_projected_position), intent(in) :: pvr_screen + type(rendering_parameter), intent(in) :: draw_param + type(pvr_colormap_parameter), intent(in) :: color_param +! + type(pvr_ray_start_type), intent(inout) :: pvr_start +! + integer(kind = kint) :: inum, iflag_comm, icount_line_int + real(kind = kreal) :: rgba_tmp(4) +! +! + icount_line_int = 0 +!$omp parallel do private(inum,iflag_comm,rgba_tmp) & +!$omp& reduction(+:icount_line_int) + do inum = 1, pvr_start%num_pvr_ray + rgba_tmp(1:4) = zero + call ray_trace_each_pixel & + & (mesh%node, mesh%ele, mesh%surf, group%surf_grp, & + & sf_grp_4_sf, tracer, fline, pvr_screen%viewpoint_vec, & + & pvr_screen%modelview_mat, pvr_screen%projection_mat, & + & field_pvr, draw_param, color_param, ray_vec4, & + & pvr_start%id_pixel_check(inum), & + & pvr_start%isf_pvr_ray_start(1,inum), & + & pvr_start%xx4_pvr_ray_start(1,inum), & + & pvr_start%xx4_pvr_start(1,inum), & + & pvr_start%xi_pvr_start(1,inum), & + & rgba_tmp(1), icount_line_int, iflag_comm) + pvr_start%rgba_ray(1:4,inum) = rgba_tmp(1:4) + end do +!$omp end parallel do +! + end subroutine s_ray_trace_4_each_image +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine ray_trace_each_pixel & + & (node, ele, surf, surf_grp, sf_grp_4_sf, tracer, fline, & + & viewpoint_vec, modelview_mat, projection_mat, & + & field_pvr, draw_param, color_param, ray_vec4, & + & iflag_check, isurf_org, screen4_st, xx4_st, xi, & + & rgba_ray, icount_line_int, iflag_comm) +! + use set_position_pvr_screen + use cal_field_on_surf_viz + use cal_fline_in_cube + use set_coefs_of_sections + use pvr_surface_enhancement +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(surface_data), intent(in) :: surf + type(surface_group_data), intent(in) :: surf_grp + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + integer(kind = kint), intent(in) :: iflag_check +! + real(kind = kreal), intent(in) :: viewpoint_vec(3) + real(kind = kreal), intent(in) :: modelview_mat(4,4) + real(kind = kreal), intent(in) :: projection_mat(4,4) + real(kind = kreal), intent(in) :: ray_vec4(4) +! + type(pvr_field_data), intent(in) :: field_pvr + type(rendering_parameter), intent(in) :: draw_param + type(pvr_colormap_parameter), intent(in) :: color_param +! + integer(kind = kint), intent(inout) :: isurf_org(3) + integer(kind = kint), intent(inout) :: icount_line_int + integer(kind = kint), intent(inout) :: iflag_comm + real(kind = kreal), intent(inout) :: screen4_st(4) + real(kind = kreal), intent(inout) :: xx4_st(4), xi(2) + real(kind = kreal), intent(inout) :: rgba_ray(4) +! + integer(kind = kint) :: iflag_notrace + integer(kind = kint) :: isf_tgt, isurf_end, iele, isf_org + integer(kind = kint) :: iflag_hit + real(kind = kreal) :: screen4_tgt(4), c_tgt(1), c_org(1) + real(kind = kreal) :: xx4_model_sf(4,num_linear_sf,nsurf_4_ele) + real(kind = kreal) :: grad_tgt(3), xx4_tgt(4) +! +! + if(isurf_org(1) .eq. 0) return +! + iflag_notrace = 1 + iele = isurf_org(1) + isf_org = isurf_org(2) + isurf_end = abs(surf%isf_4_ele(iele,isf_org)) + call cal_field_on_surf_vect4 & + & (node%numnod, surf%numsurf, surf%nnod_4_surf, & + & surf%ie_surf, isurf_end, xi, node%xx, xx4_st) + call cal_field_on_surf_scalar & + & (node%numnod, surf%numsurf, surf%nnod_4_surf, & + & surf%ie_surf, isurf_end, xi, field_pvr%d_pvr, c_org(1) ) +! + if(iflag_check .gt. 0) then + iflag_hit = 0 + end if +! +! Set color if starting surface is colourd + if(ele%interior_ele(iele) .gt. 0) then + call rendering_surace_group & + & (isurf_end, surf, surf_grp, sf_grp_4_sf, & + & viewpoint_vec, modelview_mat, draw_param, color_param, & + & xx4_st, rgba_ray) + end if +! + do + icount_line_int = icount_line_int + 1 + iele = isurf_org(1) + isf_org = isurf_org(2) +! + if(draw_param%iflag_used_ele(iele).eq.0) then + iflag_comm = 2 + exit + end if +! +! extend to surface of element +! + call position_on_each_ele_sfs_wone & + & (surf, node%numnod, node%xx, iele, xx4_model_sf) + call project_once_each_element(modelview_mat, projection_mat, & + & (num_linear_sf*nsurf_4_ele), xx4_model_sf(1,1,1)) + call find_line_end_in_1ele(iflag_forward_line, & + & isf_org, ray_vec4, screen4_st, xx4_model_sf, & + & isf_tgt, screen4_tgt, xi) +! if(iflag_check .gt. 0) write(*,*) 'screen_tgt', & +! & my_rank, screen4_tgt(1:4), ele%interior_ele(iele) +! + if(isf_tgt .eq. 0) then + iflag_comm = -1 + exit + end if +! +! set backside element and surface +! + iflag_notrace = 0 + isurf_end = abs(surf%isf_4_ele(iele,isf_tgt)) +! + if(surf%isf_4_ele(iele,isf_tgt) .lt. 0) then + isurf_org(1) = surf%iele_4_surf(isurf_end,1,1) + isurf_org(2) = surf%iele_4_surf(isurf_end,1,2) + else + isurf_org(1) = surf%iele_4_surf(isurf_end,2,1) + isurf_org(2) = surf%iele_4_surf(isurf_end,2,2) + end if +! + call cal_field_on_surf_vect4 & + & (node%numnod, surf%numsurf, surf%nnod_4_surf, & + & surf%ie_surf, isurf_end, xi, node%xx, xx4_tgt) + call cal_field_on_surf_scalar & + & (node%numnod, surf%numsurf, surf%nnod_4_surf, & + & surf%ie_surf, isurf_end, xi, field_pvr%d_pvr, c_tgt(1)) +! + if(ele%interior_ele(iele) .gt. 0) then +! Set color if exit surface is colourd + call rendering_surace_group & + & (isurf_end, surf, surf_grp, sf_grp_4_sf, & + & viewpoint_vec, modelview_mat, draw_param, color_param, & + & xx4_tgt, rgba_ray) +! + call rendering_sections & + & (viewpoint_vec, draw_param, color_param, & + & xx4_st, xx4_tgt, c_org(1), c_tgt(1), rgba_ray, iflag_hit) + call rendering_isosurfaces(iele, viewpoint_vec, field_pvr, & + & draw_param, color_param, & + & xx4_tgt, c_org, c_tgt, rgba_ray) +! + call rendering_tracers & + & (viewpoint_vec, color_param, draw_param%tracer_pvr_prm, & + & tracer%num_trace, tracer%fline_lc, & + & xx4_tgt, c_tgt, rgba_ray) + call rendering_fieldlines & + & (viewpoint_vec, color_param, draw_param%fline_pvr_prm, & + & fline%num_fline, fline%fline_lc, & + & xx4_tgt, c_tgt, rgba_ray) +! + grad_tgt(1:3) = field_pvr%grad_ele(iele,1:3) + c_tgt(1) = half*(c_tgt(1) + c_org(1)) + call s_set_rgba_4_each_pixel & + & (viewpoint_vec, xx4_st, xx4_tgt, & + & c_tgt(1), grad_tgt, color_param, rgba_ray) + end if +! + if(isurf_org(1).eq.0) then + iflag_comm = 0 + exit + end if +! + screen4_st(1:4) = screen4_tgt(1:4) + xx4_st(1:4) = xx4_tgt(1:4) + c_org(1) = c_tgt(1) + end do +! +! if(iflag_check*draw_param%num_sections .gt. 0) then +! if(iflag_hit .eq. 0) then +! write(*,*) 'surface does not hit: ', my_rank, rgba_ray(1:4) +! else +! write(*,*) 'surface hit in: ', my_rank, rgba_ray(1:4) +! end if +! end if +! + end subroutine ray_trace_each_pixel +! +! --------------------------------------------------------------------- +! + subroutine rendering_sections & + & (viewpoint_vec, draw_param, color_param, & + & xx4_st, xx4_tgt, c_org, c_tgt, rgba_ray, iflag_hit) +! + use set_coefs_of_sections +! + real(kind = kreal), intent(in) :: viewpoint_vec(3) +! + type(rendering_parameter), intent(in) :: draw_param + type(pvr_colormap_parameter), intent(in) :: color_param + real(kind = kreal), intent(in) :: xx4_st(4) + real(kind = kreal), intent(in) :: xx4_tgt(4) + real(kind = kreal), intent(in) :: c_tgt(1), c_org(1) +! + real(kind = kreal), intent(inout) :: rgba_ray(4) + integer(kind = kint), intent(inout) :: iflag_hit +! + integer(kind = kint) :: i_psf + real(kind = kreal) :: grad_tgt(3), rflag1, rflag2 + logical :: flag_sect +! +! + do i_psf = 1, draw_param%num_sections + rflag1 = side_of_plane(draw_param%coefs(1:10,i_psf), xx4_st(1)) + rflag2 = side_of_plane(draw_param%coefs(1:10,i_psf), xx4_tgt(1)) +! + flag_sect = .FALSE. + if (rflag1 .ge. -TINY9 .and. rflag2 .le. TINY9) then + flag_sect = .TRUE. + iflag_hit = 1 + else if(rflag1 .le. TINY9 .and. rflag2 .ge. -TINY9) then + flag_sect = .TRUE. + iflag_hit = 1 + end if + + if(flag_sect) then + call cal_normal_of_plane & + & (draw_param%coefs(1:10,i_psf), xx4_tgt(1), grad_tgt) + call color_plane_with_light & + & (viewpoint_vec, xx4_tgt, c_tgt(1), grad_tgt, & + & draw_param%sect_opacity(i_psf), color_param, & + & rgba_ray) + if(draw_param%iflag_psf_zeoline(i_psf) .gt. 0 & + & .and. c_org(1)*c_tgt(1) .le. TINY9) then + call black_plane_with_light & + & (viewpoint_vec, xx4_tgt, grad_tgt, & + & draw_param%sect_opacity(i_psf), color_param, rgba_ray) + end if + end if + end do +! + end subroutine rendering_sections +! +! --------------------------------------------------------------------- +! + subroutine rendering_isosurfaces(iele, viewpoint_vec, field_pvr, & + & draw_param, color_param, & + & xx4_tgt, c_org, c_tgt, rgba_ray) +! + integer(kind = kint), intent(in) :: iele + real(kind = kreal), intent(in) :: viewpoint_vec(3) +! + type(pvr_field_data), intent(in) :: field_pvr + type(rendering_parameter), intent(in) :: draw_param + type(pvr_colormap_parameter), intent(in) :: color_param + real(kind = kreal), intent(in) :: xx4_tgt(4) + real(kind = kreal), intent(in) :: c_tgt(1), c_org(1) +! + real(kind = kreal), intent(inout) :: rgba_ray(4) +! + integer(kind = kint) :: i_iso + real(kind = kreal) :: grad_tgt(3), rflag +! +! + do i_iso = 1, draw_param%num_isosurf + rflag = (c_org(1) - draw_param%iso_value(i_iso)) & + & * (c_tgt(1) - draw_param%iso_value(i_iso)) + if((c_tgt(1) - draw_param%iso_value(i_iso)) .eq. zero & + & .or. rflag .lt. zero) then + grad_tgt(1:3) = field_pvr%grad_ele(iele,1:3) & + & * dble(draw_param%itype_isosurf(i_iso)) + call color_plane_with_light(viewpoint_vec, xx4_tgt, & + & draw_param%iso_value(i_iso), grad_tgt, & + & draw_param%iso_opacity(i_iso), color_param, rgba_ray) + end if + end do +! + end subroutine rendering_isosurfaces +! +! --------------------------------------------------------------------- +! + subroutine rendering_surace_group & + & (isurf_end, surf, surf_grp, sf_grp_4_sf, & + & viewpoint_vec, modelview_mat, draw_param, color_param, & + & xx4_tgt, rgba_ray) +! + use pvr_surface_enhancement +! + integer(kind = kint), intent(in) :: isurf_end + type(surface_data), intent(in) :: surf + type(surface_group_data), intent(in) :: surf_grp + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf + real(kind = kreal), intent(in) :: viewpoint_vec(3) + real(kind = kreal), intent(in) :: modelview_mat(4,4) +! + type(rendering_parameter), intent(in) :: draw_param + type(pvr_colormap_parameter), intent(in) :: color_param + real(kind = kreal), intent(in) :: xx4_tgt(4) +! + real(kind = kreal), intent(inout) :: rgba_ray(4) +! + real(kind = kreal) :: grad_tgt(3), opacity_bc +! +! + opacity_bc = opacity_by_surf_grp(isurf_end, surf, surf_grp, & + & sf_grp_4_sf, modelview_mat, & + & draw_param%iflag_enhanse, & + & draw_param%enhansed_opacity) + if(opacity_bc .gt. SMALL_RAY_TRACE) then + grad_tgt(1:3) = surf%vnorm_surf(isurf_end,1:3) + call plane_rendering_with_light(viewpoint_vec, & + & xx4_tgt, grad_tgt, opacity_bc, color_param, rgba_ray) + end if +! + end subroutine rendering_surace_group +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine rendering_tracers(viewpoint_vec, color_param, & + & tracer_pvr_prm, num_tracer, particle_lc, & + & xx4_tgt, c_tgt, rgba_ray) +! + use t_local_fline + use t_geometries_in_pvr_screen +! + real(kind = kreal), intent(in) :: viewpoint_vec(3) + type(tracer_render_param), intent(in) :: tracer_pvr_prm + type(pvr_colormap_parameter), intent(in) :: color_param +! + integer(kind = kint), intent(in) :: num_tracer + type(local_fieldline), intent(in) :: particle_lc(num_tracer) +! + real(kind = kreal), intent(in) :: xx4_tgt(4) + real(kind = kreal), intent(in) :: c_tgt(1) +! + real(kind = kreal), intent(inout) :: rgba_ray(4) +! + integer(kind = kint) :: i_fln, inum, increment + integer(kind = kint_gl) :: i_global + real(kind = kreal) :: grad_tgt(3), radius, distance + real(kind = kreal) :: rgb_color(3), opacity +! + if(tracer_pvr_prm%num_pvr_tracer .le. 0) return + do i_fln = 1, tracer_pvr_prm%num_pvr_tracer + increment = tracer_pvr_prm%increment(i_fln) + radius = tracer_pvr_prm%rendering_radius(i_fln) + opacity = tracer_pvr_prm%tracer_opacity(i_fln) + rgb_color(1:3) = tracer_pvr_prm%tracer_RGB(1:3,i_fln) + do inum = 1, particle_lc(i_fln)%nnod_line_l + i_global = particle_lc(i_fln)%iglobal_fline(inum) + if(mod(i_global-1,increment) .ne. 0) cycle +! + distance = distance_from_tracer(xx4_tgt, inum, & + & particle_lc(i_fln)) + if(distance .ge. radius) cycle +! +! opacity = opacity * (one - sqrt(distance / radius)) + call normal_of_single_tracer & + & (xx4_tgt, inum, particle_lc(i_fln), grad_tgt) +! + if(tracer_pvr_prm%iflag_color_mode(i_fln) & + & .eq. iflag_single_color) then + call surface_rendering_with_light & + & (viewpoint_vec, xx4_tgt, grad_tgt, rgb_color, & + & opacity, color_param, rgba_ray) + else + call color_plane_with_light & + & (viewpoint_vec, xx4_tgt, c_tgt(1), grad_tgt, & + & opacity, color_param, rgba_ray) + end if +! + end do + end do +! + end subroutine rendering_tracers +! +! ---------------------------------------------------------------------- +! + subroutine rendering_fieldlines(viewpoint_vec, color_param, & + & fline_pvr_prm, num_fline, fline_lc, & + & xx4_tgt, c_tgt, rgba_ray) +! + use t_local_fline + use t_geometries_in_pvr_screen +! + real(kind = kreal), intent(in) :: viewpoint_vec(3) + type(pvr_colormap_parameter), intent(in) :: color_param + type(tracer_render_param), intent(in) :: fline_pvr_prm +! + integer(kind = kint), intent(in) :: num_fline + type(local_fieldline), intent(in) :: fline_lc(num_fline) + real(kind = kreal), intent(in) :: xx4_tgt(4) + real(kind = kreal), intent(in) :: c_tgt(1) +! + real(kind = kreal), intent(inout) :: rgba_ray(4) +! + integer(kind = kint) :: i_fln, iedge, inod, increment + integer(kind = kint_gl) :: i_global + real(kind = kreal) :: grad_tgt(3), radius, distance + real(kind = kreal) :: rgb_color(3), opacity +! +! + if(fline_pvr_prm%num_pvr_tracer .le. 0) return + do i_fln = 1, fline_pvr_prm%num_pvr_tracer + increment = fline_pvr_prm%increment(i_fln) + radius = fline_pvr_prm%rendering_radius(i_fln) + opacity = fline_pvr_prm%tracer_opacity(i_fln) + rgb_color(1:3) = fline_pvr_prm%tracer_RGB(1:3,i_fln) + do iedge = 1, fline_lc(i_fln)%nele_line_l + inod = fline_lc(i_fln)%iedge_line_l(1,iedge) + i_global = fline_lc(i_fln)%iglobal_fline(inod) + if(mod(i_global-1,increment) .ne. 0) cycle +! + distance = distance_from_fline_segment(xx4_tgt, iedge, & + & fline_lc(i_fln)) + if(distance .ge. radius) cycle +! +! opacity = opacity * (one - sqrt(distance / radius)) + call normal_of_single_fline & + & (xx4_tgt, iedge, fline_lc(i_fln), grad_tgt) +! + if(fline_pvr_prm%iflag_color_mode(i_fln) & + & .eq. iflag_single_color) then + call surface_rendering_with_light & + & (viewpoint_vec, xx4_tgt, grad_tgt, rgb_color, & + & opacity, color_param, rgba_ray) + else + call color_plane_with_light & + & (viewpoint_vec, xx4_tgt, c_tgt(1), grad_tgt, & + & opacity, color_param, rgba_ray) + end if +! + end do + end do +! + end subroutine rendering_fieldlines +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + real(kind = kreal) function distance_from_tracer(point, & + & inum, fline_lc) +! + use t_local_fline +! + real(kind = kreal), intent(in) :: point(4) + integer(kind = kint), intent(in) :: inum + type(local_fieldline), intent(in) :: fline_lc +! + real(kind = kreal) :: xyzw(4) +! + xyzw(1:3) = fline_lc%xx_line_l(1:3,inum) + xyzw(4) = one + distance_from_tracer = distance_from_point(point, xyzw(1)) +! + end function distance_from_tracer +! +! ---------------------------------------------------------------------- +! + real(kind = kreal) function distance_from_fline_segment & + & (point, iedge, fline_lc) +! + use t_local_fline +! + real(kind = kreal), intent(in) :: point(4) + integer(kind = kint), intent(in) :: iedge + type(local_fieldline), intent(in) :: fline_lc +! + real(kind = kreal) :: xyzw_1(4), xyzw_2(4) + integer(kind = kint) :: i1, i2 +! + i1 = fline_lc%iedge_line_l(1,iedge) + i2 = fline_lc%iedge_line_l(2,iedge) + xyzw_1(1:3) = fline_lc%xx_line_l(1:3,i1) + xyzw_1(4) = one + xyzw_2(1:3) = fline_lc%xx_line_l(1:3,i2) + xyzw_2(4) = one +! + distance_from_fline_segment & + & = distance_from_line_segment(point, xyzw_1(1), xyzw_2(1)) +! + end function distance_from_fline_segment +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine normal_of_single_tracer & + & (xx4_tgt, inum, fline_lc, norm) +! + use t_local_fline +! + real(kind = kreal), intent(in) :: xx4_tgt(4) + integer(kind = kint), intent(in) :: inum + type(local_fieldline), intent(in) :: fline_lc + real(kind = kreal), intent(inout) :: norm(3) +! + norm(1:3) = xx4_tgt(1:3) - fline_lc%xx_line_l(1:3,inum) + call single_normalize_vector(norm) +! + end subroutine normal_of_single_tracer +! +! ---------------------------------------------------------------------- +! + subroutine normal_of_single_fline & + & (xx4_tgt, iedge, fline_lc, norm) +! + use t_local_fline +! + real(kind = kreal), intent(in) :: xx4_tgt(4) + integer(kind = kint), intent(in) :: iedge + type(local_fieldline), intent(in) :: fline_lc + real(kind = kreal), intent(inout) :: norm(3) +! + integer(kind = kint) :: i1, i2 +! + i1 = fline_lc%iedge_line_l(1,iedge) + i2 = fline_lc%iedge_line_l(2,iedge) + norm(1:3) = xx4_tgt(1:3) - half * (fline_lc%xx_line_l(1:3,i1) & + & + fline_lc%xx_line_l(1:3,i1)) + call single_normalize_vector(norm) +! + end subroutine normal_of_single_fline +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + real(kind = kreal) function distance_from_point(point, xyzw1) +! + real(kind = kreal), intent(in) :: point(4), xyzw1(4) + real(kind = kreal) :: x_line(1:4) +! + x_line(1:4) = xyzw1(1:4) - point(1:4) + distance_from_point = single_dot_product(x_line(1), x_line(1)) +! + end function distance_from_point +! +! ---------------------------------------------------------------------- +! + real(kind = kreal) function distance_from_line_segment & + & (point, xyzw1, xyzw2) +! + real(kind = kreal), intent(in) :: point(4), xyzw1(4), xyzw2(4) +! + real(kind = kreal) :: vec1(1:4), vec2(1:4) + real(kind = kreal) :: x_line(1:4), c_prod(1:4) + real(kind = kreal) :: dot1, dot2, area + real(kind = kreal) :: seg_len, dist_line +! + vec1(1:4) = point(1:4) - xyzw1(1:4) + vec2(1:4) = xyzw2(1:4) - xyzw1(1:4) + dot1 = single_dot_product(vec1(1), vec2(1)) + vec1(1:4) = point(1:4) - xyzw2(1:4) + vec2(1:4) = xyzw1(1:4) - xyzw2(1:4) + dot2 = single_dot_product(vec1(1), vec2(1)) +! + if (dot1 .le. zero) then + vec1(1:4) = point(1:4) - xyzw1(1:4) + dist_line = single_dot_product(vec1(1), vec1(1)) + else if(dot2 .le. zero) then + vec2(1:4) = point(1:4) - xyzw2(1:4) + dist_line = single_dot_product(vec2(1), vec2(1)) + else + x_line(1:4) = xyzw2(1:4) - xyzw1(1:4) + seg_len = single_dot_product(x_line(1), x_line(1)) + call single_cross_product(vec1(1), vec2(1), c_prod) + area = single_dot_product(c_prod(1), c_prod(1)) + dist_line = area / seg_len + end if + distance_from_line_segment = dist_line +! + end function distance_from_line_segment +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine single_normalize_vector(vector) +! + real (kind=kreal), intent(inout) :: vector(3) + real (kind=kreal) :: length +! + length = max(single_dot_product(vector(1), vector(1)), TINY) + vector(1:3) = vector(1:3) / length +! + end subroutine single_normalize_vector +! +! ---------------------------------------------------------------------- +! + real(kind = kreal) function single_dot_product(vect1, vect2) +! + real (kind=kreal), intent(in) :: vect1(3), vect2(3) + real (kind=kreal) :: prod +! + prod = vect1(1)*vect2(1) + vect1(2)*vect2(2) + vect1(3)*vect2(3) + single_dot_product = prod +! + end function single_dot_product +! +! ---------------------------------------------------------------------- +! + subroutine single_cross_product(vect1, vect2, prod) +! + real (kind=kreal), intent(in) :: vect1(3), vect2(3) + real (kind=kreal), intent(inout) :: prod(3) +! + prod(1) = (vect1(2)*vect2(3) - vect1(3)*vect2(2)) + prod(2) = (vect1(3)*vect2(1) - vect1(1)*vect2(3)) + prod(3) = (vect1(1)*vect2(2) - vect1(2)*vect2(1)) +! + end subroutine single_cross_product +! +! ---------------------------------------------------------------------- +! + end module ray_trace_4_each_image diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/rendering_and_image_nums.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/rendering_and_image_nums.f90 new file mode 100644 index 00000000..6b4197a7 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/rendering_and_image_nums.f90 @@ -0,0 +1,203 @@ +!>@file rendering_and_image_nums.f90 +!!@brief module rendering_and_image_nums +!! +!!@date Programmed by H.Matsui in May. 2006 +! +!>@brief Set PVR parameters from control files +!! +!!@verbatim +!! subroutine count_num_rendering_and_images(num_pvr, pvr_param, & +!! & num_pvr_images, istack_pvr_images) +!! subroutine set_rendering_and_image_pes(num_pe, num_pvr, pvr_ctl,& +!! & pvr_sort, num_pvr_images, pvr_rgb) +!! integer, intent(in) :: num_pe +!! integer(kind = kint), intent(in) :: num_pvr +!! integer(kind = kint), intent(in) :: num_pvr_images +!! type(PVR_control_params), intent(in) :: pvr_param(num_pvr) +!! type(pvr_parameter_ctl), intent(in) :: pvr_ctl(num_pvr) +!! type(sort_PVRs_by_type), intent(in) :: PVR_sort +!! integer(kind = kint), intent(inout) & +!! & :: istack_pvr_images(0:num_pvr) +!! type(pvr_image_type), intent(inout) :: pvr_rgb(num_pvr_images) +!!@endverbatim +! + module rendering_and_image_nums +! + use m_precision + use calypso_mpi +! + use t_control_data_4_pvr + use t_rendering_vr_image + use t_pvr_image_array + use t_sort_PVRs_by_type +! + implicit none +! + private :: set_pvr_file_prefix, set_pvr_file_control +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine count_num_rendering_and_images(num_pvr, pvr_param, & + & num_pvr_images, istack_pvr_images) +! + integer(kind = kint), intent(in) :: num_pvr + type(PVR_control_params), intent(in) :: pvr_param(num_pvr) +! + integer(kind = kint), intent(inout) & + & :: istack_pvr_images(0:num_pvr) + integer(kind = kint), intent(inout) :: num_pvr_images +! + integer(kind = kint) :: i_pvr +! +! + istack_pvr_images(0) = 0 + do i_pvr = 1, num_pvr + if(pvr_param(i_pvr)%stereo_def%flag_quilt) then + istack_pvr_images(i_pvr) = istack_pvr_images(i_pvr-1) & + & + pvr_param(i_pvr)%stereo_def%n_column_row_view(1) & + & * pvr_param(i_pvr)%stereo_def%n_column_row_view(2) + else if(pvr_param(i_pvr)%stereo_def%flag_anaglyph) then + istack_pvr_images(i_pvr) = istack_pvr_images(i_pvr-1) + 2 + else + istack_pvr_images(i_pvr) = istack_pvr_images(i_pvr-1) + 1 + end if + end do + num_pvr_images = istack_pvr_images(num_pvr) +! + if(iflag_debug .eq. 0) return + write(*,*) my_rank, 'num_pvr', num_pvr + write(*,*) my_rank, 'num_pvr_images', num_pvr_images + write(*,*) my_rank, 'num_pvr_images', istack_pvr_images +! + end subroutine count_num_rendering_and_images +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_rendering_and_image_pes(num_pe, num_pvr, pvr_ctl, & + & PVR_sort, num_pvr_images, pvr_rgb) +! + use m_error_IDs + use set_composition_pe_range + use set_parallel_file_name + use delete_data_files +! + integer, intent(in) :: num_pe + integer(kind = kint), intent(in) :: num_pvr + integer(kind = kint), intent(in) :: num_pvr_images +! + type(pvr_parameter_ctl), intent(in) :: pvr_ctl(num_pvr) + type(sort_PVRs_by_type), intent(in) :: PVR_sort +! + type(pvr_image_type), intent(inout) :: pvr_rgb(num_pvr_images) +! + integer(kind = kint) :: i_pvr, i_ctl, ist, ied, i + logical :: flag_error +! +! + call s_set_composition_pe_range & + & (num_pe, num_pvr, PVR_sort%istack_PVR_modes, & + & num_pvr_images, PVR_sort%istack_pvr_images, pvr_rgb) +! + do i_ctl = 1, num_pvr + i_pvr = PVR_sort%ipvr_sorted(i_ctl) + ist = PVR_sort%istack_pvr_images(i_pvr-1) + 1 + ied = PVR_sort%istack_pvr_images(i_pvr ) + do i = ist, ied + call set_pvr_file_control(pvr_ctl(i_ctl), & + & pvr_rgb(i)%iflag_monitoring, & + & pvr_rgb(i)%id_pvr_file_type) + pvr_rgb(i_pvr)%id_pvr_transparent = 0 + pvr_rgb(i)%pvr_prefix = set_pvr_file_prefix(pvr_ctl(i_ctl)) + end do + end do +! + flag_error = .FALSE. + do i = 1, PVR_sort%istack_pvr_images(num_pvr) + if(check_file_writable(my_rank, pvr_rgb(i)%pvr_prefix) & + & .eqv. .FALSE.) flag_error = .TRUE. + end do + if(flag_error) call calypso_mpi_abort(ierr_VIZ, & + & 'Check Directory for PVR output') +! +! + if(iflag_debug .eq. 0) return +! if(my_rank .gt. 0) return + write(*,*) 'ID, File, ouput_PE, end_composition_PE, Num_PE' + do i_pvr = 1, num_pvr_images + write(*,*) i_pvr, trim(pvr_rgb(i_pvr)%pvr_prefix), ' ', & + & pvr_rgb(i_pvr)%irank_image_file, & + & pvr_rgb(i_pvr)%irank_end_composit, & + & pvr_rgb(i_pvr)%npe_img_composit, & + & trim(pvr_rgb(i_pvr)%pvr_prefix) + end do +! + end subroutine set_rendering_and_image_pes +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + character(len = kchara) function set_pvr_file_prefix(pvr_ctl) +! + type(pvr_parameter_ctl), intent(in) :: pvr_ctl +! +! + if(pvr_ctl%file_head_ctl%iflag .gt. 0) then + set_pvr_file_prefix = pvr_ctl%file_head_ctl%charavalue + else + set_pvr_file_prefix = 'pvr' + end if +! + end function set_pvr_file_prefix +! +! --------------------------------------------------------------------- +! + subroutine set_pvr_file_control(pvr_ctl, & + & iflag_monitoring, id_pvr_file_type) +! + use t_control_params_4_pvr + use set_area_4_viz + use skip_comment_f + use output_image_sel_4_png +! + type(pvr_parameter_ctl), intent(in) :: pvr_ctl + integer(kind = kint), intent(inout) :: iflag_monitoring + integer(kind = kint), intent(inout) :: id_pvr_file_type +! + character(len = kchara) :: tmpchara +! +! + tmpchara = pvr_ctl%file_fmt_ctl%charavalue + if(cmp_no_case(tmpchara, hd_PNG)) then + id_pvr_file_type = iflag_PNG + else if(cmp_no_case(tmpchara, hd_QUILT_BMP)) then + id_pvr_file_type = iflag_QUILT_BMP + else if(cmp_no_case(tmpchara, hd_QUILT_BMP_GZ) & + & .or. cmp_no_case(tmpchara, hd_QUILT_BMP_GZ2) & + & .or. cmp_no_case(tmpchara, hd_QUILT_BMP_GZ3) & + & .or. cmp_no_case(tmpchara, hd_QUILT_BMP_GZ4)) then + id_pvr_file_type = iflag_QUILT_BMP_GZ + else if(cmp_no_case(tmpchara, hd_BMP)) then + id_pvr_file_type = iflag_BMP + else + id_pvr_file_type = iflag_BMP + end if +! + iflag_monitoring = 0 + if(yes_flag(pvr_ctl%monitoring_ctl%charavalue)) then + iflag_monitoring = 1 + end if +! + if(iflag_debug .gt. 0) then + write(*,*) 'id_pvr_file_type', id_pvr_file_type + end if +! + end subroutine set_pvr_file_control +! +! --------------------------------------------------------------------- +! + end module rendering_and_image_nums diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/rendering_streo_vr_image.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/rendering_streo_vr_image.f90 new file mode 100644 index 00000000..b24b72a1 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/rendering_streo_vr_image.f90 @@ -0,0 +1,129 @@ +!>@file rendering_streo_vr_image.f90 +!! module rendering_streo_vr_image +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structures for position in the projection coordinate +!! +!!@verbatim +!! subroutine rendering_with_rotation & +!! & (istep_pvr, time, elps_PVR, mesh, group, tracer, fline,& +!! & sf_grp_4_sf, field_pvr, pvr_rgb, pvr_param, & +!! & pvr_bound, pvr_proj, SR_sig, SR_r, SR_i) +!! integer(kind = kint), intent(in) :: istep_pvr +!! real(kind = kreal), intent(in) :: time +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(mesh_geometry), intent(in) :: mesh +!! type(mesh_groups), intent(in) :: group +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +!! type(pvr_field_data), intent(in) :: field_pvr +!! type(pvr_image_type), intent(in) :: pvr_rgb +!! type(PVR_control_params), intent(inout) :: pvr_param +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! type(PVR_projection_data), intent(inout) :: pvr_proj +!! type(send_recv_status), intent(inout) :: SR_sig +!! type(send_recv_real_buffer), intent(inout) :: SR_r +!! type(send_recv_int_buffer), intent(inout) :: SR_i +!!@endverbatim +! + module rendering_streo_vr_image +! + use m_precision + use m_machine_parameter + use m_constants + use m_work_time +! + use calypso_mpi +! + use t_mesh_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_phys_data + use t_jacobians + use t_surf_grp_list_each_surf + use t_rendering_vr_image + use t_control_params_4_pvr + use t_geometries_in_pvr_screen + use t_surf_grp_4_pvr_domain + use t_pvr_ray_startpoints + use t_pvr_image_array + use t_pvr_field_data + use t_solver_SR + use t_solver_SR_int + use generate_vr_image +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine rendering_with_rotation & + & (istep_pvr, time, elps_PVR, mesh, group, tracer, fline, & + & sf_grp_4_sf, field_pvr, pvr_rgb, pvr_param, & + & pvr_bound, pvr_proj, SR_sig, SR_r, SR_i) +! + use t_rotation_pvr_images + use set_PVR_view_and_image + use write_multi_PVR_image + use output_image_sel_4_png + use rendering_vr_image +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time +! + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf + type(pvr_field_data), intent(in) :: field_pvr + type(pvr_image_type), intent(in) :: pvr_rgb +! + type(PVR_control_params), intent(inout) :: pvr_param + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(PVR_projection_data), intent(inout) :: pvr_proj + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r + type(send_recv_int_buffer), intent(inout) :: SR_i +! + integer(kind = kint) :: i_rot + type(rotation_pvr_images) :: rot_imgs1 +! +! + call init_rot_pvr_image_arrays & + & (pvr_param%movie_def, pvr_rgb, rot_imgs1) +! + do i_rot = 1, pvr_param%movie_def%num_frame + call rotation_view_projection_mats(i_rot, pvr_param, & + & pvr_proj%screen) + call rendering_at_once(istep_pvr, time, elps_PVR, & + & mesh, group, tracer, fline, sf_grp_4_sf, & + & field_pvr, pvr_param, pvr_bound, pvr_proj, & + & rot_imgs1%rot_pvr_rgb(i_rot), SR_sig, SR_r, SR_i) + end do + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+1) +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+2) + call output_rotation_PVR_images(istep_pvr, & + & pvr_param%movie_def%num_frame, rot_imgs1%rot_pvr_rgb(1)) + call dealloc_rot_pvr_image_arrays(pvr_param%movie_def, rot_imgs1) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+2) + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+1) +! + end subroutine rendering_with_rotation +! +! --------------------------------------------------------------------- +! + end module rendering_streo_vr_image diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/rendering_vr_image.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/rendering_vr_image.f90 new file mode 100644 index 00000000..b5842f5b --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/rendering_vr_image.f90 @@ -0,0 +1,283 @@ +!>@file rendering_vr_image.f90 +!! module rendering_vr_image +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structures for position in the projection coordinate +!! +!!@verbatim +!! subroutine set_fixed_view_and_image(elps_PVR, mesh, & +!! & pvr_param, pvr_rgb, pvr_bound, pvr_proj, m_SR) +!! subroutine rendering_with_fixed_view(istep_pvr, time, elps_PVR, & +!! & mesh, group, tracer, fline, sf_grp_4_sf, & +!! & field_pvr, pvr_param, pvr_proj, pvr_rgb, & +!! & SR_sig, SR_r) +!! +!! subroutine rendering_at_once & +!! & (istep_pvr, time, elps_PVR, mesh, group, tracer, fline,& +!! & sf_grp_4_sf, field_pvr, pvr_param, pvr_bound, & +!! & pvr_proj, pvr_rgb, SR_sig, SR_r, SR_i) +!! integer(kind = kint), intent(in) :: i_img, i_rot +!! integer(kind = kint), intent(in) :: istep_pvr +!! type(elapsed_lables), intent(in) :: elps_PVR +!! real(kind = kreal), intent(in) :: time +!! type(mesh_geometry), intent(in) :: mesh +!! type(mesh_groups), intent(in) :: group +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf +!! type(pvr_field_data), intent(in) :: field_pvr +!! type(PVR_control_params), intent(in) :: pvr_param +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! type(PVR_projection_data), intent(inout) :: pvr_proj +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module rendering_vr_image +! + use m_precision + use m_machine_parameter + use m_constants + use m_work_time +! + use calypso_mpi +! + use t_mesh_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_particle_trace + use t_fieldline +! + use t_surf_grp_list_each_surf + use t_control_params_4_pvr + use t_pvr_colormap_parameter + use t_geometries_in_pvr_screen + use t_pvr_ray_startpoints + use t_pvr_image_array + use t_pvr_stencil_buffer + use t_pvr_field_data + use t_rendering_vr_image + use t_control_params_stereo_pvr + use t_mesh_SR + use generate_vr_image +! + implicit none +! + private :: rendering_image +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_fixed_view_and_image(elps_PVR, mesh, & + & pvr_param, pvr_rgb, pvr_bound, pvr_proj, m_SR) +! + use cal_pvr_projection_mat + use cal_pvr_modelview_mat + use t_pvr_stencil_buffer +! + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(PVR_control_params), intent(in) :: pvr_param + type(pvr_image_type), intent(in) :: pvr_rgb +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(PVR_projection_data), intent(inout) :: pvr_proj + type(mesh_SR), intent(inout) :: m_SR +! +! + call transfer_to_screen(mesh%node, mesh%surf, & + & pvr_param%pixel, pvr_param%multi_view(1)%n_pvr_pixel, & + & pvr_bound, pvr_proj%screen, pvr_proj%start_fix) + call const_pvr_stencil_buffer & + & (elps_PVR, pvr_rgb, pvr_proj%start_fix, pvr_proj%stencil, & + & m_SR%SR_sig, m_SR%SR_r, m_SR%SR_i) +! + call allocate_item_pvr_ray_start & + & (pvr_proj%start_fix%num_pvr_ray, pvr_proj%start_save) + call copy_item_pvr_ray_start & + & (pvr_proj%start_fix, pvr_proj%start_save) +! + end subroutine set_fixed_view_and_image +! +! --------------------------------------------------------------------- +! + subroutine rendering_with_fixed_view(istep_pvr, time, elps_PVR, & + & mesh, group, tracer, fline, sf_grp_4_sf, & + & field_pvr, pvr_param, pvr_proj, pvr_rgb, & + & SR_sig, SR_r) +! + use write_PVR_image +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf + type(pvr_field_data), intent(in) :: field_pvr + type(PVR_control_params), intent(in) :: pvr_param +! + type(PVR_projection_data), intent(inout) :: pvr_proj + type(pvr_image_type), intent(inout) :: pvr_rgb + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r +! +! + call copy_item_pvr_ray_start & + & (pvr_proj%start_save, pvr_proj%start_fix) +! + if(iflag_debug .gt. 0) write(*,*) 'rendering_image' + call rendering_image(istep_pvr, time, elps_PVR, & + & mesh, group, tracer, fline, sf_grp_4_sf, & + & pvr_param%color, pvr_param%colorbar, field_pvr, & + & pvr_param%draw_param, pvr_proj%screen, pvr_proj%start_fix, & + & pvr_proj%stencil, pvr_rgb, SR_sig, SR_r) +! + end subroutine rendering_with_fixed_view +! +! --------------------------------------------------------------------- +! + subroutine rendering_at_once & + & (istep_pvr, time, elps_PVR, mesh, group, tracer, fline, & + & sf_grp_4_sf, field_pvr, pvr_param, pvr_bound, & + & pvr_proj, pvr_rgb, SR_sig, SR_r, SR_i) +! + use cal_pvr_projection_mat + use cal_pvr_modelview_mat + use write_PVR_image + use t_pvr_stencil_buffer +! + integer(kind = kint), intent(in) :: istep_pvr + type(elapsed_lables), intent(in) :: elps_PVR + real(kind = kreal), intent(in) :: time + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf + type(pvr_field_data), intent(in) :: field_pvr + type(PVR_control_params), intent(in) :: pvr_param +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(PVR_projection_data), intent(inout) :: pvr_proj + type(pvr_image_type), intent(inout) :: pvr_rgb + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r + type(send_recv_int_buffer), intent(inout) :: SR_i +! +! + call transfer_to_screen(mesh%node, mesh%surf, & + & pvr_param%pixel, pvr_param%multi_view(1)%n_pvr_pixel, & + & pvr_bound, pvr_proj%screen, pvr_proj%start_fix) + call const_pvr_stencil_buffer(elps_PVR, pvr_rgb, & + & pvr_proj%start_fix, pvr_proj%stencil, SR_sig, SR_r, SR_i) +! + if(iflag_debug .gt. 0) write(*,*) 'rendering_image' + call rendering_image(istep_pvr, time, elps_PVR, & + & mesh, group, tracer, fline, sf_grp_4_sf, & + & pvr_param%color, pvr_param%colorbar, field_pvr, & + & pvr_param%draw_param, pvr_proj%screen, pvr_proj%start_fix, & + & pvr_proj%stencil, pvr_rgb, SR_sig, SR_r) + call deallocate_pvr_ray_start(pvr_proj%start_fix) + call dealloc_pvr_stencil_buffer(pvr_proj%stencil) +! + end subroutine rendering_at_once +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine rendering_image & + & (istep_pvr, time, elps_PVR, mesh, group, tracer, fline, & + & sf_grp_4_sf, color_param, cbar_param, field_pvr, & + & draw_param, pvr_screen, pvr_start, pvr_stencil, & + & pvr_rgb, SR_sig, SR_r) +! + use m_geometry_constants + use t_solver_SR +! + use ray_trace_4_each_image + use draw_pvr_colorbar + use pvr_axis_label +! use composit_by_segmentad_image +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time +! + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(mesh_groups), intent(in) :: group + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(sf_grp_list_each_surf), intent(in) :: sf_grp_4_sf + type(pvr_field_data), intent(in) :: field_pvr + type(rendering_parameter), intent(in) :: draw_param + type(pvr_colormap_parameter), intent(in) :: color_param + type(pvr_colorbar_parameter), intent(in) :: cbar_param + type(pvr_projected_position), intent(in) :: pvr_screen +! + type(pvr_ray_start_type), intent(inout) :: pvr_start + type(pvr_stencil_buffer), intent(inout) :: pvr_stencil +! type(pvr_segmented_img), intent(inout) :: pvr_img + type(pvr_image_type), intent(inout) :: pvr_rgb + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r +! +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+3) + if(iflag_debug .gt. 0) write(*,*) 's_ray_trace_4_each_image' + call s_ray_trace_4_each_image & + & (mesh, group, tracer, fline, sf_grp_4_sf, & + & field_pvr, pvr_screen, draw_param, color_param, pvr_start) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+3) +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+4) + if(iflag_debug .gt. 0) write(*,*) 'collect_rendering_image' + call collect_rendering_image(pvr_start, & + & pvr_rgb%num_pixel_actual, pvr_rgb%rgba_real_gl, pvr_stencil, & + & SR_sig, SR_r) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+4) +! +! call s_composit_by_segmentad_image(istep_pvr, elps_PVR, & +! & pvr_start, pvr_stencil, pvr_img, pvr_rgb) +! + if(my_rank .eq. pvr_rgb%irank_image_file) then + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+3) + if(cbar_param%flag_pvr_colorbar) then + call set_pvr_colorbar & + & (pvr_rgb%num_pixel_xy, pvr_rgb%num_pixels, & + & color_param, cbar_param, pvr_rgb%rgba_real_gl) + end if +! + if(cbar_param%flag_draw_time) then + call set_pvr_timelabel & + & (time, pvr_rgb%num_pixel_xy, pvr_rgb%num_pixels, & + & cbar_param, pvr_rgb%rgba_real_gl) + end if +! + if(cbar_param%flag_pvr_axis) then + call set_pvr_axislabel & + & (pvr_rgb%num_pixel_xy, pvr_rgb%num_pixels, & + & cbar_param%iscale_font, pvr_screen, pvr_rgb%rgba_real_gl) + end if + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+3) + end if +! + end subroutine rendering_image +! +! --------------------------------------------------------------------- +! + end module rendering_vr_image diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_PVR_view_and_image.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_PVR_view_and_image.f90 new file mode 100644 index 00000000..1d320818 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_PVR_view_and_image.f90 @@ -0,0 +1,187 @@ +!>@file set_PVR_view_and_image.f90 +!!@brief module set_PVR_view_and_image +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +! +!>@brief Main module for each volume rendering +!! +!!@verbatim +!! subroutine single_PVR_view_matrices(elps_PVR, mesh, & +!! & pvr_rgb, pvr_param, pvr_bound, pvr_proj, m_SR) +!! subroutine quilt_PVR_view_matrices(num_img, elps_PVR, mesh, & +!! & pvr_rgb, pvr_param, pvr_bound, pvr_proj, m_SR) +!! subroutine anaglyph_PVR_view_matrices(elps_PVR, mesh, & +!! & pvr_rgb, pvr_param, pvr_bound, pvr_proj, m_SR) +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(mesh_geometry), intent(in) :: mesh +!! type(pvr_image_type), intent(in) :: pvr_rgb +!! type(PVR_control_params), intent(in) :: pvr_param +!! type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +!! type(PVR_projection_data), intent(inout) :: pvr_proj +!! type(mesh_SR), intent(inout) :: m_SR +!! +!! subroutine rotation_view_projection_mats(i_rot, & +!! & pvr_param, screen) +!! subroutine rot_multi_view_projection_mats(i_img, i_rot, & +!! & pvr_param, screen) +!! integer(kind = kint), intent(in) :: i_rot +!! type(PVR_control_params), intent(in) :: pvr_param +!! type(pvr_projected_position), intent(inout) :: screen +!!@endverbatim +! + module set_PVR_view_and_image +! + use m_precision + use calypso_mpi +! + use m_constants + use m_machine_parameter + use m_geometry_constants + use m_work_time +! + use t_mesh_data + use t_pvr_image_array + use t_rendering_vr_image + use t_surf_grp_4_pvr_domain + use t_geometries_in_pvr_screen + use t_mesh_SR +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine single_PVR_view_matrices(elps_PVR, mesh, & + & pvr_rgb, pvr_param, pvr_bound, pvr_proj, m_SR) +! + use rendering_vr_image +! + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(pvr_image_type), intent(in) :: pvr_rgb + type(PVR_control_params), intent(in) :: pvr_param +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(PVR_projection_data), intent(inout) :: pvr_proj + type(mesh_SR), intent(inout) :: m_SR +! +! + call rotation_view_projection_mats(izero, pvr_param, & + & pvr_proj%screen) + call set_fixed_view_and_image(elps_PVR, mesh, pvr_param, pvr_rgb, & + & pvr_bound, pvr_proj, m_SR) +! + end subroutine single_PVR_view_matrices +! +! --------------------------------------------------------------------- +! + subroutine quilt_PVR_view_matrices(num_img, elps_PVR, mesh, & + & pvr_rgb, pvr_param, pvr_bound, pvr_proj, m_SR) +! + use rendering_vr_image +! + integer(kind = kint), intent(in) :: num_img + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(pvr_image_type), intent(in) :: pvr_rgb(num_img) + type(PVR_control_params), intent(in) :: pvr_param +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(PVR_projection_data), intent(inout) :: pvr_proj(num_img) + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_img +! +! + do i_img = 1, num_img + call rot_multi_view_projection_mats(i_img, izero, pvr_param, & + & pvr_proj(i_img)%screen) + call set_fixed_view_and_image(elps_PVR, mesh, pvr_param, & + & pvr_rgb(i_img), pvr_bound, pvr_proj(i_img), m_SR) + end do +! + end subroutine quilt_PVR_view_matrices +! +! --------------------------------------------------------------------- +! + subroutine anaglyph_PVR_view_matrices(elps_PVR, mesh, & + & pvr_rgb, pvr_param, pvr_bound, pvr_proj, m_SR) +! + use rendering_vr_image +! + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_geometry), intent(in) :: mesh + type(pvr_image_type), intent(in) :: pvr_rgb + type(PVR_control_params), intent(in) :: pvr_param +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound + type(PVR_projection_data), intent(inout) :: pvr_proj(2) + type(mesh_SR), intent(inout) :: m_SR +! +! + call rot_multi_view_projection_mats(ione, izero, pvr_param, & + & pvr_proj(1)%screen) + call rot_multi_view_projection_mats(itwo, izero, pvr_param, & + & pvr_proj(2)%screen) + call set_fixed_view_and_image(elps_PVR, mesh, pvr_param, pvr_rgb, & + & pvr_bound, pvr_proj(1), m_SR) + call set_fixed_view_and_image(elps_PVR, mesh, pvr_param, pvr_rgb, & + & pvr_bound, pvr_proj(2), m_SR) +! + end subroutine anaglyph_PVR_view_matrices +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine rotation_view_projection_mats(i_rot, & + & pvr_param, screen) +! + use cal_pvr_modelview_mat + use cal_pvr_projection_mat +! + integer(kind = kint), intent(in) :: i_rot + type(PVR_control_params), intent(in) :: pvr_param +! + type(pvr_projected_position), intent(inout) :: screen +! +! + call set_pvr_projection_matrix & + & (pvr_param%multi_view(1), screen%projection_mat) + call cal_pvr_modelview_matrix(ione, i_rot, & + & pvr_param%outline, pvr_param%movie_def, & + & pvr_param%stereo_def, pvr_param%multi_view(1), & + & screen%viewpoint_vec, screen%modelview_mat) +! + end subroutine rotation_view_projection_mats +! +! --------------------------------------------------------------------- +! + subroutine rot_multi_view_projection_mats(i_img, i_rot, & + & pvr_param, screen) +! + use cal_pvr_modelview_mat + use cal_pvr_projection_mat +! + integer(kind = kint), intent(in) :: i_img, i_rot + type(PVR_control_params), intent(in) :: pvr_param +! + type(pvr_projected_position), intent(inout) :: screen +! +! + call set_pvr_step_projection_mat & + & (i_img, pvr_param%multi_view(1), pvr_param%stereo_def, & + & screen%projection_mat) + call cal_pvr_modelview_matrix(i_img, i_rot, & + & pvr_param%outline, pvr_param%movie_def, & + & pvr_param%stereo_def, pvr_param%multi_view(1), & + & screen%viewpoint_vec, screen%modelview_mat) +! + end subroutine rot_multi_view_projection_mats +! +! --------------------------------------------------------------------- +! + end module set_PVR_view_and_image diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_color_4_pvr.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_color_4_pvr.f90 new file mode 100644 index 00000000..18fa3cdb --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_color_4_pvr.f90 @@ -0,0 +1,176 @@ +!>@file set_color_4_pvr.f90 +!! module set_color_4_pvr +!! +!!@author H. Matsui +!!@date Programmed in July. 2006 +! +!> @brief Structures for parameteres for volume rendering +!! +!!@verbatim +!! subroutine normalize_by_color(value, id_colormap_style, & +!! & num_point, datamap_param, colordat) +!! subroutine restore_from_normalize(value_rgb, id_colormap_style,& +!! & mincolor, maxcolor, num_point, datamap_param, value) +!! +!! subroutine normvalue_to_rgb(id_color_system, colordat, color) +!! +!! subroutine value_to_rgb(id_colormap_style, id_color_system, & +!! & num_interval_map, interval_point, value, color) +!!@endverbatim +! + module set_color_4_pvr +! + use m_precision +! + use set_rgb_colors +! + implicit none +! + character(len = kchara), parameter :: hd_rainbow = 'rainbow' + character(len = kchara), parameter :: hd_grayscale = 'grayscale' + character(len = kchara), parameter & + & :: hd_radblue = 'blue_to_red' + character(len = kchara), parameter & + & :: hd_sym_gray = 'symmetric_grayscale' + character(len = kchara), parameter & + & :: hd_orangecyan = 'cyan_to_orange' + character(len = kchara), parameter & + & :: hd_moltenmetal = 'molten_metal' + character(len = kchara), parameter & + & :: hd_spacecolor = 'space' +! + integer(kind = kint), parameter :: iflag_rainbow = 1 + integer(kind = kint), parameter :: iflag_grayscale = 2 + integer(kind = kint), parameter :: iflag_redblue = 3 + integer(kind = kint), parameter :: iflag_sym_gray = 4 + integer(kind = kint), parameter :: iflag_orangecyan = 5 + integer(kind = kint), parameter :: iflag_moltenmetal = 6 + integer(kind = kint), parameter :: iflag_spacecolor = 7 +! + character(len = kchara), parameter :: hd_minmax = 'minmax' + character(len = kchara), parameter :: hd_linear = 'linear' + character(len = kchara), parameter :: hd_nonlinear = 'nonlinear' + character(len = kchara), parameter & + & :: hd_colorlist = 'colormap_list' + integer(kind = kint), parameter :: iflag_automatic = 1 + integer(kind = kint), parameter :: iflag_minmax = 2 + integer(kind = kint), parameter :: iflag_colorlist = 3 +! +! ---------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine normalize_by_color(value, id_colormap_style, & + & num_point, datamap_param, colordat) +! + integer(kind = kint), intent(in) :: id_colormap_style + real(kind = kreal), intent(in) :: value + integer(kind = kint), intent(in) :: num_point + real(kind = kreal), intent(in) :: datamap_param(2,num_point) +! + real(kind = kreal), intent(out) :: colordat +! +! + if(id_colormap_style .eq. iflag_colorlist) then + call normalize_by_linear_segment(num_point, datamap_param, & + & value, colordat) + else + call normalize_by_linear(datamap_param(1,1), & + & datamap_param(1,2), value, colordat) + end if +! + end subroutine normalize_by_color +! +! ---------------------------------------------------------------------- +! + subroutine restore_from_normalize(value_rgb, id_colormap_style, & + & mincolor, maxcolor, num_point, datamap_param, value) +! + integer(kind = kint), intent(in) :: id_colormap_style + real(kind = kreal), intent(in) :: value_rgb + real(kind = kreal), intent(in) :: mincolor, maxcolor + integer(kind = kint), intent(in) :: num_point + real(kind = kreal), intent(in) :: datamap_param(2,num_point) +! + real(kind = kreal), intent(out) :: value +! +! + if(id_colormap_style .eq. iflag_colorlist) then + call restore_segment_normalize(value_rgb, & + & mincolor, maxcolor, num_point, datamap_param, value) + else + call restore_linear_normalize(value_rgb, mincolor, maxcolor, & + & value) + end if +! + end subroutine restore_from_normalize +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine normvalue_to_rgb(id_color_system, colordat, color) +! + use set_rgb_colors + use colormap_rainbow + use colormap_two_colors + use colormap_grayscales + use colormap_metal + use colormap_space +! + integer(kind = kint), intent(in) :: id_color_system + real(kind = kreal), intent(in) :: colordat +! + real(kind = kreal), intent(out) :: color(3) +! +! + if(id_color_system .eq. iflag_redblue) then + call s_colormap_redblue(colordat, color(1), color(2), color(3)) + else if(id_color_system .eq. iflag_orangecyan) then + call s_colormap_orangecyan & + & (colordat, color(1), color(2), color(3)) + else if(id_color_system .eq. iflag_moltenmetal) then + call s_colormap_metal(colordat, color(1), color(2), color(3)) + else if(id_color_system .eq. iflag_spacecolor) then + call s_colormap_space(colordat, color(1), color(2), color(3)) + else if(id_color_system .eq. iflag_sym_gray) then + call s_colormap_sym_grayscale & + & (colordat, color(1), color(2), color(3)) + else if(id_color_system .eq. iflag_grayscale) then + call s_colormap_grayscale & + & (colordat, color(1), color(2), color(3)) + else + call s_colormap_rainbow(colordat, color(1), color(2), color(3)) + end if +! + end subroutine normvalue_to_rgb +! +! ---------------------------------------------------------------------- +! + subroutine value_to_rgb(id_colormap_style, id_color_system, & + & num_interval_map, interval_point, value, color) +! + use set_rgb_colors +! + integer(kind = kint), intent(in) :: id_colormap_style + integer(kind = kint), intent(in) :: id_color_system + integer(kind = kint), intent(in) :: num_interval_map + real(kind = kreal), intent(in) & + & :: interval_point(2,num_interval_map) + real(kind = kreal), intent(in) :: value +! + real(kind = kreal), intent(inout) :: color(3) +! + real(kind = kreal) :: colordat +! +! + call normalize_by_color(value, id_colormap_style, & + & num_interval_map, interval_point, colordat) + call normvalue_to_rgb(id_color_system, colordat, color) +! + end subroutine value_to_rgb +! +! ---------------------------------------------------------------------- +! + end module set_color_4_pvr diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_composition_pe_range.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_composition_pe_range.f90 new file mode 100644 index 00000000..5cf15594 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_composition_pe_range.f90 @@ -0,0 +1,208 @@ +!>@file set_composition_pe_range.f90 +!!@brief module set_composition_pe_range +!! +!!@date Programmed by H.Matsui in May. 2006 +! +!>@brief Set PVR parameters from control files +!! +!!@verbatim +!! subroutine s_set_composition_pe_range & +!! & (num_pe, num_pvr, istack_PVR_modes, & +!! & num_pvr_images, istack_pvr_images, pvr_rgb) +!! type(PVR_control_params), intent(in) :: pvr_param(num_pvr) +!! type(pvr_image_type), intent(inout) :: pvr_rgb(num_pvr_images) +!!!@endverbatim +! + module set_composition_pe_range +! + use m_precision +! + use t_rendering_vr_image + use t_pvr_image_array +! + implicit none +! + private :: set_rank_to_write_tmp, set_rank_to_write_images + private :: each_composition_pe_range +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_set_composition_pe_range & + & (num_pe, num_pvr, istack_PVR_modes, & + & num_pvr_images, istack_pvr_images, pvr_rgb) +! + integer, intent(in) :: num_pe + integer(kind = kint), intent(in) :: num_pvr + integer(kind = kint), intent(in) :: istack_PVR_modes(0:6) +! + integer(kind = kint), intent(in) :: num_pvr_images + integer(kind = kint), intent(in) :: istack_pvr_images(0:num_pvr) +! + type(pvr_image_type), intent(inout) :: pvr_rgb(num_pvr_images) +! + integer(kind = kint) :: i_pvr, ist_pvr, ied_pvr +! +! + ist_pvr = istack_PVR_modes(0) + 1 + ied_pvr = istack_PVR_modes(2) + call each_composition_pe_range & + & (num_pe, num_pvr, ist_pvr, ied_pvr, & + & num_pvr_images, istack_pvr_images, pvr_rgb) +! + do i_pvr = 3, 6 + ist_pvr = istack_PVR_modes(i_pvr-1) + 1 + ied_pvr = istack_PVR_modes(i_pvr) + call each_composition_pe_range & + & (num_pe, num_pvr, ist_pvr, ied_pvr, & + & num_pvr_images, istack_pvr_images, pvr_rgb) + end do +! + end subroutine s_set_composition_pe_range +! +! --------------------------------------------------------------------- +! + subroutine each_composition_pe_range & + & (num_pe, num_pvr, ist_pvr, ied_pvr, & + & num_pvr_images, istack_pvr_images, pvr_rgb) +! + integer, intent(in) :: num_pe + integer(kind = kint), intent(in) :: num_pvr, ist_pvr, ied_pvr +! + integer(kind = kint), intent(in) :: num_pvr_images + integer(kind = kint), intent(in) :: istack_pvr_images(0:num_pvr) +! + type(pvr_image_type), intent(inout) :: pvr_rgb(num_pvr_images) +! + integer(kind = kint), allocatable:: irank_image_tmp(:) + integer(kind = kint), allocatable:: irank_end_tmp(:) + integer(kind = kint), allocatable:: maxpe_composit_tmp(:) +! + integer(kind = kint) :: ist_img, num_img +! +! + ist_img = istack_pvr_images(ist_pvr-1) + num_img = istack_pvr_images(ied_pvr ) - ist_img + if(num_img .le. 0) return +! + allocate(maxpe_composit_tmp(num_img)) + allocate(irank_image_tmp(num_img)) + allocate(irank_end_tmp(num_img)) +! +! + call set_rank_to_write_tmp(num_pe, num_img, & + & maxpe_composit_tmp, irank_image_tmp, irank_end_tmp) + call set_rank_to_write_images & + & (num_img, irank_image_tmp, irank_end_tmp, pvr_rgb(ist_img+1)) +! + deallocate(irank_image_tmp, irank_end_tmp, maxpe_composit_tmp) +! + end subroutine each_composition_pe_range +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_rank_to_write_tmp(num_pe, num_img, & + & maxpe_composit_tmp, irank_image_tmp, irank_end_tmp) +! + integer, intent(in) :: num_pe + integer(kind = kint), intent(in) :: num_img +! + integer(kind = kint), intent(inout) & + & :: maxpe_composit_tmp(num_img) + integer(kind = kint), intent(inout) & + & :: irank_image_tmp(num_img) + integer(kind = kint), intent(inout) & + & :: irank_end_tmp(num_img) +! + integer(kind = kint) :: i_img, num + real(kind = kreal) :: address +! +! +!$omp parallel workshare + maxpe_composit_tmp(1:num_img) = num_pe +!$omp end parallel workshare +! +!$omp parallel do private(i_img,address) + do i_img = 1, num_img + address = dble((i_img-1) * num_pe) / dble(num_img) + irank_image_tmp(i_img) = int(aint(address)) + end do +!$omp end parallel do +! + do i_img = 1, num_img - 1 + num = irank_image_tmp(i_img+1) - irank_image_tmp(i_img) + if(num .le. 0) then + irank_end_tmp(i_img) = irank_image_tmp(i_img) + else if(num .gt. maxpe_composit_tmp(i_img)) then + irank_end_tmp(i_img) & + & = irank_image_tmp(i_img) + maxpe_composit_tmp(i_img) - 1 + else + irank_end_tmp(i_img) = irank_image_tmp(i_img+1) - 1 + end if + end do +! + num = num_pe - irank_image_tmp(num_img) + if(num .gt. maxpe_composit_tmp(num_img)) then + irank_end_tmp(num_img) = irank_image_tmp(num_img) & + & + maxpe_composit_tmp(num_img) - 1 + else + irank_end_tmp(num_img) = num_pe - 1 + end if +! + end subroutine set_rank_to_write_tmp +! +! --------------------------------------------------------------------- +! + subroutine set_rank_to_write_images & + & (num_img, irank_image_tmp, irank_end_tmp, pvr_rgb) +! + integer(kind = kint), intent(in) :: num_img + integer(kind = kint), intent(in) :: irank_image_tmp(num_img) + integer(kind = kint), intent(in) :: irank_end_tmp(num_img) +! + type(pvr_image_type), intent(inout) :: pvr_rgb(num_img) +! + integer(kind = kint) :: i_img +! +! +!$omp parallel do private(i_img) + do i_img = 1, num_img + pvr_rgb(i_img)%irank_image_file = irank_image_tmp(i_img) + pvr_rgb(i_img)%irank_end_composit = irank_end_tmp(i_img) +! + pvr_rgb(i_img)%npe_img_composit & + & = pvr_rgb(i_img)%irank_end_composit & + & - pvr_rgb(i_img)%irank_image_file + 1 + end do +!$omp end parallel do +! + end subroutine set_rank_to_write_images +! +! --------------------------------------------------------------------- +! + subroutine anaglyph_maxpe_composit_tmp(num_pe, num_pvr, & + & maxpe_composit_tmp) +! + integer, intent(in) :: num_pe + integer(kind = kint), intent(in) :: num_pvr +! + integer(kind = kint), intent(inout) & + & :: maxpe_composit_tmp(2*num_pvr) +! + integer(kind = kint) :: i_pvr +! +! + do i_pvr = 1, num_pvr + maxpe_composit_tmp(2+i_pvr-1) = 2*num_pe + maxpe_composit_tmp(2+i_pvr ) = 2*num_pe + end do +! + end subroutine anaglyph_maxpe_composit_tmp +! +! --------------------------------------------------------------------- +! + end module set_composition_pe_range diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_control_each_pvr.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_control_each_pvr.f90 new file mode 100644 index 00000000..72b294d5 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_control_each_pvr.f90 @@ -0,0 +1,317 @@ +!>@file set_control_each_pvr.f90 +!!@brief module set_control_each_pvr +!! +!!@date Programmed by H.Matsui in May. 2006 +! +!>@brief Set each PVR parameters from control +!! +!!@verbatim +!! subroutine check_pvr_field_control & +!! & (pvr_ctl, num_nod_phys, phys_nod_name) +!! +!! subroutine set_control_field_4_pvr(field_ctl, comp_ctl, & +!! & num_nod_phys, phys_nod_name, fld_param, icheck_ncomp) +!! subroutine set_control_pvr & +!! & (pvr_ctl, ele_grp, surf_grp, tracer, fline, & +!! & pvr_area, draw_param, color_param, cbar_param) +!! type(group_data), intent(in) :: ele_grp +!! type(surface_group_data), intent(in) :: surf_grp +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(pvr_parameter_ctl), intent(in) :: pvr_ctl +!! type(pvr_field_parameter), intent(inout) :: fld_param +!! type(pvr_view_parameter), intent(inout) :: view_param +!! type(rendering_parameter), intent(inout) :: draw_param +!! type(viz_area_parameter), intent(inout) :: pvr_area +!! type(pvr_colormap_parameter), intent(inout) :: color_param +!! type(pvr_colorbar_parameter), intent(inout) :: cbar_param +!!@endverbatim +! + module set_control_each_pvr +! + use m_precision +! + use m_constants + use m_error_IDs + use t_control_data_4_pvr + use calypso_mpi +! + use set_field_comp_for_viz + use output_image_sel_4_png +! + implicit none +! + private :: set_control_pvr_render_area, set_control_pvr_isosurf +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine check_pvr_field_control & + & (pvr_ctl, num_nod_phys, phys_nod_name) +! + use t_control_params_4_pvr + use skip_comment_f +! + integer(kind = kint), intent(in) :: num_nod_phys + character(len=kchara), intent(in) :: phys_nod_name(num_nod_phys) +! + type(pvr_parameter_ctl), intent(in) :: pvr_ctl +! + integer(kind = kint) :: num_field, num_phys_viz + character(len = kchara) :: tmpfield(1) +! +! + tmpfield(1) = pvr_ctl%pvr_field_ctl%charavalue + call check_field_4_viz(num_nod_phys, phys_nod_name, & + & ione, tmpfield, num_field, num_phys_viz) + if(num_field .eq. 0) then + call calypso_MPI_abort(ierr_PVR,'set correct field name') + end if +! + end subroutine check_pvr_field_control +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_control_field_4_pvr(field_ctl, comp_ctl, & + & num_nod_phys, phys_nod_name, fld_param, icheck_ncomp) +! + use t_control_array_character + use t_control_params_4_pvr +! + integer(kind = kint), intent(in) :: num_nod_phys + character(len=kchara), intent(in) :: phys_nod_name(num_nod_phys) + type(read_character_item), intent(in) :: field_ctl + type(read_character_item), intent(in) :: comp_ctl +! + type(pvr_field_parameter), intent(inout) :: fld_param + integer(kind = kint), intent(inout) :: icheck_ncomp(1) +! + integer(kind = kint) :: ifld_tmp(1), icomp_tmp(1), ncomp_tmp(1) + character(len = kchara) :: fldname_tmp(1) + character(len = kchara) :: tmpfield(1), tmpcomp(1) +! +! + tmpfield(1) = field_ctl%charavalue + tmpcomp(1) = comp_ctl%charavalue + call set_components_4_viz & + & (num_nod_phys, phys_nod_name, ione, tmpfield, tmpcomp, ione, & + & ifld_tmp, icomp_tmp, icheck_ncomp, ncomp_tmp, fldname_tmp) + fld_param%id_field = ifld_tmp(1) + fld_param%id_component = icomp_tmp(1) + fld_param%num_original_comp = ncomp_tmp(1) + fld_param%field_name = fldname_tmp(1) +! + end subroutine set_control_field_4_pvr +! +! --------------------------------------------------------------------- +! + subroutine set_control_pvr & + & (pvr_ctl, ele_grp, surf_grp, tracer, fline, & + & pvr_area, draw_param, color_param, cbar_param) +! + use t_group_data + use t_particle_trace + use t_fieldline + use t_control_params_4_pvr + use t_pvr_colormap_parameter + use t_geometries_in_pvr_screen + use t_ctl_param_tracer_render + use set_color_4_pvr + use set_rgba_4_each_pixel + use set_coefs_of_sections + use set_control_pvr_color + use skip_comment_f +! + type(group_data), intent(in) :: ele_grp + type(surface_group_data), intent(in) :: surf_grp + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(pvr_parameter_ctl), intent(in) :: pvr_ctl +! + type(rendering_parameter), intent(inout) :: draw_param + type(viz_area_parameter), intent(inout) :: pvr_area + type(pvr_colormap_parameter), intent(inout) :: color_param + type(pvr_colorbar_parameter), intent(inout) :: cbar_param +! +! + call set_control_pvr_render_area(pvr_ctl%render_area_c, & + & ele_grp, surf_grp, pvr_area, draw_param) +! + call set_control_pvr_sections(pvr_ctl%pvr_scts_c, draw_param) +! + call set_control_pvr_isosurf(pvr_ctl%pvr_isos_c, draw_param) +! + call set_control_pvr_tracer(tracer%num_trace, tracer%fln_prm, & + & pvr_ctl%pvr_tracers_c%num_pvr_tracer_ctl, & + & pvr_ctl%pvr_tracers_c%pvr_trc_c, draw_param%tracer_pvr_prm) + call set_control_pvr_tracer(fline%num_fline, fline%fln_prm, & + & pvr_ctl%pvr_flines_c%num_pvr_tracer_ctl, & + & pvr_ctl%pvr_flines_c%pvr_trc_c, draw_param%fline_pvr_prm) +! +! set colormap setting + call set_control_pvr_lighting(pvr_ctl%light, color_param) + call set_control_pvr_colormap & + & (pvr_ctl%cmap_cbar_c%color, color_param) + call set_control_pvr_colorbar & + & (pvr_ctl%cmap_cbar_c%cbar_ctl, cbar_param) +! + end subroutine set_control_pvr +! +! --------------------------------------------------------------------- +! + subroutine set_control_pvr_render_area & + & (render_area_c, ele_grp, surf_grp, pvr_area, draw_param) +! + use t_group_data + use t_ctl_data_pvr_area + use t_control_params_4_pvr + use t_geometries_in_pvr_screen + use skip_comment_f + use pvr_surface_enhancement + use set_area_4_viz +! + type(group_data), intent(in) :: ele_grp + type(surface_group_data), intent(in) :: surf_grp + type(pvr_render_area_ctl), intent(in) :: render_area_c +! + type(rendering_parameter), intent(inout) :: draw_param + type(viz_area_parameter), intent(inout) :: pvr_area +! +! + call count_area_4_viz(ele_grp%num_grp, ele_grp%grp_name, & + & render_area_c%pvr_area_ctl%num, & + & render_area_c%pvr_area_ctl%c_tbl, & + & pvr_area%nele_grp_area_pvr) +! + if (pvr_area%nele_grp_area_pvr .le. 0) then + call calypso_MPI_abort(ierr_PVR, 'set correct element group') + else + call alloc_pvr_element_group(pvr_area) + end if +! +! + call s_set_area_4_viz(ele_grp%num_grp, ele_grp%grp_name, & + & render_area_c%pvr_area_ctl%num, & + & render_area_c%pvr_area_ctl%c_tbl, & + & pvr_area%nele_grp_area_pvr, pvr_area%id_ele_grp_area_pvr) +! +! + if (render_area_c%surf_enhanse_ctl%num .gt. 0) then + call set_pvr_bc_enhanse_flag(surf_grp, & + & render_area_c%surf_enhanse_ctl%num, & + & render_area_c%surf_enhanse_ctl%c1_tbl, & + & render_area_c%surf_enhanse_ctl%c2_tbl, & + & render_area_c%surf_enhanse_ctl%vect, & + & draw_param%iflag_enhanse, draw_param%enhansed_opacity) + else + draw_param%iflag_enhanse = IFLAG_NONE + end if +! + end subroutine set_control_pvr_render_area +! +! --------------------------------------------------------------------- +! + subroutine set_control_pvr_sections(pvr_scts_c, draw_param) +! + use t_control_data_pvr_sections + use t_geometries_in_pvr_screen + use set_coefs_of_sections + use set_control_pvr_color + use skip_comment_f +! + type(pvr_sections_ctl), intent(in) :: pvr_scts_c +! + type(rendering_parameter), intent(inout) :: draw_param +! + integer(kind = kint) :: id_section_method, ierr, i + character(len=kchara) :: tmpchara +! +! + draw_param%num_sections = pvr_scts_c%num_pvr_sect_ctl + if(draw_param%num_sections .gt. 0) then + call alloc_pvr_sections(draw_param) +! + do i = 1, draw_param%num_sections + call s_set_coefs_of_sections & + & (pvr_scts_c%pvr_sect_ctl(i)%psf_def_c, & + & id_section_method, draw_param%coefs(1:10,i), ierr) + if(ierr .gt. 0) call calypso_mpi_abort & + & (ierr, 'Set section parameters for pvr') +! + if(pvr_scts_c%pvr_sect_ctl(i)%opacity_ctl%iflag .gt. 0) then + draw_param%sect_opacity(i) & + & = pvr_scts_c%pvr_sect_ctl(i)%opacity_ctl%realvalue + end if +! + draw_param%iflag_psf_zeoline(i) = 0 + if(pvr_scts_c%pvr_sect_ctl(i)%zeroline_switch_ctl%iflag & + & .gt. 0) then + tmpchara & + & = pvr_scts_c%pvr_sect_ctl(i)%zeroline_switch_ctl%charavalue + if(yes_flag(tmpchara)) draw_param%iflag_psf_zeoline(i) = 1 + end if + end do + end if +! + end subroutine set_control_pvr_sections +! +! --------------------------------------------------------------------- +! + subroutine set_control_pvr_isosurf(pvr_isos_c, draw_param) +! + use t_control_data_pvr_isosurfs + use t_geometries_in_pvr_screen + use m_pvr_control_labels + use pvr_surface_enhancement +! + type(pvr_isosurfs_ctl), intent(in) :: pvr_isos_c +! + type(rendering_parameter), intent(inout) :: draw_param +! + integer(kind = kint) :: i + character(len = kchara) :: tmpchara +! + integer(kind = kint) :: iflag +! +! + draw_param%num_isosurf = pvr_isos_c%num_pvr_iso_ctl + if(draw_param%num_isosurf .le. 0) return +! + call alloc_pvr_isosurfaces(draw_param) +! + do i = 1, draw_param%num_isosurf + iflag = pvr_isos_c%pvr_iso_ctl(i)%iso_value_ctl%iflag + if(iflag .gt. 0) then + draw_param%iso_value(i) & + & = pvr_isos_c%pvr_iso_ctl(i)%iso_value_ctl%realvalue + end if +! + iflag = pvr_isos_c%pvr_iso_ctl(i)%opacity_ctl%iflag + if(iflag .gt. 0) then + draw_param%iso_opacity(i) & + & = pvr_isos_c%pvr_iso_ctl(i)%opacity_ctl%realvalue + end if +! + iflag = pvr_isos_c%pvr_iso_ctl(i)%isosurf_type_ctl%iflag + if(iflag .gt. 0) then + tmpchara & + & = pvr_isos_c%pvr_iso_ctl(i)%isosurf_type_ctl%charavalue + if(cmp_no_case(tmpchara, LABEL_DECREASE)) then + draw_param%itype_isosurf(i) = IFLAG_SHOW_REVERSE + else if(cmp_no_case(tmpchara, LABEL_DECREASE)) then + draw_param%itype_isosurf(i) = IFLAG_SHOW_FORWARD + else + draw_param%itype_isosurf(i) = IFLAG_SHOW_FORWARD + end if + end if + end do +! + end subroutine set_control_pvr_isosurf +! +! --------------------------------------------------------------------- +! + end module set_control_each_pvr diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_control_pvr_color.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_control_pvr_color.f90 new file mode 100644 index 00000000..82606e4d --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_control_pvr_color.f90 @@ -0,0 +1,359 @@ +!>@file set_control_pvr_color.f90 +!!@brief module set_control_pvr_color +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!> @brief Load control parameters from input data +!! +!!@verbatim +!! subroutine set_control_pvr_lighting(light, color_param) +!! subroutine set_control_pvr_colormap(color, color_param) +!! subroutine set_control_pvr_colorbar(cbar_ctl, cbar_param) +!! type(pvr_light_ctl), intent(in) :: light +!! type(pvr_colormap_ctl), intent(in) :: color +!! type(pvr_colormap_parameter), intent(inout) :: color_param +!! type(pvr_colorbar_ctl), intent(in) :: cbar_ctl +!!@endverbatim +! + module set_control_pvr_color +! + use m_precision +! + use m_constants + use m_error_IDs + use calypso_mpi +! + use t_pvr_colormap_parameter + use skip_comment_f +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_control_pvr_lighting(light, color_param) +! + use t_ctl_data_pvr_light + use set_color_4_pvr + use set_rgba_4_each_pixel +! + type(pvr_light_ctl), intent(in) :: light +! + type(pvr_colormap_parameter), intent(inout) :: color_param +! + integer(kind = kint) :: i, icou + real(kind = kreal) :: r, t, p +! +! + if(light%ambient_coef_ctl%iflag .gt. 0) then + color_param%pvr_lighting_real(1) & + & = light%ambient_coef_ctl%realvalue + else + color_param%pvr_lighting_real(1) = 0.5 + end if +! + if(light%diffuse_coef_ctl%iflag .gt. 0) then + color_param%pvr_lighting_real(2) & + & = light%diffuse_coef_ctl%realvalue + else + color_param%pvr_lighting_real(2) = 0.7 + end if +! + if(light%specular_coef_ctl%iflag .gt. 0) then + color_param%pvr_lighting_real(3) & + & = light%specular_coef_ctl%realvalue + else + color_param%pvr_lighting_real(3) = 0.8 + end if +! +! + color_param%num_pvr_lights = 0 + if(light%light_position_ctl%num .gt. 0) then + color_param%num_pvr_lights = color_param%num_pvr_lights & + & + light%light_position_ctl%num + end if +! + if(light%light_sph_posi_ctl%num .gt. 0) then + color_param%num_pvr_lights = color_param%num_pvr_lights & + & + light%light_sph_posi_ctl%num + end if + if(color_param%num_pvr_lights .eq. 0) & + & color_param%num_pvr_lights = 1 +! + call alloc_light_posi_in_view(color_param) +! + i = 0 + if(light%light_position_ctl%num .gt. 0) then + do icou = 1, light%light_position_ctl%num + i = i + 1 + color_param%xyz_pvr_lights(1,i) & + & = light%light_position_ctl%vec1(icou) + color_param%xyz_pvr_lights(2,i) & + & = light%light_position_ctl%vec2(icou) + color_param%xyz_pvr_lights(3,i) & + & = light%light_position_ctl%vec3(icou) + end do + end if + if(light%light_sph_posi_ctl%num .gt. 0) then + do icou = 1, light%light_sph_posi_ctl%num + i = i + 1 + r = light%light_sph_posi_ctl%vec1(icou) + t = light%light_sph_posi_ctl%vec2(icou) * atan(one) / 45.0 + p = light%light_sph_posi_ctl%vec3(icou) * atan(one) / 45.0 + color_param%xyz_pvr_lights(1,i) = r * sin(t) * cos(p) + color_param%xyz_pvr_lights(2,i) = r * sin(t) * sin(p) + color_param%xyz_pvr_lights(3,i) = r * cos(t) + end do + end if + + if(i .gt. 0) then + color_param%iflag_pvr_lights = 1 + else + color_param%xyz_pvr_lights(1,1) = one + color_param%xyz_pvr_lights(2,1) = one + color_param%xyz_pvr_lights(3,1) = one + end if +! + end subroutine set_control_pvr_lighting +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_control_pvr_colormap(color, color_param) +! + use t_ctl_data_pvr_colormap + use set_color_4_pvr + use set_rgba_4_each_pixel +! + type(pvr_colormap_ctl), intent(in) :: color +! + type(pvr_colormap_parameter), intent(inout) :: color_param +! + integer(kind = kint) :: i, ist + character(len = kchara) :: tmpchara +! +! +! set colormap setting +! + color_param%id_pvr_color(1) = iflag_rainbow + if( color%colormap_mode_ctl%iflag .gt. 0) then + tmpchara = color%colormap_mode_ctl%charavalue + if (cmp_no_case(tmpchara, hd_rainbow)) then + color_param%id_pvr_color(1) = iflag_rainbow + else if(cmp_no_case(tmpchara, hd_radblue)) then + color_param%id_pvr_color(1) = iflag_redblue + else if(cmp_no_case(tmpchara, hd_grayscale)) then + color_param%id_pvr_color(1) = iflag_grayscale + else if(cmp_no_case(tmpchara, hd_sym_gray)) then + color_param%id_pvr_color(1) = iflag_sym_gray + else if(cmp_no_case(tmpchara, hd_orangecyan)) then + color_param%id_pvr_color(1) = iflag_orangecyan + else if(cmp_no_case(tmpchara, hd_moltenmetal)) then + color_param%id_pvr_color(1) = iflag_moltenmetal + else if(cmp_no_case(tmpchara, hd_spacecolor)) then + color_param%id_pvr_color(1) = iflag_spacecolor + end if + end if +! + color_param%bg_rgba_real(1:4) = 0.0d0 + if(color%background_color_ctl%iflag .gt. 0) then + color_param%bg_rgba_real(1:3) & + & = color%background_color_ctl%realvalue(1:3) + color_param%bg_rgba_real(4) = 1.0d0 + end if +! +! + color_param%id_pvr_color(2) = iflag_automatic + color_param%num_pvr_datamap_pnt = 2 + if( color%data_mapping_ctl%iflag .gt. 0) then + tmpchara = color%data_mapping_ctl%charavalue + if (cmp_no_case(tmpchara, hd_nonlinear) & + & .or. cmp_no_case(tmpchara, hd_colorlist)) then + if(color%colortbl_ctl%num .gt. 0) then + color_param%id_pvr_color(2) = iflag_colorlist + color_param%num_pvr_datamap_pnt = color%colortbl_ctl%num + end if + else if (cmp_no_case(tmpchara, hd_linear) & + & .or. cmp_no_case(tmpchara, hd_minmax)) then + if( color%range_min_ctl%iflag .gt. 0 & + & .and. color%range_max_ctl%iflag .gt. 0) then + color_param%id_pvr_color(2) = iflag_minmax + end if + end if + end if +! +! + call alloc_pvr_color_parameteres(color_param) +! + if (color_param%id_pvr_color(2) .eq. iflag_minmax) then + color_param%pvr_datamap_param(1,1) & + & = color%range_min_ctl%realvalue + color_param%pvr_datamap_param(1,2) & + & = color%range_max_ctl%realvalue + color_param%pvr_datamap_param(2,1) = zero + color_param%pvr_datamap_param(2,2) = one +! + else if(color_param%id_pvr_color(2) .eq. iflag_colorlist) then + do i = 1, color_param%num_pvr_datamap_pnt + color_param%pvr_datamap_param(1,i) & + & = color%colortbl_ctl%vec1(i) + color_param%pvr_datamap_param(2,i) & + & = color%colortbl_ctl%vec2(i) + end do +! + else + color_param%pvr_datamap_param(1,1) = zero + color_param%pvr_datamap_param(1,2) = zero + color_param%pvr_datamap_param(2,1) = zero + color_param%pvr_datamap_param(2,2) = one + end if +! +! +! + color_param%id_pvr_color(3) = iflag_anbient + color_param%num_opacity_pnt = 0 + if( color%opacity_style_ctl%iflag .gt. 0) then + tmpchara = color%opacity_style_ctl%charavalue +! if (cmp_no_case(tmpchara, hd_intensity) then +! color_param%id_pvr_color(3) = iflag_intense +! end if + if(cmp_no_case(tmpchara, hd_pointlinear)) then + if( color%linear_opacity_ctl%num .gt. 0) then + color_param%id_pvr_color(3) = iflag_pointlinear + color_param%num_opacity_pnt = color%linear_opacity_ctl%num + end if + end if + end if +! + call alloc_pvr_opacity_list(color_param) +! + if(color_param%id_pvr_color(3) .eq. iflag_pointlinear) then + do i = 1, color_param%num_opacity_pnt + color_param%pvr_opacity_param(1,i) & + & = color%linear_opacity_ctl%vec1(i) + color_param%pvr_opacity_param(2,i) & + & = color%linear_opacity_ctl%vec1(i) + color_param%pvr_opacity_param(3,i) & + & = color%linear_opacity_ctl%vec2(i) + color_param%pvr_max_opacity & + & = max(color_param%pvr_max_opacity, & + & color_param%pvr_opacity_param(3,i)) + end do + end if +! + ist = color_param%num_opacity_pnt + 1 + color_param%pvr_opacity_param(1,ist) = zero + color_param%pvr_opacity_param(2,ist) = one + if( color%fix_opacity_ctl%iflag .gt. 0) then + color_param%pvr_opacity_param(3,ist) & + & = color%fix_opacity_ctl%realvalue + else + color_param%pvr_opacity_param(3,ist) = 0.001 + end if + color_param%pvr_max_opacity & + & = max(color_param%pvr_max_opacity, & + & color_param%pvr_opacity_param(3,ist)) +! + end subroutine set_control_pvr_colormap +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_control_pvr_colorbar(cbar_ctl, cbar_param) +! + use t_ctl_data_pvr_colorbar + use t_pvr_colormap_parameter +! + type(pvr_colorbar_ctl), intent(in) :: cbar_ctl + type(pvr_colorbar_parameter), intent(inout) :: cbar_param +! + character(len = kchara) :: tmpchara +! +! set axis label setting + cbar_param%flag_pvr_axis = .FALSE. + if( cbar_ctl%axis_switch_ctl%iflag .gt. 0) then + tmpchara = cbar_ctl%axis_switch_ctl%charavalue + cbar_param%flag_pvr_axis = cmp_no_case(tmpchara, 'on') + end if +! +! set time label setting + cbar_param%flag_draw_time = .FALSE. + if( cbar_ctl%time_switch_ctl%iflag .gt. 0) then + tmpchara = cbar_ctl%time_switch_ctl%charavalue + cbar_param%flag_draw_time = cmp_no_case(tmpchara, 'on') + end if +! +! set mapgrid setting + cbar_param%flag_draw_mapgrid = .FALSE. + if( cbar_ctl%mapgrid_switch_ctl%iflag .gt. 0) then + tmpchara = cbar_ctl%mapgrid_switch_ctl%charavalue + cbar_param%flag_draw_mapgrid = cmp_no_case(tmpchara, 'on') + end if +! +! set colorbar setting +! + cbar_param%flag_pvr_colorbar = .FALSE. + if( cbar_ctl%colorbar_switch_ctl%iflag .gt. 0) then + tmpchara = cbar_ctl%colorbar_switch_ctl%charavalue + cbar_param%flag_pvr_colorbar & + & = cmp_no_case(tmpchara, 'on') & + & .or. cmp_no_case(tmpchara, 'data') & + & .or. cmp_no_case(tmpchara, 'equi_data') + end if +! + if(cbar_param%flag_pvr_colorbar) then + cbar_param%flag_pvr_cbar_bottom = .FALSE. + if( cbar_ctl%colorbar_position_ctl%iflag .gt. 0) then + tmpchara = cbar_ctl%colorbar_position_ctl%charavalue + if (cmp_no_case(tmpchara, 'bottom')) then + cbar_param%flag_pvr_cbar_bottom = .TRUE. + end if + end if + + if( cbar_ctl%colorbar_scale_ctl%iflag .gt. 0) then + tmpchara = cbar_ctl%colorbar_scale_ctl%charavalue + if (cmp_no_case(tmpchara, 'on')) then + cbar_param%iflag_pvr_cbar_nums = 1 +! + if (cbar_ctl%font_size_ctl%iflag .gt. 0) then + cbar_param%iscale_font = cbar_ctl%font_size_ctl%intvalue + else + cbar_param%iscale_font = 1 + end if +! + if (cbar_ctl%ngrid_cbar_ctl%iflag .gt. 0) then + cbar_param%ntick_pvr_colorbar & + & = cbar_ctl%ngrid_cbar_ctl%intvalue + 2 + else + cbar_param%ntick_pvr_colorbar = 3 + end if +! + if (cbar_ctl%zeromarker_flag_ctl%iflag .gt. 0) then + tmpchara = cbar_ctl%zeromarker_flag_ctl%charavalue + if (cmp_no_case(tmpchara, 'on')) then + cbar_param%iflag_pvr_zero_mark = 1 + else + cbar_param%iflag_pvr_zero_mark = 0 + end if + else + cbar_param%iflag_pvr_zero_mark = 0 + end if +! + end if + end if +! + if( cbar_ctl%cbar_range_ctl%iflag .gt. 0) then + cbar_param%cbar_range(1:2) & + & = cbar_ctl%cbar_range_ctl%realvalue(1:2) + end if + end if +! + end subroutine set_control_pvr_colorbar +! +! --------------------------------------------------------------------- +! + end module set_control_pvr_color diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_control_pvr_movie.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_control_pvr_movie.f90 new file mode 100644 index 00000000..33e7ccab --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_control_pvr_movie.f90 @@ -0,0 +1,120 @@ +!>@file set_control_pvr_movie.f90 +!!@brief module set_control_pvr_movie +!! +!!@date Programmed by H.Matsui in May. 2006 +! +!>@brief Set each PVR parameters from control +!! +!!@verbatim +!! subroutine s_set_control_pvr_movie(movie_ctl, movie_def) +!! type(pvr_movie_ctl), intent(in) :: movie_ctl +!! type(pvr_movie_parameter), intent(inout) :: movie_def +!!@endverbatim +! + module set_control_pvr_movie +! + use m_precision +! + use m_constants + use m_error_IDs + use calypso_mpi +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_set_control_pvr_movie(movie_ctl, movie_def) +! + use t_ctl_data_pvr_movie + use t_control_params_4_pvr + use t_geometries_in_pvr_screen + use m_pvr_control_labels + use output_image_sel_4_png + use skip_comment_f +! + type(pvr_movie_ctl), intent(in) :: movie_ctl + type(pvr_movie_parameter), intent(inout) :: movie_def +! + character(len = kchara) :: tmpchara +! +! + movie_def%iflag_movie_mode = IFLAG_NO_MOVIE + if(movie_ctl%movie_mode_ctl%iflag .gt. 0) then + tmpchara = movie_ctl%movie_mode_ctl%charavalue + if(cmp_no_case(tmpchara, FLAG_ROTATE_MOVIE)) then + movie_def%iflag_movie_mode = I_ROTATE_MOVIE + else if(cmp_no_case(tmpchara, FLAG_ZOOM)) then + movie_def%iflag_movie_mode = I_ZOOM + else if(cmp_no_case(tmpchara, FLAG_START_END_VIEW)) then + movie_def%iflag_movie_mode = I_START_END_VIEW + else if(cmp_no_case(tmpchara, FLAG_LIC_KERNEL)) then + movie_def%iflag_movie_mode = I_LIC_KERNEL + else + movie_def%iflag_movie_mode = I_ROTATE_MOVIE + end if + end if +! + if(movie_ctl%num_frames_ctl%iflag .eq. 0) then + movie_def%iflag_movie_mode = IFLAG_NO_MOVIE + else + movie_def%num_frame = movie_ctl%num_frames_ctl%intvalue + end if +! + if(movie_def%iflag_movie_mode .eq. I_ROTATE_MOVIE) then +! + if(movie_ctl%rotation_axis_ctl%iflag .eq. 0) then + movie_def%iflag_movie_mode = IFLAG_NO_MOVIE + else + tmpchara = movie_ctl%rotation_axis_ctl%charavalue + if (cmp_no_case(tmpchara, 'x')) then + movie_def%id_rot_axis = 1 + else if(cmp_no_case(tmpchara, 'y')) then + movie_def%id_rot_axis = 2 + else if(cmp_no_case(tmpchara, 'z')) then + movie_def%id_rot_axis = 3 + end if + end if + if(movie_ctl%angle_range_ctl%iflag .eq. 0) then + movie_def%angle_range(1) = 0.0d0 + movie_def%angle_range(2) = 360.0d0 + else + movie_def%angle_range(1:2) & + & = movie_ctl%angle_range_ctl%realvalue(1:2) + end if + else if(movie_def%iflag_movie_mode .eq. I_ZOOM) then + if(movie_ctl%apature_range_ctl%iflag .eq. 0) then + movie_def%iflag_movie_mode = IFLAG_NO_MOVIE + else + movie_def%apature_range(1:2) & + & = movie_ctl%apature_range_ctl%realvalue(1:2) + end if +! + else if(movie_def%iflag_movie_mode .eq. I_LIC_KERNEL) then + if(movie_ctl%LIC_kernel_peak_range_ctl%iflag .eq. 0) then + movie_def%iflag_movie_mode = IFLAG_NO_MOVIE + movie_def%peak_range(1) = -0.5d0 + movie_def%peak_range(2) = 0.5d0 + else + movie_def%peak_range(1:2) & + & = movie_ctl%LIC_kernel_peak_range_ctl%realvalue(1:2) + end if +! + else if(movie_def%iflag_movie_mode .eq. I_START_END_VIEW) then + if(movie_ctl%view_start_ctl%i_view_transform .eq. 0) then + movie_def%iflag_movie_mode = IFLAG_NO_MOVIE + end if + if(movie_ctl%view_end_ctl%i_view_transform .eq. 0) then + movie_def%iflag_movie_mode = IFLAG_NO_MOVIE + end if + end if +! +! + end subroutine s_set_control_pvr_movie +! +! --------------------------------------------------------------------- +! + end module set_control_pvr_movie diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_default_pvr_params.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_default_pvr_params.f90 new file mode 100644 index 00000000..532ea1c5 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_default_pvr_params.f90 @@ -0,0 +1,159 @@ +!set_default_pvr_params.f90 +! module set_default_pvr_params +! +! programmed by H.Matsui on May. 2009 +! +!! subroutine check_pvr_parameters & +!! & (outline, num_views, multi_view, color_param) +!! subroutine set_default_pvr_data_params(outline, color_param) +!! integer(kind = kint), intent(in) :: num_views +!! type(pvr_domain_outline), intent(in) :: outline +!! type(pvr_view_parameter), intent(inout) & +!! & :: multi_view(num_views) +!! type(pvr_colormap_parameter), intent(inout) :: color_param +! + module set_default_pvr_params +! + use m_precision +! + use m_constants + use t_control_params_4_pvr + use t_pvr_colormap_parameter +! + implicit none +! + private :: set_default_viewpoint_pvr + private :: set_default_lookatpoint_pvr + private :: set_default_up_dir_pvr, set_default_light_pvr +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine check_pvr_parameters & + & (outline, num_views, multi_view, color_param) +! + use t_surf_grp_4_pvr_domain + use t_geometries_in_pvr_screen +! + integer(kind = kint), intent(in) :: num_views + type(pvr_domain_outline), intent(in) :: outline + type(pvr_view_parameter), intent(inout) :: multi_view(num_views) + type(pvr_colormap_parameter), intent(inout) :: color_param +! + integer(kind = kint) :: i +! +! + do i = 1, num_views + if(multi_view(i)%iflag_viewpoint .eq. 0) then + call set_default_viewpoint_pvr(outline%center_g, & + & outline%xx_minmax_g, multi_view(i)%viewpoint) + end if +! + if(multi_view(i)%iflag_lookpoint .eq. 0) then + call set_default_lookatpoint_pvr & + & (outline%center_g, multi_view(i)%lookat_vec) + end if +! + if(multi_view(i)%iflag_updir .eq. 0) then + call set_default_up_dir_pvr(multi_view(i)%up_direction_vec) + end if + end do +! + if(color_param%iflag_pvr_lights .eq. 0) then + call set_default_light_pvr & + & (outline%center_g, outline%xx_minmax_g, color_param) + end if +! + end subroutine check_pvr_parameters +! +! ----------------------------------------------------------------------- +! + subroutine set_default_viewpoint_pvr & + & (center_g, xx_minmax_g, viewpoint_vec) +! + real(kind = kreal), intent(in) :: center_g(3) + real(kind = kreal), intent(in) :: xx_minmax_g(2,3) + real(kind = kreal), intent(inout) :: viewpoint_vec(3) +! +! + viewpoint_vec(1) = center_g(1) + viewpoint_vec(2) = xx_minmax_g(2,2) + 1.5d0 * ( xx_minmax_g(2,2) & + & - xx_minmax_g(1,2)) + viewpoint_vec(3) = xx_minmax_g(2,3) + 1.5d0 * ( xx_minmax_g(2,3) & + & - xx_minmax_g(1,3)) +! + end subroutine set_default_viewpoint_pvr +! +! ----------------------------------------------------------------------- +! + subroutine set_default_lookatpoint_pvr(center_g, lookat_vec) +! + real(kind = kreal), intent(in) :: center_g(3) + real(kind = kreal), intent(inout) :: lookat_vec(3) +! +! + lookat_vec(1:3) = center_g(1:3) +! + end subroutine set_default_lookatpoint_pvr +! +! ----------------------------------------------------------------------- +! + subroutine set_default_up_dir_pvr(up_direction_vec) +! + real(kind = kreal), intent(inout) :: up_direction_vec(3) +! +! + up_direction_vec(1:3) = zero + up_direction_vec(2) = one +! + end subroutine set_default_up_dir_pvr +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine set_default_light_pvr & + & (center_g, xx_minmax_g, color_param) +! + real(kind = kreal), intent(in) :: xx_minmax_g(2,3) + real(kind = kreal), intent(in) :: center_g(3) + type(pvr_colormap_parameter), intent(inout) :: color_param +! +! + color_param%num_pvr_lights = 1 + color_param%xyz_pvr_lights(1,1) = center_g(1) + color_param%xyz_pvr_lights(2,1) = xx_minmax_g(2,2) & + & + 0.1d0 * ( xx_minmax_g(2,2) & + & - xx_minmax_g(1,2) ) + color_param%xyz_pvr_lights(3,1) = xx_minmax_g(2,3) & + & + 2.0d0 * ( xx_minmax_g(2,3) & + & - xx_minmax_g(1,3) ) +! + end subroutine set_default_light_pvr +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine set_default_pvr_data_params(outline, color_param) +! + use t_surf_grp_4_pvr_domain + use set_color_4_pvr +! + type(pvr_domain_outline), intent(in) :: outline + type(pvr_colormap_parameter), intent(inout) :: color_param +! +! + if(color_param%id_pvr_color(2) .eq. iflag_automatic) then + color_param%pvr_datamap_param(1,1) = outline%d_minmax_pvr(1) + color_param%pvr_datamap_param(1,2) = outline%d_minmax_pvr(2) + color_param%pvr_datamap_param(2,1) = zero + color_param%pvr_datamap_param(2,2) = one + end if +! + end subroutine set_default_pvr_data_params +! +! ----------------------------------------------------------------------- +! + end module set_default_pvr_params diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_position_pvr_screen.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_position_pvr_screen.f90 new file mode 100644 index 00000000..76e508c7 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_position_pvr_screen.f90 @@ -0,0 +1,469 @@ +!set_position_pvr_screen.f90 +!>@file set_position_pvr_screen.f90 +!! module set_position_pvr_screen +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!>@brief Convert position by modelview or projection matrix +!! +!!@verbatim +!! subroutine copy_node_position_pvr_domain(numnod, numele, & +!! & numsurf, nnod_4_surf, xx, ie_surf, isf_4_ele, & +!! & num_pvr_surf, item_pvr_surf_domain, xx_pvr_domain) +!! integer(kind = kint), intent(in) :: numnod +!! real(kind = kreal), intent(in) :: xx(numnod,3) +!! integer(kind = kint), intent(in) :: numele +!! integer(kind = kint), intent(in) :: numsurf, nnod_4_surf +!! integer(kind = kint), intent(in) & +!! & :: ie_surf(numsurf,nnod_4_surf) +!! integer(kind = kint), intent(in) & +!! & :: isf_4_ele(numele,nsurf_4_ele) +!! integer(kind = kint), intent(in) :: num_pvr_surf +!! integer(kind = kint), intent(in) & +!! & :: item_pvr_surf_domain(2,num_pvr_surf) +!! real(kind = kreal), intent(inout) & +!! & :: xx_pvr_domain(4*num_pvr_surf,4) +!! +!! subroutine overwte_to_modelview_each_ele & +!! & (model_mat, numnod, x4_each_model) +!! real(kind = kreal), intent(in) :: model_mat(4,4) +!! integer(kind = kint), intent(in) :: numnod +!! real(kind = kreal), intent(inout) :: x4_each_model(4,numnod) +!! subroutine project_once_each_element & +!! & (model_mat, project_mat, numnod, x4_projected) +!! subroutine project_once_each_ele_w_smp & +!! & (model_mat, project_mat, numnod, x4_projected) +!! real(kind = kreal), intent(in) :: model_mat(4,4) +!! real(kind = kreal), intent(in) :: project_mat(4,4) +!! integer(kind = kint), intent(in) :: numnod +!! real(kind = kreal), intent(inout) :: x4_projected(4,numnod) +!! +!! subroutine cal_position_pvr_modelview & +!! & (model_mat, numnod, xx, x_nod_model) +!! real(kind = kreal), intent(in) :: model_mat(4,4) +!! integer(kind = kint), intent(in) :: numnod +!! real(kind = kreal), intent(in) :: xx(numnod,3) +!! real(kind = kreal), intent(inout) :: x_nod_model(numnod,4) +!! subroutine chenge_direction_pvr_modelview & +!! & (model_mat, numnod, xx, x_nod_model) +!! real(kind = kreal), intent(in) :: model_mat(4,4) +!! integer(kind = kint), intent(in) :: numnod +!! real(kind = kreal), intent(in) :: xx(numnod,3) +!! real(kind = kreal), intent(inout) :: x_nod_model(numnod,4) +!! +!! subroutine overwte_position_pvr_screen(project_mat, numnod, & +!! & x_nod_screen) +!! real(kind = kreal), intent(in) :: project_mat(4,4) +!! integer(kind = kint), intent(in) :: numnod +!! real(kind = kreal), intent(inout) :: x_nod_screen(numnod,4) +!! subroutine overwte_pvr_domain_on_screen(model_mat, project_mat, & +!! & num_pvr_surf, xx_pvr_domain) +!! real(kind = kreal), intent(in) :: model_mat(4,4) +!! real(kind = kreal), intent(in) :: project_mat(4,4) +!! integer(kind = kint), intent(in) :: num_pvr_surf +!! real(kind = kreal), intent(inout) & +!! & :: xx_pvr_domain(4*num_pvr_surf,4) +!!@endverbatim +! + module set_position_pvr_screen +! + use m_precision +! + use m_constants + use m_machine_parameter +! + implicit none +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine copy_node_position_pvr_domain(numnod, numele, & + & numsurf, nnod_4_surf, xx, ie_surf, isf_4_ele, & + & num_pvr_surf, item_pvr_surf_domain, xx_pvr_domain) +! + use m_geometry_constants +! + integer(kind = kint), intent(in) :: numnod + real(kind = kreal), intent(in) :: xx(numnod,3) + integer(kind = kint), intent(in) :: numele + integer(kind = kint), intent(in) :: numsurf, nnod_4_surf + integer(kind = kint), intent(in) & + & :: ie_surf(numsurf,nnod_4_surf) + integer(kind = kint), intent(in) & + & :: isf_4_ele(numele,nsurf_4_ele) +! + integer(kind = kint), intent(in) :: num_pvr_surf + integer(kind = kint), intent(in) & + & :: item_pvr_surf_domain(2,num_pvr_surf) +! + real(kind = kreal), intent(inout) & + & :: xx_pvr_domain(4*num_pvr_surf,4) +! + integer(kind = kint) :: inum, iele, k1, isurf + integer(kind = kint) :: i1, i2, i3, i4 +! +! +!$omp parallel do private (inum,iele,k1,isurf,i1,i2,i3,i4) + do inum = 1, num_pvr_surf + iele = item_pvr_surf_domain(1,inum) + k1 = item_pvr_surf_domain(2,inum) + isurf = abs(isf_4_ele(iele,k1)) +! + i1 = ie_surf(isurf,1) + i2 = ie_surf(isurf,2) + i3 = ie_surf(isurf,3) + i4 = ie_surf(isurf,4) +! + xx_pvr_domain(4*inum-3,1:3) = xx(i1,1:3) + xx_pvr_domain(4*inum-2,1:3) = xx(i2,1:3) + xx_pvr_domain(4*inum-1,1:3) = xx(i3,1:3) + xx_pvr_domain(4*inum, 1:3) = xx(i4,1:3) + xx_pvr_domain(4*inum-3:4*inum,4) = one + end do +!$omp end parallel do +! + end subroutine copy_node_position_pvr_domain +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine overwte_to_modelview_each_ele & + & (model_mat, numnod, x4_each_model) +! + real(kind = kreal), intent(in) :: model_mat(4,4) +! + integer(kind = kint), intent(in) :: numnod + real(kind = kreal), intent(inout) :: x4_each_model(4,numnod) +! + integer(kind = kint) :: inod + real(kind = kreal) :: x4_tmp(4) +! +! + do inod = 1, numnod + x4_tmp(1) = model_mat(1,1) * x4_each_model(1,inod) & + & + model_mat(1,2) * x4_each_model(2,inod) & + & + model_mat(1,3) * x4_each_model(3,inod) & + & + model_mat(1,4) * x4_each_model(4,inod) + x4_tmp(2) = model_mat(2,1) * x4_each_model(1,inod) & + & + model_mat(2,2) * x4_each_model(2,inod) & + & + model_mat(2,3) * x4_each_model(3,inod) & + & + model_mat(2,4) * x4_each_model(4,inod) + x4_tmp(3) = model_mat(3,1) * x4_each_model(1,inod) & + & + model_mat(3,2) * x4_each_model(2,inod) & + & + model_mat(3,3) * x4_each_model(3,inod) & + & + model_mat(3,4) * x4_each_model(4,inod) + x4_tmp(4) = model_mat(4,1) * x4_each_model(1,inod) & + & + model_mat(4,2) * x4_each_model(2,inod) & + & + model_mat(4,3) * x4_each_model(3,inod) & + & + model_mat(4,4) * x4_each_model(4,inod) +! + x4_each_model(1:4,inod) = x4_tmp(1:4) + end do +! + end subroutine overwte_to_modelview_each_ele +! +! ----------------------------------------------------------------------- +! + subroutine project_once_each_element & + & (model_mat, project_mat, numnod, x4_projected) +! + real(kind = kreal), intent(in) :: model_mat(4,4) + real(kind = kreal), intent(in) :: project_mat(4,4) +! + integer(kind = kint), intent(in) :: numnod + real(kind = kreal), intent(inout) :: x4_projected(4,numnod) +! + integer(kind = kint) :: inod + real(kind = kreal) :: coef + real(kind = kreal) :: x4_tmp(4) +! +! + do inod = 1, numnod + x4_tmp(1) = model_mat(1,1) * x4_projected(1,inod) & + & + model_mat(1,2) * x4_projected(2,inod) & + & + model_mat(1,3) * x4_projected(3,inod) & + & + model_mat(1,4) * x4_projected(4,inod) + x4_tmp(2) = model_mat(2,1) * x4_projected(1,inod) & + & + model_mat(2,2) * x4_projected(2,inod) & + & + model_mat(2,3) * x4_projected(3,inod) & + & + model_mat(2,4) * x4_projected(4,inod) + x4_tmp(3) = model_mat(3,1) * x4_projected(1,inod) & + & + model_mat(3,2) * x4_projected(2,inod) & + & + model_mat(3,3) * x4_projected(3,inod) & + & + model_mat(3,4) * x4_projected(4,inod) + x4_tmp(4) = model_mat(4,1) * x4_projected(1,inod) & + & + model_mat(4,2) * x4_projected(2,inod) & + & + model_mat(4,3) * x4_projected(3,inod) & + & + model_mat(4,4) * x4_projected(4,inod) +! + x4_projected(1,inod) = project_mat(1,1)*x4_tmp(1) & + & + project_mat(1,2)*x4_tmp(2) & + & + project_mat(1,3)*x4_tmp(3) & + & + project_mat(1,4)*x4_tmp(4) + x4_projected(2,inod) = project_mat(2,1)*x4_tmp(1) & + & + project_mat(2,2)*x4_tmp(2) & + & + project_mat(2,3)*x4_tmp(3) & + & + project_mat(2,4)*x4_tmp(4) + x4_projected(3,inod) = project_mat(3,1)*x4_tmp(1) & + & + project_mat(3,2)*x4_tmp(2) & + & + project_mat(3,3)*x4_tmp(3) & + & + project_mat(3,4)*x4_tmp(4) + x4_projected(4,inod) = project_mat(4,1)*x4_tmp(1) & + & + project_mat(4,2)*x4_tmp(2) & + & + project_mat(4,3)*x4_tmp(3) & + & + project_mat(4,4)*x4_tmp(4) +! +! + coef = one / x4_projected(4,inod) + x4_projected(1,inod) = x4_projected(1,inod) * coef + x4_projected(2,inod) = x4_projected(2,inod) * coef + x4_projected(3,inod) = x4_projected(3,inod) * coef + x4_projected(4,inod) = one + end do +! + end subroutine project_once_each_element +! +! ----------------------------------------------------------------------- +! + subroutine project_once_each_ele_w_smp & + & (model_mat, project_mat, numnod, x4_projected) +! + real(kind = kreal), intent(in) :: model_mat(4,4) + real(kind = kreal), intent(in) :: project_mat(4,4) + integer(kind = kint), intent(in) :: numnod +! + real(kind = kreal), intent(inout) :: x4_projected(4,numnod) +! + integer(kind = kint) :: inod + real(kind = kreal) :: coef + real(kind = kreal) :: x4_tmp(4) +! +! +!$omp parallel do private(inod,x4_tmp,coef) + do inod = 1, numnod + x4_tmp(1) = model_mat(1,1) * x4_projected(1,inod) & + & + model_mat(1,2) * x4_projected(2,inod) & + & + model_mat(1,3) * x4_projected(3,inod) & + & + model_mat(1,4) * x4_projected(4,inod) + x4_tmp(2) = model_mat(2,1) * x4_projected(1,inod) & + & + model_mat(2,2) * x4_projected(2,inod) & + & + model_mat(2,3) * x4_projected(3,inod) & + & + model_mat(2,4) * x4_projected(4,inod) + x4_tmp(3) = model_mat(3,1) * x4_projected(1,inod) & + & + model_mat(3,2) * x4_projected(2,inod) & + & + model_mat(3,3) * x4_projected(3,inod) & + & + model_mat(3,4) * x4_projected(4,inod) + x4_tmp(4) = model_mat(4,1) * x4_projected(1,inod) & + & + model_mat(4,2) * x4_projected(2,inod) & + & + model_mat(4,3) * x4_projected(3,inod) & + & + model_mat(4,4) * x4_projected(4,inod) +! + x4_projected(1,inod) = project_mat(1,1)*x4_tmp(1) & + & + project_mat(1,2)*x4_tmp(2) & + & + project_mat(1,3)*x4_tmp(3) & + & + project_mat(1,4)*x4_tmp(4) + x4_projected(2,inod) = project_mat(2,1)*x4_tmp(1) & + & + project_mat(2,2)*x4_tmp(2) & + & + project_mat(2,3)*x4_tmp(3) & + & + project_mat(2,4)*x4_tmp(4) + x4_projected(3,inod) = project_mat(3,1)*x4_tmp(1) & + & + project_mat(3,2)*x4_tmp(2) & + & + project_mat(3,3)*x4_tmp(3) & + & + project_mat(3,4)*x4_tmp(4) + x4_projected(4,inod) = project_mat(4,1)*x4_tmp(1) & + & + project_mat(4,2)*x4_tmp(2) & + & + project_mat(4,3)*x4_tmp(3) & + & + project_mat(4,4)*x4_tmp(4) +! +! + coef = one / x4_projected(4,inod) + x4_projected(1,inod) = x4_projected(1,inod) * coef + x4_projected(2,inod) = x4_projected(2,inod) * coef + x4_projected(3,inod) = x4_projected(3,inod) * coef + x4_projected(4,inod) = one + end do +!$omp end parallel do +! + end subroutine project_once_each_ele_w_smp +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine cal_position_pvr_modelview & + & (model_mat, numnod, xx, x_nod_model) +! + real(kind = kreal), intent(in) :: model_mat(4,4) +! + integer(kind = kint), intent(in) :: numnod + real(kind = kreal), intent(in) :: xx(numnod,3) + real(kind = kreal), intent(inout) :: x_nod_model(numnod,4) +! + integer(kind = kint) :: inod +! +! +!$omp parallel do private(inod) + do inod = 1, numnod + x_nod_model(inod,1) = model_mat(1,1) * xx(inod,1) & + & + model_mat(1,2) * xx(inod,2) & + & + model_mat(1,3) * xx(inod,3) & + & + model_mat(1,4) * one + x_nod_model(inod,2) = model_mat(2,1) * xx(inod,1) & + & + model_mat(2,2) * xx(inod,2) & + & + model_mat(2,3) * xx(inod,3) & + & + model_mat(2,4) * one + x_nod_model(inod,3) = model_mat(3,1) * xx(inod,1) & + & + model_mat(3,2) * xx(inod,2) & + & + model_mat(3,3) * xx(inod,3) & + & + model_mat(3,4) * one + x_nod_model(inod,4) = model_mat(4,1) * xx(inod,1) & + & + model_mat(4,2) * xx(inod,2) & + & + model_mat(4,3) * xx(inod,3) & + & + model_mat(4,4) * one + end do +!$omp end parallel do +! + end subroutine cal_position_pvr_modelview +! +! ----------------------------------------------------------------------- +! + subroutine chenge_direction_pvr_modelview & + & (model_mat, numnod, xx, x_nod_model) +! + real(kind = kreal), intent(in) :: model_mat(4,4) +! + integer(kind = kint), intent(in) :: numnod + real(kind = kreal), intent(in) :: xx(numnod,3) + real(kind = kreal), intent(inout) :: x_nod_model(numnod,4) +! + integer(kind = kint) :: inod +! +! +!$omp parallel do private(inod) + do inod = 1, numnod + x_nod_model(inod,1) = model_mat(1,1) * xx(inod,1) & + & + model_mat(1,2) * xx(inod,2) & + & + model_mat(1,3) * xx(inod,3) + x_nod_model(inod,2) = model_mat(2,1) * xx(inod,1) & + & + model_mat(2,2) * xx(inod,2) & + & + model_mat(2,3) * xx(inod,3) + x_nod_model(inod,3) = model_mat(3,1) * xx(inod,1) & + & + model_mat(3,2) * xx(inod,2) & + & + model_mat(3,3) * xx(inod,3) + x_nod_model(inod,4) = model_mat(4,1) * xx(inod,1) & + & + model_mat(4,2) * xx(inod,2) & + & + model_mat(4,3) * xx(inod,3) + end do +!$omp end parallel do +! + end subroutine chenge_direction_pvr_modelview +! +! ----------------------------------------------------------------------- +! + subroutine overwte_position_pvr_screen(project_mat, numnod, & + & x_nod_screen) +! + real(kind = kreal), intent(in) :: project_mat(4,4) +! + integer(kind = kint), intent(in) :: numnod + real(kind = kreal), intent(inout) :: x_nod_screen(numnod,4) +! + integer(kind = kint) :: inod + real(kind = kreal) :: coef, x1, x2, x3, x4 +! +! +!$omp parallel do private(inod,x1,x2,x3,x4,coef) + do inod = 1, numnod + x1 = project_mat(1,1)*x_nod_screen(inod,1) & + & + project_mat(1,2)*x_nod_screen(inod,2) & + & + project_mat(1,3)*x_nod_screen(inod,3) & + & + project_mat(1,4)*x_nod_screen(inod,4) + x2 = project_mat(2,1)*x_nod_screen(inod,1) & + & + project_mat(2,2)*x_nod_screen(inod,2) & + & + project_mat(2,3)*x_nod_screen(inod,3) & + & + project_mat(2,4)*x_nod_screen(inod,4) + x3 = project_mat(3,1)*x_nod_screen(inod,1) & + & + project_mat(3,2)*x_nod_screen(inod,2) & + & + project_mat(3,3)*x_nod_screen(inod,3) & + & + project_mat(3,4)*x_nod_screen(inod,4) + x4 = project_mat(4,1)*x_nod_screen(inod,1) & + & + project_mat(4,2)*x_nod_screen(inod,2) & + & + project_mat(4,3)*x_nod_screen(inod,3) & + & + project_mat(4,4)*x_nod_screen(inod,4) +! + coef = one / x4 + x_nod_screen(inod,1) = x1 * coef + x_nod_screen(inod,2) = x2 * coef + x_nod_screen(inod,3) = x3 * coef + end do +!$omp end parallel do +! + end subroutine overwte_position_pvr_screen +! +! ----------------------------------------------------------------------- +! + subroutine overwte_pvr_domain_on_screen(model_mat, project_mat, & + & num_pvr_surf, xx_pvr_domain) +! + real(kind = kreal), intent(in) :: model_mat(4,4) + real(kind = kreal), intent(in) :: project_mat(4,4) +! + integer(kind = kint), intent(in) :: num_pvr_surf + real(kind = kreal), intent(inout) & + & :: xx_pvr_domain(4*num_pvr_surf,4) +! + integer(kind = kint) :: inod, ntot + real(kind = kreal) :: coef +! + ntot = 4*num_pvr_surf + call overwrite_projection_at_once & + & (ntot, model_mat, project_mat, xx_pvr_domain(1,1)) +! +!$omp parallel do private(coef,inod) + do inod = 1, ntot + coef = one / xx_pvr_domain(inod,4) + xx_pvr_domain(inod,1) = xx_pvr_domain(inod,1) * coef + xx_pvr_domain(inod,2) = xx_pvr_domain(inod,2) * coef + xx_pvr_domain(inod,3) = xx_pvr_domain(inod,3) * coef + end do +!$omp end parallel do +! + end subroutine overwte_pvr_domain_on_screen +! +! ----------------------------------------------------------------------- +! + subroutine overwrite_projection_at_once(nnod, A1, A2, x) +! + integer(kind = kint), intent(in) :: nnod + real(kind = kreal), intent(in) :: A1(4,4), A2(4,4) + real(kind = kreal), intent(inout) :: x(nnod,4) +! + real(kind = kreal) :: x1, x2, x3, x4 + integer(kind = kint) :: inod +! +!$omp parallel do private(inod,x1,x2,x3,x4) + do inod = 1, nnod + x1 = A1(1,1)*x(inod,1) + A1(1,2)*x(inod,2) & + & + A1(1,3)*x(inod,3) + A1(1,4) * one + x2 = A1(2,1)*x(inod,1) + A1(2,2)*x(inod,2) & + & + A1(2,3)*x(inod,3) + A1(2,4) * one + x3 = A1(3,1)*x(inod,1) + A1(3,2)*x(inod,2) & + & + A1(3,3)*x(inod,3) + A1(3,4) * one + x4 = A1(4,1)*x(inod,1) + A1(4,2)*x(inod,2) & + & + A1(4,3)*x(inod,3) + A1(4,4) * one +! + x(inod,1) = A2(1,1)*x1 + A2(1,2)*x2 + A2(1,3)*x3 + A2(1,4) * x4 + x(inod,2) = A2(2,1)*x1 + A2(2,2)*x2 + A2(2,3)*x3 + A2(2,4) * x4 + x(inod,3) = A2(3,1)*x1 + A2(3,2)*x2 + A2(3,3)*x3 + A2(3,4) * x4 + x(inod,4) = A2(4,1)*x1 + A2(4,2)*x2 + A2(4,3)*x3 + A2(4,4) * x4 + end do +!$omp end parallel do +! + end subroutine overwrite_projection_at_once +! +! ----------------------------------------------------------------------- +! + end module set_position_pvr_screen diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_projection_matrix.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_projection_matrix.f90 new file mode 100644 index 00000000..acc59add --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_projection_matrix.f90 @@ -0,0 +1,230 @@ +!>@file set_projection_matrix.f90 +!! module set_projection_matrix +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Evaluate projection matirx +!! +!!@verbatim +! +!! subroutine set_perspective_mat_by_angle(view_angle, aspect, & +!! & view_near, view_far, project_mat) +!! subroutine set_perspective_mat_by_area(view_left, view_right, & +!! & view_bottom, view_top, view_near, view_far, project_mat) +!! subroutine set_perspective_mat_half_area(view_right, view_top, & +!! & view_near, view_far, project_mat) +!! range: of view after transdorm: -w@file set_pvr_control.f90 +!!@brief module set_pvr_control +!! +!!@date Programmed by H.Matsui in May. 2006 +! +!>@brief Set PVR parameters from control files +!! +!!@verbatim +!! subroutine bcast_pvr_controls & +!! & (num_pvr_ctl, pvr_ctl, cflag_update) +!! integer(kind = kint), intent(in) :: num_pvr_ctl +!! type(pvr_parameter_ctl), intent(inout) :: pvr_ctl(num_pvr_ctl) +!! subroutine s_set_pvr_controls(group, nod_fld, tracer, fline, & +!! & pvr_ctl_type, pvr_param) +!! integer(kind = kint), intent(in) :: num_pvr +!! type(mesh_groups), intent(in) :: group +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(pvr_parameter_ctl), intent(in) :: pvr_ctl_type +!! type(PVR_control_params), intent(inout) :: pvr_param +!! +!! subroutine flush_each_pvr_control(pvr_param) +!! type(PVR_control_params), intent(inout) :: pvr_param +!!@endverbatim +! + module set_pvr_control +! + use m_precision + use calypso_mpi +! + use t_control_data_4_pvr +! + implicit none +! + private :: init_multi_view_parameters +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine bcast_pvr_controls & + & (num_pvr_ctl, pvr_ctl, cflag_update) +! + use ctl_file_pvr_modelview_IO + use bcast_control_data_4_pvr +! + integer(kind = kint), intent(in) :: num_pvr_ctl +! + character(len=kchara), intent(inout) :: cflag_update + type(pvr_parameter_ctl), intent(inout) :: pvr_ctl(num_pvr_ctl) +! + integer(kind = kint) :: i_pvr +! +! + if(pvr_ctl(1)%updated_ctl%iflag .gt. 0) then + cflag_update = pvr_ctl(1)%updated_ctl%charavalue + end if +! + do i_pvr = 1, num_pvr_ctl + call bcast_vr_psf_ctl(pvr_ctl(i_pvr)) + end do +! + end subroutine bcast_pvr_controls +! +! --------------------------------------------------------------------- +! + subroutine s_set_pvr_controls(group, nod_fld, tracer, fline, & + & pvr_ctl_type, pvr_param) +! + use t_group_data + use t_phys_data + use t_particle_trace + use t_fieldline + use t_rendering_vr_image + use t_geometries_in_pvr_screen + use t_control_data_pvr_sections + use set_control_each_pvr + use set_field_comp_for_viz + use set_pvr_modelview_matrix + use set_control_pvr_movie +! + type(mesh_groups), intent(in) :: group + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(pvr_parameter_ctl), intent(in) :: pvr_ctl_type +! + type(PVR_control_params), intent(inout) :: pvr_param +! + integer(kind = kint) :: icheck_ncomp(1) +! +! + call s_set_control_pvr_movie(pvr_ctl_type%movie, & + & pvr_param%movie_def) +! + call check_pvr_field_control(pvr_ctl_type, & + & nod_fld%num_phys, nod_fld%phys_name) +! + call set_control_field_4_pvr & + & (pvr_ctl_type%pvr_field_ctl, pvr_ctl_type%pvr_comp_ctl, & + & nod_fld%num_phys, nod_fld%phys_name, & + & pvr_param%field_def, icheck_ncomp) + if (icheck_ncomp(1) .gt. 1) & + & call calypso_MPI_abort(ierr_PVR, 'set scalar for rendering') +! + if(iflag_debug .gt. 0) write(*,*) 'set_control_pvr' + call set_control_pvr(pvr_ctl_type, group%ele_grp, group%surf_grp, & + & tracer, fline, pvr_param%area_def, pvr_param%draw_param, & + & pvr_param%color, pvr_param%colorbar) +! +! set parameters for stereo views + call set_pvr_stereo_control(pvr_ctl_type, pvr_param%stereo_def) + call set_pvr_mul_view_params(pvr_ctl_type%mat, & + & pvr_ctl_type%quilt_c, pvr_ctl_type%movie, pvr_param) +! + end subroutine s_set_pvr_controls +! +! --------------------------------------------------------------------- +! + subroutine set_pvr_mul_view_params(mat_base, quilt_c, movie_ctl, & + & pvr_param) +! + use t_rendering_vr_image + use t_geometries_in_pvr_screen + use t_control_data_pvr_sections + use set_pvr_modelview_matrix +! + type(modeview_ctl), intent(in) :: mat_base + type(quilt_image_ctl), intent(in) :: quilt_c + type(pvr_movie_ctl), intent(in) :: movie_ctl +! + type(PVR_control_params), intent(inout) :: pvr_param +! + integer(kind = kint) :: num_views +! +! + if(quilt_c%mul_qmats_c%num_modelviews_c .gt. 0) then + num_views = quilt_c%mul_qmats_c%num_modelviews_c + if(num_views .lt. pvr_param%stereo_def%num_views) then + write(e_message,*) 'The number of view paramter should be', & + & ' more than number of quilt image. (Stop)' + call calypso_mpi_abort(1,e_message) + else + call init_multi_view_parameters(num_views, & + & quilt_c%mul_qmats_c, pvr_param) + end if + else if(movie_ctl%mul_mmats_c%num_modelviews_c .gt. 0) then + num_views = movie_ctl%mul_mmats_c%num_modelviews_c + if(num_views .lt. pvr_param%movie_def%num_frame) then + write(e_message,*) 'The number of view paramter should be', & + & ' more than number of movie image. (Stop)' + call calypso_mpi_abort(1,e_message) + else + pvr_param%flag_mulview_movie = .TRUE. + call init_multi_view_parameters(num_views, & + & movie_ctl%mul_mmats_c, pvr_param) + end if + else + call alloc_multi_view_parameters(ione, pvr_param) + call copy_stereo_perspective_matrix & + & (mat_base%streo, pvr_param%stereo_def) + call s_set_pvr_modelview_matrix(mat_base, & + & pvr_param%multi_view(1)) + end if +! + end subroutine set_pvr_mul_view_params +! +! --------------------------------------------------------------------- +! + subroutine init_multi_view_parameters(num_views, mul_mmats_c, & + & pvr_param) +! + use t_rendering_vr_image + use set_pvr_modelview_matrix +! + integer(kind = kint), intent(in) :: num_views + type(multi_modelview_ctl), intent(in) :: mul_mmats_c +! + type(PVR_control_params), intent(inout) :: pvr_param +! + integer(kind = kint) :: i +! +! + call alloc_multi_view_parameters(num_views, pvr_param) + do i = 1, pvr_param%num_multi_views + call s_set_pvr_modelview_matrix & + & (mul_mmats_c%matrices(i), pvr_param%multi_view(i)) + end do +! + end subroutine init_multi_view_parameters +! +! --------------------------------------------------------------------- +! + subroutine flush_each_pvr_control(pvr_param) +! + use t_pvr_colormap_parameter + use t_rendering_vr_image + use t_geometries_in_pvr_screen +! + type(PVR_control_params), intent(inout) :: pvr_param +! +! + if(pvr_param%draw_param%num_sections .gt. 0) then + call dealloc_pvr_sections(pvr_param%draw_param) + end if +! + if(pvr_param%draw_param%num_isosurf .gt. 0) then + call dealloc_pvr_isosurfaces(pvr_param%draw_param) + end if +! + call dealloc_pvr_tracer_param(pvr_param%draw_param%tracer_pvr_prm) + call dealloc_pvr_tracer_param(pvr_param%draw_param%fline_pvr_prm) +! + call dealloc_pvr_element_group(pvr_param%area_def) + call dealloc_pvr_color_parameteres(pvr_param%color) +! + end subroutine flush_each_pvr_control +! +! --------------------------------------------------------------------- + + end module set_pvr_control diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_pvr_modelview_matrix.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_pvr_modelview_matrix.f90 new file mode 100644 index 00000000..9ba6d86b --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_pvr_modelview_matrix.f90 @@ -0,0 +1,433 @@ +!>@file set_pvr_modelview_matrix.f90 +!! module set_pvr_modelview_matrix +!! +!!@author H. Matsui +!!@date Programmed in May. 2009 +! +!> @brief Evaluate model view matirx +!! +!!@verbatim +!! subroutine s_set_pvr_modelview_matrix(mat, view_param) +!! type(modeview_ctl), intent(in) :: mat +!! type(pvr_view_parameter), intent(inout) :: view_param +!! subroutine copy_stereo_perspective_matrix(streo, stereo_def) +!! type(streo_view_ctl), intent(in) :: streo +!! type(pvr_stereo_parameter), intent(inout) :: stereo_def +!! +!! subroutine copy_pvr_perspective_matrix(proj, view_param) +!! type(projection_ctl), intent(in) :: proj +!! type(pvr_view_parameter), intent(inout) :: view_param +!! subroutine copy_pvr_image_size(pixel, view_param) +!! type(screen_pixel_ctl), intent(in) :: pixel +!! type(pvr_view_parameter), intent(inout) :: view_param +!!@endverbatim +! + module set_pvr_modelview_matrix +! + use m_precision +! + use calypso_mpi + use m_constants + use m_error_IDs + use t_ctl_data_4_view_transfer + use t_control_params_4_pvr + use t_geometries_in_pvr_screen + use t_control_params_stereo_pvr +! + implicit none +! + private :: copy_pvr_modelview_matrix, set_viewpoint_vector_ctl + private :: set_view_rotation_vect_ctl, set_view_scale_factor_ctl + private :: set_viewpnt_in_viewer_ctl +! + private :: set_4direction_flag, set_3direction_flag +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine s_set_pvr_modelview_matrix(mat, view_param) +! + type(modeview_ctl), intent(in) :: mat + type(pvr_view_parameter), intent(inout) :: view_param +! +! + call copy_pvr_image_size(mat%pixel, view_param) + call copy_pvr_perspective_matrix(mat%proj, view_param) +! + if (mat%modelview_mat_ctl%num .gt. 0) then + call copy_pvr_modelview_matrix(mat, view_param) + else + call set_viewpoint_vector_ctl(mat, view_param) + end if +! + if(mat%view_rotation_deg_ctl%iflag .gt. 0 & + & .and. mat%view_rot_vec_ctl%num .ge. 3) then + call set_view_rotation_vect_ctl(mat, view_param) + end if +! + if(mat%scale_factor_ctl%iflag .gt. 0) then + view_param%scale_factor_pvr(1:3) & + & = mat%scale_factor_ctl%realvalue + view_param%iflag_scale_fact = 1 + else if(mat%scale_vector_ctl%num .ge. 3) then + call set_view_scale_factor_ctl(mat, view_param) + end if +! + if(mat%viewpt_in_viewer_ctl%num .ge. 3) then + call set_viewpnt_in_viewer_ctl(mat, view_param) + end if +! + end subroutine s_set_pvr_modelview_matrix +! +! ----------------------------------------------------------------------- +! + subroutine copy_pvr_image_size(pixel, view_param) +! + use t_ctl_data_4_screen_pixel +! + type(screen_pixel_ctl), intent(in) :: pixel + type(pvr_view_parameter), intent(inout) :: view_param +! +! + if(pixel%num_xpixel_ctl%iflag .gt. 0) then + view_param%n_pvr_pixel(1) = pixel%num_xpixel_ctl%intvalue + else + view_param%n_pvr_pixel(1) = 640 + end if +! + if(pixel%num_ypixel_ctl%iflag .gt. 0) then + view_param%n_pvr_pixel(2) = pixel%num_ypixel_ctl%intvalue + else + view_param%n_pvr_pixel(2) = 480 + end if +! + end subroutine copy_pvr_image_size +! +! ----------------------------------------------------------------------- +! + subroutine copy_pvr_perspective_matrix(proj, view_param) +! + use t_ctl_data_4_projection + use t_ctl_data_4_streo_view +! + type(projection_ctl), intent(in) :: proj + type(pvr_view_parameter), intent(inout) :: view_param +! +! + if (proj%perspective_angle_ctl%iflag .gt. 0) then + view_param%perspective_angle & + & = proj%perspective_angle_ctl%realvalue + else + view_param%perspective_angle = 10.0d0 + end if +! + if (proj%perspective_xy_ratio_ctl%iflag .gt. 0) then + view_param%perspective_xy_ratio & + & = proj%perspective_xy_ratio_ctl%realvalue + else + view_param%perspective_xy_ratio & + & = dble(view_param%n_pvr_pixel(1)) & + & / dble(view_param%n_pvr_pixel(2)) + end if +! + if (proj%perspective_near_ctl%iflag .gt. 0) then + view_param%perspective_near & + & = proj%perspective_near_ctl%realvalue + else + view_param%perspective_near = 1.0d-3 + end if +! + if (proj%perspective_far_ctl%iflag .gt. 0) then + view_param%perspective_far & + & = proj%perspective_far_ctl%realvalue + else + view_param%perspective_far = 1.0d3 + end if +! + view_param%iflag_perspective & + & = proj%perspective_angle_ctl%iflag +! + end subroutine copy_pvr_perspective_matrix +! +! ----------------------------------------------------------------------- +! + subroutine copy_stereo_perspective_matrix(streo, stereo_def) +! + use t_ctl_data_4_projection + use t_ctl_data_4_streo_view +! + type(streo_view_ctl), intent(in) :: streo + type(pvr_stereo_parameter), intent(inout) :: stereo_def +! +! + if(streo%i_stereo_view .eq. 0) then + if(stereo_def%flag_quilt) then + stereo_def%flag_quilt = .FALSE. + if(my_rank.eq.0) then + write(*,*) 'Stereo view paramters are missing.' + write(*,*) 'Turn off Quilt view.' + end if + end if + end if +! + if(streo%focalpoint_ctl%iflag .gt. 0) then + stereo_def%focalLength = streo%focalpoint_ctl%realvalue + else + stereo_def%focalLength = 1.0d+1 + end if +! + stereo_def%flag_eye_separation_angle = .FALSE. + if(streo%eye_sep_angle_ctl%iflag .gt. 0) then + stereo_def%flag_eye_separation_angle = .TRUE. + stereo_def%eye_sep_angle = streo%eye_sep_angle_ctl%realvalue + else if(streo%eye_separation_ctl%iflag .gt. 0) then + stereo_def%eye_separation = streo%eye_separation_ctl%realvalue + else + stereo_def%eye_separation = 1.0d-1 + end if +! + stereo_def%flag_setp_eye_separation_angle = .FALSE. + if(streo%step_eye_sep_angle_ctl%iflag .gt. 0 & + & .and. yes_flag(streo%step_eye_sep_angle_ctl%charavalue)) then + stereo_def%flag_setp_eye_separation_angle = .TRUE. + end if +! + end subroutine copy_stereo_perspective_matrix +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine copy_pvr_modelview_matrix(mat, view_param) +! + use skip_comment_f +! + type(modeview_ctl), intent(in) :: mat + type(pvr_view_parameter), intent(inout) :: view_param + integer(kind = kint) :: i, nd1, nd2 +! +! + if(mat%modelview_mat_ctl%num .ne. 16) then + write(e_message,'(a)') & + & 'Modelview Matrix should be 16 components' + call calypso_MPI_abort(ierr_PVR, e_message) + end if +! + do i = 1, mat%modelview_mat_ctl%num + nd1 = set_4direction_flag(mat%modelview_mat_ctl%c1_tbl(i)) + nd2 = set_4direction_flag(mat%modelview_mat_ctl%c2_tbl(i)) +! + if(nd1*nd2 .gt. 0) then + view_param%modelview(nd2,nd1) = mat%modelview_mat_ctl%vect(i) + end if + end do +! + view_param%iflag_modelview_mat = 1 +! + end subroutine copy_pvr_modelview_matrix +! +! ----------------------------------------------------------------------- +! + subroutine set_viewpoint_vector_ctl(mat, view_param) +! + type(modeview_ctl), intent(in) :: mat + type(pvr_view_parameter), intent(inout) :: view_param +! + integer(kind = kint) :: i, nd +! +! +! if(mat%lookpoint_ctl%num .ne. 3) then +! write(e_message,'(a)') & +! & 'Lookatpoint vector should be 3 components' +! call calypso_MPI_abort(ierr_PVR, e_message) +! end if +! if(mat%viewpoint_ctl%num .ne. 3) then +! write(e_message,'(a)') & +! & 'Viewpoint vector should be 3 components' +! call calypso_MPI_abort(ierr_PVR, e_message) +! end if +! if(mat%up_dir_ctl%num .ne. 3) then +! write(e_message,'(a)') & +! & 'Up-direction vector should be 3 components' +! call calypso_MPI_abort(ierr_PVR, e_message) +! end if +! + do i = 1, mat%lookpoint_ctl%num + nd = set_3direction_flag(mat%lookpoint_ctl%c_tbl(i)) + if(nd .eq. 0) cycle + view_param%lookat_vec(nd) = mat%lookpoint_ctl%vect(i) + end do + if(mat%lookpoint_ctl%num .ge. 3) then + view_param%iflag_lookpoint = 1 + end if +! + do i = 1, mat%viewpoint_ctl%num + nd = set_3direction_flag(mat%viewpoint_ctl%c_tbl(i)) + if(nd .eq. 0) cycle + view_param%viewpoint(nd) = mat%viewpoint_ctl%vect(i) + end do + if(mat%viewpoint_ctl%num .ge. 3) then + view_param%iflag_viewpoint = 1 + end if +! + do i = 1, mat%up_dir_ctl%num + nd = set_3direction_flag(mat%up_dir_ctl%c_tbl(i)) + if(nd .eq. 0) cycle + view_param%up_direction_vec(nd) = mat%up_dir_ctl%vect(i) + end do + if(mat%up_dir_ctl%num .ge. 3) then + view_param%iflag_updir = 1 + end if +! + if (iflag_debug .gt. 0) then + write(*,*) 'iflag_lookpoint_vec', view_param%iflag_lookpoint + write(*,*) 'lookat_vec', view_param%lookat_vec(1:3) + write(*,*) 'iflag_viewpoint_vec', view_param%iflag_viewpoint + write(*,*) 'viewpoint_vec', view_param%viewpoint(1:3) + write(*,*) 'iflag_updir_vec', view_param%iflag_updir + write(*,*) 'up_direction_vec', & + & view_param%up_direction_vec(1:3) + end if +! + end subroutine set_viewpoint_vector_ctl +! +! ----------------------------------------------------------------------- +! + subroutine set_view_rotation_vect_ctl(mat, view_param) +! + type(modeview_ctl), intent(in) :: mat + type(pvr_view_parameter), intent(inout) :: view_param +! + integer(kind = kint) :: i, nd +! +! + if(mat%view_rot_vec_ctl%num .ne. 3) then + write(e_message,'(a)') & + & 'Rotaion of viewpoint vector should be 3 components' + call calypso_MPI_abort(ierr_PVR, e_message) + end if +! + if (mat%view_rotation_deg_ctl%iflag .gt. 0) then + view_param%rotation_pvr(1) & + & = mat%view_rotation_deg_ctl%realvalue + else + view_param%rotation_pvr(1) = 0.0d0 + end if +! + do i = 1, mat%view_rot_vec_ctl%num + nd = set_3direction_flag(mat%view_rot_vec_ctl%c_tbl(i)) + if(nd .eq. 0) cycle + view_param%rotation_pvr(nd+1) = mat%view_rot_vec_ctl%vect(i) + end do + if(mat%view_rot_vec_ctl%num.ge.3 & + & .and. mat%view_rotation_deg_ctl%iflag .gt. 0) then + view_param%iflag_rotation = 1 + end if +! + if (iflag_debug .gt. 0) then + write(*,*) 'rotation_vect', view_param%rotation_pvr(2:4) + write(*,*) 'rotation_angle', view_param%rotation_pvr(1) + end if +! + end subroutine set_view_rotation_vect_ctl +! +! ----------------------------------------------------------------------- +! + subroutine set_view_scale_factor_ctl(mat, view_param) +! + type(modeview_ctl), intent(in) :: mat + type(pvr_view_parameter), intent(inout) :: view_param + integer(kind = kint) :: i, nd +! +! + if(mat%scale_vector_ctl%num .ne. 3) then + write(e_message,'(a)') & + & 'Scale factor vector should be 3 components' + call calypso_MPI_abort(ierr_PVR, e_message) + end if +! + do i = 1, mat%scale_vector_ctl%num + nd = set_3direction_flag(mat%scale_vector_ctl%c_tbl(i)) + if(nd .eq. 0) cycle + view_param%scale_factor_pvr(nd) = mat%scale_vector_ctl%vect(i) + end do + if (mat%scale_vector_ctl%num .ge. 3) then + view_param%iflag_scale_fact = 1 + end if +! + end subroutine set_view_scale_factor_ctl +! +! ----------------------------------------------------------------------- +! + subroutine set_viewpnt_in_viewer_ctl(mat, view_param) +! + use skip_comment_f +! + type(modeview_ctl), intent(in) :: mat + type(pvr_view_parameter), intent(inout) :: view_param +! + integer(kind = kint) :: i, nd +! +! + if(mat%viewpt_in_viewer_ctl%num .ne. 3) then + write(e_message,'(a)') & + & 'Viewpoint in viewer should be 3 components' + call calypso_MPI_abort(ierr_PVR, e_message) + end if +! + do i = 1, mat%viewpt_in_viewer_ctl%num + nd = set_3direction_flag(mat%viewpt_in_viewer_ctl%c_tbl(i)) + if(nd .eq. 0) cycle + view_param%viewpt_in_viewer_pvr(nd) & + & = mat%viewpt_in_viewer_ctl%vect(i) + end do + if (mat%viewpt_in_viewer_ctl%num .ge. 3) then + view_param%iflag_viewpt_in_view = 1 + end if +! + view_param%lookat_vec(1:2) = view_param%lookat_vec(1:2) & + & - view_param%viewpt_in_viewer_pvr(1:2) +! + end subroutine set_viewpnt_in_viewer_ctl +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + integer function set_4direction_flag(dir_ctl) +! + use skip_comment_f +! + character(len = kchara), intent(in) :: dir_ctl +! +! + if (cmp_no_case(dir_ctl,'x') .or. dir_ctl.eq.'1') then + set_4direction_flag = 1 + else if(cmp_no_case(dir_ctl,'y') .or. dir_ctl.eq.'2') then + set_4direction_flag = 2 + else if(cmp_no_case(dir_ctl,'z') .or. dir_ctl.eq.'3') then + set_4direction_flag = 3 + else if(cmp_no_case(dir_ctl,'w') .or. dir_ctl.eq.'4') then + set_4direction_flag = 4 + else + set_4direction_flag = 0 + end if +! + end function set_4direction_flag +! +! ----------------------------------------------------------------------- +! + integer function set_3direction_flag(dir_ctl) +! + character(len = kchara), intent(in) :: dir_ctl +! +! + set_3direction_flag = set_4direction_flag(dir_ctl) + if(set_4direction_flag(dir_ctl) .eq. 4) set_3direction_flag = 0 +! + end function set_3direction_flag +! +! ----------------------------------------------------------------------- +! + end module set_pvr_modelview_matrix diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_pvr_ray_start_point.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_pvr_ray_start_point.f90 new file mode 100644 index 00000000..540814b8 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_pvr_ray_start_point.f90 @@ -0,0 +1,327 @@ +!>@file set_pvr_ray_start_point.f90 +!! module set_pvr_ray_start_point +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Set start points for ray tracing +!! +!!@verbatim +!! subroutine set_each_pvr_ray_start & +!! & (node, surf, npixel_x, npixel_y, & +!! & num_pvr_surf, item_pvr_surf_domain, & +!! & screen_norm_pvr_domain, isurf_xrng_pvr_domain, & +!! & jsurf_yrng_pvr_domain, viewpoint_vec, ray_vec4, & +!! & istack_pvr_ray_sf, num_pvr_ray, id_pixel_start, & +!! & isf_pvr_ray_start, xi_pvr_start, & +!! & xx4_pvr_start, xx4_pvr_ray_start) +!! subroutine set_each_ray_projected_start(surf, & +!! & npixel_x, npixel_y, pixel_point_x, pixel_point_y, & +!! & num_pvr_surf, item_pvr_surf_domain, & +!! & screen_norm_pvr_domain, ray_vec4, & +!! & ntot_tmp_pvr_ray, istack_tmp_pvr_ray_st, & +!! & ipix_start_tmp, iflag_start_tmp, istack_pvr_ray_sf, & +!! & num_pvr_ray, xx4_pvr_ray_start) +!! type(surface_data), intent(in) :: surf +!! subroutine check_pvr_ray_startpoint & +!! & (npixel_x, npixel_y, num_pvr_ray, id_pixel_start) +!! subroutine set_pvr_ray_trace_check(npixel_x, npixel_y, & +!! & num_pvr_ray, id_pixel_start, id_pixel_check) +!!@endverbatim +! + module set_pvr_ray_start_point +! + use m_precision +! + use calypso_mpi + use m_constants + use m_geometry_constants + use t_geometry_data + use t_surface_data + use t_control_params_4_pvr +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_each_pvr_ray_start & + & (node, surf, npixel_x, npixel_y, & + & num_pvr_surf, item_pvr_surf_domain, & + & screen_norm_pvr_domain, viewpoint_vec, ray_vec4, & + & ntot_tmp_pvr_ray, istack_tmp_pvr_ray_st, & + & ipix_start_tmp, iflag_start_tmp, xi_pvr_start_tmp, & + & istack_pvr_ray_sf, num_pvr_ray, id_pixel_start, & + & isf_pvr_ray_start, xi_pvr_start, & + & xx4_pvr_start, xx4_pvr_ray_start) +! + use cal_field_on_surf_viz +! + type(node_data), intent(in) :: node + type(surface_data), intent(in) :: surf +! + integer(kind = kint), intent(in) :: npixel_x, npixel_y +! + integer(kind = kint), intent(in) :: num_pvr_surf + integer(kind = kint), intent(in) & + & :: item_pvr_surf_domain(2,num_pvr_surf) + real(kind = kreal), intent(in) & + & :: screen_norm_pvr_domain(3,num_pvr_surf) +! + real(kind = kreal), intent(in) :: viewpoint_vec(3) + real(kind = kreal), intent(in) :: ray_vec4(4) +! + integer(kind = kint), intent(in) :: ntot_tmp_pvr_ray + integer(kind = kint), intent(in) & + & :: istack_tmp_pvr_ray_st(0:num_pvr_surf) + integer(kind = kint), intent(in) & + & :: iflag_start_tmp(ntot_tmp_pvr_ray) + integer(kind = kint), intent(in) & + & :: ipix_start_tmp(2,ntot_tmp_pvr_ray) + real(kind = kreal), intent(in) & + & :: xi_pvr_start_tmp(2,ntot_tmp_pvr_ray) + integer(kind = kint), intent(in) & + & :: istack_pvr_ray_sf(0:num_pvr_surf) +! + integer(kind = kint), intent(in) :: num_pvr_ray + integer(kind = kint), intent(inout) & + & :: id_pixel_start(num_pvr_ray) + integer(kind = kint), intent(inout) & + & :: isf_pvr_ray_start(3,num_pvr_ray) + real(kind = kreal), intent(inout) :: xi_pvr_start(2,num_pvr_ray) + real(kind = kreal), intent(inout) :: xx4_pvr_start(4,num_pvr_ray) + real(kind = kreal), intent(inout) & + & :: xx4_pvr_ray_start(4,num_pvr_ray) +! real(kind = kreal), intent(inout) :: pvr_ray_dir(3,num_pvr_ray) +! + integer(kind = kint) :: inum, icou, jcou, iele, k1, isurf + integer(kind = kint) :: ist_pix, ied_pix + integer(kind = kint) :: ipix, jpix +! +! +!$omp parallel do private(inum,icou,jcou,iele,k1,isurf, & +!$omp& ipix,jpix,ist_pix,ied_pix) + do inum = 1, num_pvr_surf + if((screen_norm_pvr_domain(3,inum)*ray_vec4(3)) & + & .gt. SMALL_NORM) then + iele = item_pvr_surf_domain(1,inum) + k1 = item_pvr_surf_domain(2,inum) + isurf = abs(surf%isf_4_ele(iele,k1)) +! + icou = istack_tmp_pvr_ray_st(inum-1) + jcou = istack_pvr_ray_sf(inum-1) +! + ist_pix = istack_tmp_pvr_ray_st(inum-1) + 1 + ied_pix = istack_tmp_pvr_ray_st(inum) + do icou = ist_pix, ied_pix + ipix = ipix_start_tmp(1,icou) + jpix = ipix_start_tmp(2,icou) + if(iflag_start_tmp(icou) .gt. 0) then + jcou = jcou + 1 + if(jcou .gt. num_pvr_ray) write(*,*) 'aho', my_rank, & + & jcou, num_pvr_ray, inum, num_pvr_surf +! + id_pixel_start(jcou) = ipix + (jpix-1)*npixel_x + isf_pvr_ray_start(1,jcou) = iele + isf_pvr_ray_start(2,jcou) = k1 + isf_pvr_ray_start(3,jcou) = surf%ie_surf(isurf,1) + xi_pvr_start(1:2,jcou) = xi_pvr_start_tmp(1:2,icou) +! + call cal_field_on_surf_vect4(node%numnod, surf%numsurf, & + & surf%nnod_4_surf, surf%ie_surf, isurf, & + & xi_pvr_start(1,jcou), node%xx(1,1), & + & xx4_pvr_start(1,jcou)) +! +! pvr_ray_dir(1,jcou) = viewpoint_vec(1) & +! & - xx4_pvr_start(1,jcou) +! pvr_ray_dir(2,jcou) = viewpoint_vec(2) & +! & - xx4_pvr_start(2,jcou) +! pvr_ray_dir(3,jcou) = viewpoint_vec(3) & +! & - xx4_pvr_start(3,jcou) + end if + end do + end if +! + end do +!$omp end parallel do +! +!$omp parallel workshare + xx4_pvr_ray_start(1:4,1:num_pvr_ray) & + & = xx4_pvr_start(1:4,1:num_pvr_ray) +!$omp end parallel workshare +! + end subroutine set_each_pvr_ray_start +! +! --------------------------------------------------------------------- +! + subroutine set_each_ray_projected_start(surf, & + & npixel_x, npixel_y, pixel_point_x, pixel_point_y, & + & num_pvr_surf, item_pvr_surf_domain, & + & screen_norm_pvr_domain, ray_vec4, & + & ntot_tmp_pvr_ray, istack_tmp_pvr_ray_st, & + & ipix_start_tmp, iflag_start_tmp, istack_pvr_ray_sf, & + & num_pvr_ray, xx4_pvr_ray_start) +! + use cal_field_on_surf_viz +! + type(surface_data), intent(in) :: surf +! + integer(kind = kint), intent(in) :: npixel_x, npixel_y + real(kind = kreal), intent(in) :: pixel_point_x(npixel_x) + real(kind = kreal), intent(in) :: pixel_point_y(npixel_y) +! + integer(kind = kint), intent(in) :: num_pvr_surf + integer(kind = kint), intent(in) & + & :: item_pvr_surf_domain(2,num_pvr_surf) + real(kind = kreal), intent(in) & + & :: screen_norm_pvr_domain(3,num_pvr_surf) +! + real(kind = kreal), intent(in) :: ray_vec4(4) +! + integer(kind = kint), intent(in) :: ntot_tmp_pvr_ray + integer(kind = kint), intent(in) & + & :: istack_tmp_pvr_ray_st(0:num_pvr_surf) + integer(kind = kint), intent(in) & + & :: iflag_start_tmp(ntot_tmp_pvr_ray) + integer(kind = kint), intent(in) & + & :: ipix_start_tmp(2,ntot_tmp_pvr_ray) + integer(kind = kint), intent(in) & + & :: istack_pvr_ray_sf(0:num_pvr_surf) +! + integer(kind = kint), intent(in) :: num_pvr_ray +! + real(kind = kreal), intent(inout) & + & :: xx4_pvr_ray_start(4,num_pvr_ray) +! + integer(kind = kint) :: inum, icou, jcou, iele, k1, isurf + integer(kind = kint) :: ist_pix, ied_pix + integer(kind = kint) :: ipix, jpix +! +! +!$omp parallel do private(inum,icou,jcou,iele,k1,isurf, & +!$omp& ipix,jpix,ist_pix,ied_pix) + do inum = 1, num_pvr_surf + if((screen_norm_pvr_domain(3,inum)*ray_vec4(3)) & + & .gt. SMALL_NORM) then + iele = item_pvr_surf_domain(1,inum) + k1 = item_pvr_surf_domain(2,inum) + isurf = abs(surf%isf_4_ele(iele,k1)) +! + icou = istack_tmp_pvr_ray_st(inum-1) + jcou = istack_pvr_ray_sf(inum-1) +! + ist_pix = istack_tmp_pvr_ray_st(inum-1) + 1 + ied_pix = istack_tmp_pvr_ray_st(inum) + do icou = ist_pix, ied_pix + ipix = ipix_start_tmp(1,icou) + jpix = ipix_start_tmp(2,icou) + if(iflag_start_tmp(icou) .gt. 0) then + jcou = jcou + 1 + xx4_pvr_ray_start(1,jcou) = pixel_point_x(ipix) + xx4_pvr_ray_start(2,jcou) = pixel_point_y(jpix) + end if + end do + end if +! + end do +!$omp end parallel do +! + end subroutine set_each_ray_projected_start +! +! --------------------------------------------------------------------- +! + subroutine check_pvr_ray_startpoint & + & (npixel_x, npixel_y, num_pvr_ray, id_pixel_start) +! + use calypso_mpi_int + use write_bmp_image +! + integer(kind = kint), intent(in) :: npixel_x, npixel_y + integer(kind = kint), intent(in) :: num_pvr_ray + integer(kind = kint), intent(in) & + & :: id_pixel_start(num_pvr_ray) +! + integer(kind = kint) :: inum, icou + integer(kind = kint_gl) :: npixel +! + character(len=kchara), parameter :: img_head = 'startpoints' + integer(kind = kint), allocatable :: iflag_pix_g(:) + integer(kind = kint), allocatable :: iflag_pix_l(:) + character(len = 1), allocatable :: rgb_chk(:,:) +! +! + allocate(iflag_pix_l(npixel_x*npixel_y)) + allocate(iflag_pix_g(npixel_x*npixel_y)) + allocate(rgb_chk(3,npixel_x*npixel_y)) +! + iflag_pix_l = 0 + iflag_pix_g = 0 + rgb_chk = char(0) + do icou = 1, num_pvr_ray + inum = id_pixel_start(icou) + iflag_pix_l(inum) = 1 + end do +! + npixel = npixel_x*npixel_y + call calypso_mpi_allreduce_int & + & (iflag_pix_l, iflag_pix_g, npixel, MPI_SUM) +! + if(my_rank .eq. 0) then + do icou = 1, npixel_x*npixel_y + rgb_chk(1,icou) = char(iflag_pix_g(icou)*255) + end do +! + call pixout_BMP & + & (img_head, npixel_x, npixel_y, rgb_chk(1,1)) +! + do icou = 1, npixel_x*npixel_y + if(iflag_pix_g(icou) .eq. 0) write(*,*) 'missing pixel: ', & + & icou, mod(icou-1,npixel_x)+1, (icou-1)/npixel_x+1 + end do + end if +! + deallocate(rgb_chk, iflag_pix_g, iflag_pix_l) +! + end subroutine check_pvr_ray_startpoint +! +! --------------------------------------------------------------------- +! + subroutine set_pvr_ray_trace_check(npixel_x, npixel_y, & + & num_pvr_ray, id_pixel_start, id_pixel_check) +! + use write_bmp_image +! + integer(kind = kint), intent(in) :: npixel_x, npixel_y + integer(kind = kint), intent(in) :: num_pvr_ray + integer(kind = kint), intent(in) & + & :: id_pixel_start(num_pvr_ray) +! + integer(kind = kint), intent(inout) & + & :: id_pixel_check(num_pvr_ray) +! + integer(kind = kint) :: inum, icou + integer(kind = kint) :: ipix, jpix +! +! + do icou = 1, num_pvr_ray + inum = id_pixel_start(icou) + ipix = mod(inum-1,npixel_x)+1 + jpix = (inum-1)/npixel_x+1 +! + if(ipix.eq.636 .and. jpix.eq.245) id_pixel_check(icou) = 1 + if(ipix.eq.637 .and. jpix.eq.245) id_pixel_check(icou) = 1 +! if(my_rank.eq.134 .and. icou.eq.18854) id_pixel_check(icou) = 2 +! + if(id_pixel_check(icou) .gt. 0) then + write(*,*) 'pixel check for ', my_rank, icou, ipix, jpix + end if + end do +! + end subroutine set_pvr_ray_trace_check +! +! --------------------------------------------------------------------- +! + end module set_pvr_ray_start_point diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_pvr_stencil_buffer.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_pvr_stencil_buffer.f90 new file mode 100644 index 00000000..50333467 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_pvr_stencil_buffer.f90 @@ -0,0 +1,318 @@ +!>@file set_pvr_stencil_buffer.f90 +!!@brief module set_pvr_stencil_buffer +!! +!!@author H. Matsui +!!@date Programmed on Oct., 2016 +! +!>@brief Set communication table and imagae comsition stack +!! +!!@verbatim +!! subroutine s_set_pvr_stencil_buffer & +!! & (irank_image_file, irank_end_composit, num_pixel_xy, & +!! & elps_PVR, pvr_start, stencil_wk, num_pixel_recv, & +!! & img_output_tbl, img_composit_tbl, img_stack, & +!! & SR_sig, SR_r, SR_i) +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(pvr_ray_start_type), intent(in) :: pvr_start +!! type(stencil_buffer_work), intent(in) :: stencil_wk +!! type(calypso_comm_table), intent(inout) :: img_output_tbl +!! type(calypso_comm_table), intent(inout) :: img_composit_tbl +!! type(pvr_image_stack_table), intent(inout) :: img_stack +!! type(send_recv_status), intent(inout) :: SR_sig +!! type(send_recv_real_buffer), intent(inout) :: SR_r +!! type(send_recv_int_buffer), intent(inout) :: SR_i +!!@endverbatim +!! + module set_pvr_stencil_buffer +! + use m_precision + use m_constants + use m_machine_parameter + use calypso_mpi +! + use t_calypso_comm_table + use t_pvr_ray_startpoints + use t_pvr_image_stack_table + use t_stencil_buffer_work + use t_solver_SR + use t_solver_SR_int +! + implicit none +! + character(len=kchara), parameter, private & + & :: check_fhead = 'pvr_composition_check' + integer(kind = kint), parameter, private :: id_file = 49 +! + private :: num_parallel_stencil_buffer + private :: set_global_pixel_4_composit + private :: check_composit_communication + private :: check_img_output_communication +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_set_pvr_stencil_buffer & + & (irank_image_file, irank_end_composit, num_pixel_xy, & + & elps_PVR, pvr_start, stencil_wk, num_pixel_recv, & + & img_output_tbl, img_composit_tbl, img_stack, & + & SR_sig, SR_r, SR_i) +! + use m_work_time + use quicksort + use calypso_SR_type + use const_comm_tbl_img_composit + use set_parallel_file_name +! + integer(kind = kint), intent(in) :: irank_image_file + integer(kind = kint), intent(in) :: irank_end_composit + integer(kind = kint), intent(in) :: num_pixel_xy + type(elapsed_lables), intent(in) :: elps_PVR + type(pvr_ray_start_type), intent(in) :: pvr_start + type(stencil_buffer_work), intent(in) :: stencil_wk +! + integer(kind = kint), intent(inout) :: num_pixel_recv + type(calypso_comm_table), intent(inout) :: img_output_tbl + type(calypso_comm_table), intent(inout) :: img_composit_tbl + type(pvr_image_stack_table), intent(inout) :: img_stack + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r + type(send_recv_int_buffer), intent(inout) :: SR_i +! + character(len=kchara) :: fname_tmp, file_name +! +! +! write(*,*) 'num_parallel_stencil_buffer' + img_stack%npixel_4_composit & + & = num_parallel_stencil_buffer(stencil_wk) +! +! +! write(*,*) 's_const_comm_tbl_img_output' + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+8) + call s_const_comm_tbl_img_output & + & (stencil_wk, irank_image_file, num_pixel_xy, & + & img_stack%npixel_4_composit, num_pixel_recv, img_output_tbl) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+8) +! +! +! write(*,*) 'set_global_pixel_4_composit' + call alloc_pvr_ipixel_4_composit(num_pixel_xy, img_stack) + call set_global_pixel_4_composit & + & (stencil_wk, img_stack%npixel_4_composit, num_pixel_xy, & + & img_stack%ipixel_4_composit, img_stack%item_4_composit) +! +! +! +! write(*,*) 's_const_comm_tbl_img_composit' + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+9) + call s_const_comm_tbl_img_composit & + & (irank_image_file, irank_end_composit, & + & num_pixel_xy, stencil_wk%irank_4_composit, & + & pvr_start%num_pvr_ray, pvr_start%id_pixel_start, & + & img_composit_tbl) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+9) +! +! + call alloc_depth_pixel_composit(pvr_start%num_pvr_ray, & + & img_composit_tbl%ntot_import, img_stack) +! +!$omp parallel workshare + img_stack%depth_pvr_ray_start(1:pvr_start%num_pvr_ray) & + & = - pvr_start%xx4_pvr_ray_start(3,1:pvr_start%num_pvr_ray) +!$omp end parallel workshare +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+10) + call calypso_SR_type_int(0, img_composit_tbl, & + & pvr_start%num_pvr_ray, img_composit_tbl%ntot_import, & + & pvr_start%id_pixel_start, img_stack%ipix_4_composit, & + & SR_sig, SR_i) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+10) +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+11) + call calypso_SR_type_1(0, img_composit_tbl, & + & pvr_start%num_pvr_ray, img_composit_tbl%ntot_import, & + & img_stack%depth_pvr_ray_start, img_stack%depth_pixel_composit, & + & SR_sig, SR_r) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+11) +! + call alloc_pvr_image_stack_table(img_stack) + call set_image_stacking_and_recv & + & (num_pixel_xy, img_stack%item_4_composit, & + & img_stack%npixel_4_composit, img_stack%ipix_4_composit, & + & img_stack%depth_pixel_composit, img_stack%istack_composition, & + & img_composit_tbl) +! + if(i_debug .gt. 0) then + fname_tmp = add_int_suffix(my_rank, check_fhead) + file_name = add_dat_extension(fname_tmp) + open(id_file, file = file_name) + call check_img_output_communication(id_file, & + & img_stack, img_output_tbl, stencil_wk, & + & num_pixel_xy, num_pixel_recv, SR_sig, SR_i) +! + call check_composit_communication(id_file, & + & pvr_start, img_composit_tbl, img_stack) + close(id_file) +! + call dealloc_pvr_ipixel_4_composit(img_stack) + call dealloc_depth_pixel_composit(img_stack) + end if +! + end subroutine s_set_pvr_stencil_buffer +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + integer(kind = kint) function & + & num_parallel_stencil_buffer(stencil_wk) +! + type(stencil_buffer_work), intent(in) :: stencil_wk +! + integer(kind = kint) :: ip, ist, ipix, num +! +! + num_parallel_stencil_buffer = 0 + do ip = 1, nprocs + ist = stencil_wk%istack_recv_image(ip-1) + num = stencil_wk%istack_recv_image(ip) - ist + if(num .le. 0) cycle +! + ipix = stencil_wk%item_recv_image(ist+1) + if(stencil_wk%irank_4_composit(ipix) .eq. my_rank) then + num_parallel_stencil_buffer = num + exit + end if + end do +! + end function num_parallel_stencil_buffer +! +! --------------------------------------------------------------------- +! + subroutine set_global_pixel_4_composit & + & (stencil_wk, npixel_4_composit, num_pixel_xy, & + & ipixel_4_composit, item_4_composit) +! + type(stencil_buffer_work), intent(in) :: stencil_wk + integer(kind = kint), intent(in) :: npixel_4_composit + integer(kind = kint), intent(in) :: num_pixel_xy +! + integer(kind = kint), intent(inout) & + & :: ipixel_4_composit(npixel_4_composit) + integer(kind = kint), intent(inout) & + & :: item_4_composit(num_pixel_xy) +! + integer(kind = kint) :: ip, inum, ipix, ist +! +! +!$omp parallel workshare + item_4_composit(1:num_pixel_xy) = 0 +!$omp end parallel workshare +! + do ip = 1, nprocs + ist = stencil_wk%istack_recv_image(ip-1) + ipix = stencil_wk%item_recv_image(ist+1) + if(stencil_wk%irank_4_composit(ipix) .eq. my_rank) then + do inum = 1, npixel_4_composit + ipix = stencil_wk%item_recv_image(ist+inum) + ipixel_4_composit(inum) = ipix + item_4_composit(ipix) = inum + end do + exit + end if + end do +! + end subroutine set_global_pixel_4_composit +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine check_composit_communication & + & (id_file, pvr_start, img_composit_tbl, img_stack) +! + integer(kind = kint), intent(in) :: id_file + type(pvr_ray_start_type), intent(in) :: pvr_start + type(calypso_comm_table), intent(in) :: img_composit_tbl + type(pvr_image_stack_table), intent(in) :: img_stack +! + integer(kind = kint) :: inum, ipix, icou, ist, num, ip +! +! + write(id_file,*) 'nrank_export', img_composit_tbl%nrank_export + do ip = 1, img_composit_tbl%nrank_export + ist = img_composit_tbl%istack_export(ip-1) + num = img_composit_tbl%istack_export(ip) - ist + write(id_file,*) 'img_composit_tbl%irank_export', & + & ip, img_composit_tbl%irank_export(ip), ist, num + do inum = 1, num + icou = img_composit_tbl%item_export(ist+inum) + write(id_file,*) inum, icou, & + & pvr_start%id_pixel_start(icou), & + & pvr_start%xx4_pvr_ray_start(3,icou) + end do + end do +! + write(id_file,*) 'img_composit_tbl%ntot_import', & + & img_composit_tbl%ntot_import, img_stack%npixel_4_composit + do ipix = 1, img_stack%npixel_4_composit + ist = img_stack%istack_composition(ipix-1) + num = img_stack%istack_composition(ipix) - ist + write(id_file,*) 'img_composit_tbl%item_import', ist, num + do inum = 1, num + icou = img_composit_tbl%item_import(ist+inum) + write(id_file,*) inum, ipix, icou, & + & img_stack%ipix_4_composit(icou), & + & img_stack%depth_pixel_composit(icou) + end do + end do + close(id_file) +! + end subroutine check_composit_communication +! +! --------------------------------------------------------------------- +! + subroutine check_img_output_communication(id_file, & + & img_stack, img_output_tbl, stencil_wk, & + & num_pixel_xy, num_pixel_recv, SR_sig, SR_i) +! + use calypso_SR_type +! + integer(kind = kint), intent(in) :: id_file + type(pvr_image_stack_table), intent(in) :: img_stack + type(calypso_comm_table), intent(in) :: img_output_tbl + type(stencil_buffer_work), intent(in) :: stencil_wk + integer(kind = kint), intent(in) :: num_pixel_xy, num_pixel_recv +! + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_int_buffer), intent(inout) :: SR_i +! + integer(kind = kint), allocatable :: ipixel_check(:) + integer(kind = kint) :: ipix +! +! + allocate(ipixel_check(num_pixel_recv)) + call calypso_SR_type_int(0, img_output_tbl, & + & img_stack%npixel_4_composit, num_pixel_recv, & + & img_stack%ipixel_4_composit, ipixel_check, SR_sig, SR_i) +! + write(id_file,*) 'ipixel_check', num_pixel_recv, num_pixel_xy + do ipix = 1, num_pixel_recv + write(id_file,*) & + ipix, ipixel_check(ipix), stencil_wk%irev_recv_image(ipix) + end do + deallocate(ipixel_check) +! + end subroutine check_img_output_communication +! +! --------------------------------------------------------------------- +! + end module set_pvr_stencil_buffer diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_rgb_colors.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_rgb_colors.f90 new file mode 100644 index 00000000..ec15ada3 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_rgb_colors.f90 @@ -0,0 +1,157 @@ +!>@file set_rgb_colors.F90 +!!@brief module set_rgb_colors +!! +!!@author H. Matsui +!!@date Programmed in Apr., 2024 +! +!>@brief Normalization for color mapping +!! +!!@verbatim +!! subroutine normalize_by_linear(dat_min, dat_max, value, & +!! & colordat) +!! real(kind = kreal), intent(in) :: value +!! real(kind = kreal), intent(in) :: dat_min, dat_max +!! real(kind = kreal), intent(out) :: colordat +!! subroutine normalize_by_linear_segment(num_point, datamap_param,& +!! & value, colordat) +!! real(kind = kreal), intent(in) :: value +!! integer(kind = kint), intent(in) :: num_point +!! real(kind = kreal), intent(in) :: datamap_param(2,num_point) +!! real(kind = kreal), intent(out) :: colordat +!! +!! subroutine restore_linear_normalize(value_rgb, & +!! & mincolor, maxcolor, value) +!! subroutine restore_segment_normalize(value_rgb, & +!! & mincolor, maxcolor, num_point, datamap_param, value) +!! real(kind = kreal), intent(in) :: value_rgb +!! real(kind = kreal), intent(in) :: mincolor, maxcolor +!! integer(kind = kint), intent(in) :: num_point +!! real(kind = kreal), intent(in) :: datamap_param(2,num_point) +!! real(kind = kreal), intent(out) :: value +!!@endverbatim + module set_rgb_colors +! + use m_precision + use m_constants +! + implicit none +! + real(kind = kreal), parameter :: EPSILON = 1.0d-11 + private :: EPSILON +! +! +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine normalize_by_linear(dat_min, dat_max, value, & + & colordat) +! + real(kind = kreal), intent(in) :: value + real(kind = kreal), intent(in) :: dat_min, dat_max +! + real(kind = kreal), intent(out) :: colordat +! +! + if( abs(dat_max-dat_min) .gt. EPSILON) then + if(value .lt. dat_min) then + colordat = zero + else if(value .gt. dat_max) then + colordat = one + else + colordat = (value-dat_min) / (dat_max-dat_min) + end if + end if +! + end subroutine normalize_by_linear +! +! ---------------------------------------------------------------------- +! + subroutine normalize_by_linear_segment(num_point, datamap_param, & + & value, colordat) +! + real(kind = kreal), intent(in) :: value + integer(kind = kint), intent(in) :: num_point + real(kind = kreal), intent(in) :: datamap_param(2,num_point) +! + real(kind = kreal), intent(out) :: colordat +! + integer(kind = kint) :: i +! +! + if(value .lt. datamap_param(1,1)) then + colordat = zero + else if(value .gt. datamap_param(1,num_point)) then + colordat = one + else + do i = 1, num_point-1 + if(value.ge.datamap_param(1,i) & + & .and. value.le.datamap_param(1,i+1)) then + colordat = datamap_param(2,i) & + & + (datamap_param(2,i+1)-datamap_param(2,i)) & + & * (value - datamap_param(1,i)) & + & / (datamap_param(1,i+1)-datamap_param(1,i)) + exit + end if + end do + end if +! + end subroutine normalize_by_linear_segment +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine restore_linear_normalize(value_rgb, & + & mincolor, maxcolor, value) +! + real(kind = kreal), intent(in) :: value_rgb + real(kind = kreal), intent(in) :: mincolor, maxcolor +! + real(kind = kreal), intent(out) :: value +! +! + if( abs(maxcolor-mincolor) .gt. EPSILON) then + value = value_rgb * (maxcolor - mincolor) + mincolor + end if +! + end subroutine restore_linear_normalize +! +! ---------------------------------------------------------------------- +! + subroutine restore_segment_normalize(value_rgb, & + & mincolor, maxcolor, num_point, datamap_param, value) +! + real(kind = kreal), intent(in) :: value_rgb + real(kind = kreal), intent(in) :: mincolor, maxcolor + integer(kind = kint), intent(in) :: num_point + real(kind = kreal), intent(in) :: datamap_param(2,num_point) +! + real(kind = kreal), intent(out) :: value +! + integer(kind = kint) :: i +! +! + if(value_rgb .lt. datamap_param(2,1)) then + value = mincolor + else if(value_rgb .gt. datamap_param(2,num_point)) then + value = maxcolor + else + do i = 1, num_point + if(value .ge. datamap_param(2,i) & + & .and. value .le. datamap_param(2,i+1)) then + value = datamap_param(1,i) & + & + (datamap_param(1,i+1) - datamap_param(1,i)) & + & * (value_rgb - datamap_param(2,i)) & + & / (datamap_param(2,i+1) - datamap_param(2,i)) + end if + end do + end if +! + end subroutine restore_segment_normalize +! +! ---------------------------------------------------------------------- +! + end module set_rgb_colors diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/set_rgba_4_each_pixel.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/set_rgba_4_each_pixel.f90 new file mode 100644 index 00000000..a711aed2 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/set_rgba_4_each_pixel.f90 @@ -0,0 +1,389 @@ +!>@file set_rgba_4_each_pixel.f90 +!! module set_rgba_4_each_pixel +!! +!!@author H. Matsui +!!@date Programmed in July. 2006 +! +!> @brief Structures for parameteres for volume rendering +!! +!!@verbatim +!! subroutine s_set_rgba_4_each_pixel(viewpoint_vec, & +!! & x4in_model, x4out_model, c_data, grad, & +!! & color_param, rgba_pixel) +!! subroutine color_plane_with_light & +!! & (viewpoint_vec, xout_model, c_data, grad, & +!! & opa_current, color_param, rgba_pixel) +!! subroutine black_plane_with_light(viewpoint_vec, xout_model, & +!! & grad, opa_current, color_param, rgba_pixel) +!! subroutine plane_rendering_with_light(viewpoint_vec, x4_model, & +!! & surf_normal, opa_current, color_param, rgba_pixel) +!! subroutine surface_rendering_with_light & +!! & (viewpoint_vec, x4_model, surf_normal, color_surf, & +!! & opa_current, color_param, rgba_pixel) +!! +!! subroutine compute_opacity(transfer_function_style, opa_value, & +!! & num_of_features, fea_point, value, opacity_local) +!! +!! subroutine phong_reflection(view_point_d, & +!! & num_of_lights, light_point, norm_v, k_ads, & +!! & in_point, out_point, color, rgb) +!! +!! subroutine composite_alpha_blending(rgba_src, rgba_tgt) +!! subroutine alpha_blending(rgba_src, rgba_tgt) +!!@endverbatim +! + module set_rgba_4_each_pixel +! + use m_precision + use m_constants + use t_pvr_colormap_parameter +! + implicit none +! + real(kind = kreal), parameter :: EPSILON = 1.0d-9 + private :: EPSILON +! + character(len = kchara), parameter & + & :: hd_intensity = 'intense_chenge' + character(len = kchara), parameter & + & :: hd_pointlinear = 'point_linear' + integer(kind = kint), parameter :: iflag_anbient = 1 + integer(kind = kint), parameter :: iflag_intense = 2 + integer(kind = kint), parameter :: iflag_pointlinear = 5 +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine s_set_rgba_4_each_pixel(viewpoint_vec, & + & x4in_model, x4out_model, c_data, grad, & + & color_param, rgba_pixel) +! + use set_color_4_pvr +! + real(kind = kreal), intent(in) :: viewpoint_vec(3) + real(kind = kreal), intent(in) :: c_data, grad(3) + real(kind = kreal), intent(in) :: x4in_model(4), x4out_model(4) + type(pvr_colormap_parameter), intent(in) :: color_param +! + real(kind = kreal), intent(inout) :: rgba_pixel(4) +! + integer(kind = kint) :: num_of_features + real(kind = kreal) :: color(3) + real(kind = kreal) :: anb_opacity, opa_current, ray_length + real(kind = kreal), allocatable :: rgb(:) +! +! + ray_length = sqrt((x4out_model(1)-x4in_model(1))**2 & + & + (x4out_model(2)-x4in_model(2))**2 & + & + (x4out_model(3)-x4in_model(3))**2) +! + num_of_features = color_param%num_opacity_pnt + anb_opacity = color_param%pvr_opacity_param(1,num_of_features) +! + call compute_opacity(color_param%id_pvr_color(3), anb_opacity, & + & num_of_features, color_param%pvr_opacity_param, & + & c_data, opa_current) +! + call value_to_rgb(color_param%id_pvr_color(2), & + & color_param%id_pvr_color(1), color_param%num_pvr_datamap_pnt, & + & color_param%pvr_datamap_param, c_data, color) +! +! + allocate(rgb(4)) + call phong_reflection(viewpoint_vec, & + & color_param%num_pvr_lights, color_param%xyz_pvr_lights, & + & grad, color_param%pvr_lighting_real, & + & x4in_model(1), x4out_model(1), color, rgb(1)) +! +! rgb(4) = 1.0d0 & +! & - (1.0d0 - opa_current)**(ray_length) + rgb(4) = -ray_length * LOG(1.0d0 - opa_current) +! rgb(4) = ray_length * opa_current + rgb(1:3) = rgb(1:3) * rgb(4) + if(rgb(4) .gt. one) rgb(4) = one + if(rgb(4) .lt. zero) rgb(4) = zero +! + call composite_alpha_blending(rgb, rgba_pixel) + deallocate(rgb) +! + end subroutine s_set_rgba_4_each_pixel +! +! ---------------------------------------------------------------------- +! + subroutine color_plane_with_light & + & (viewpoint_vec, x4out_model, c_data, grad, & + & opa_current, color_param, rgba_pixel) +! + use set_color_4_pvr +! + real(kind = kreal), intent(in) :: viewpoint_vec(3) + real(kind = kreal), intent(in) :: c_data, grad(3) + real(kind = kreal), intent(in) :: x4out_model(4) + real(kind = kreal), intent(in) :: opa_current + type(pvr_colormap_parameter), intent(in) :: color_param +! + real(kind = kreal), intent(inout) :: rgba_pixel(4) +! + real(kind = kreal) :: color(3) + real(kind = kreal), allocatable :: rgb(:) +! +! + call value_to_rgb(color_param%id_pvr_color(2), & + & color_param%id_pvr_color(1), color_param%num_pvr_datamap_pnt, & + & color_param%pvr_datamap_param, c_data, color) +! +! + allocate(rgb(4)) + call phong_reflection(viewpoint_vec, & + & color_param%num_pvr_lights, color_param%xyz_pvr_lights, & + & grad, color_param%pvr_lighting_real, & + & x4out_model(1), x4out_model(1), color, rgb(1)) +! + rgb(1:3) = rgb(1:3) * opa_current + rgb(4) = opa_current +! + call composite_alpha_blending(rgb, rgba_pixel) + deallocate(rgb) +! + end subroutine color_plane_with_light +! +! ---------------------------------------------------------------------- +! + subroutine black_plane_with_light(viewpoint_vec, x4out_model, & + & grad, opa_current, color_param, rgba_pixel) +! + use set_color_4_pvr +! + real(kind = kreal), intent(in) :: viewpoint_vec(3) + real(kind = kreal), intent(in) :: grad(3) + real(kind = kreal), intent(in) :: x4out_model(4) + real(kind = kreal), intent(in) :: opa_current + type(pvr_colormap_parameter), intent(in) :: color_param +! + real(kind = kreal), intent(inout) :: rgba_pixel(4) +! + real(kind = kreal), parameter :: black(3) = (/0.0, 0.0, 0.0/) +! + call surface_rendering_with_light(viewpoint_vec, x4out_model, & + & grad, black, opa_current, color_param, rgba_pixel) +! + end subroutine black_plane_with_light +! +! ---------------------------------------------------------------------- +! + subroutine plane_rendering_with_light(viewpoint_vec, x4_model, & + & surf_normal, opa_current, color_param, rgba_pixel) +! + use set_color_4_pvr +! + real(kind = kreal), intent(in) :: viewpoint_vec(3) + real(kind = kreal), intent(in) :: x4_model(4) + real(kind = kreal), intent(in) :: surf_normal(3) + real(kind = kreal), intent(in) :: opa_current + type(pvr_colormap_parameter), intent(in) :: color_param +! + real(kind = kreal), intent(inout) :: rgba_pixel(4) +! + real(kind = kreal), parameter :: color(3) = (/0.2, 0.2, 0.2/) +! + call surface_rendering_with_light(viewpoint_vec, x4_model, & + & surf_normal, color, opa_current, color_param, rgba_pixel) +! + end subroutine plane_rendering_with_light +! +! ---------------------------------------------------------------------- +! + subroutine surface_rendering_with_light & + & (viewpoint_vec, x4_model, surf_normal, color_surf, & + & opa_current, color_param, rgba_pixel) +! + use set_color_4_pvr +! + real(kind = kreal), intent(in) :: viewpoint_vec(3) + real(kind = kreal), intent(in) :: x4_model(4) + real(kind = kreal), intent(in) :: surf_normal(3) + real(kind = kreal), intent(in) :: color_surf(3) + real(kind = kreal), intent(in) :: opa_current + type(pvr_colormap_parameter), intent(in) :: color_param +! + real(kind = kreal), intent(inout) :: rgba_pixel(4) +! + real(kind = kreal), allocatable :: rgb(:) +! +! + allocate(rgb(4)) +! + call phong_reflection(viewpoint_vec, & + & color_param%num_pvr_lights, color_param%xyz_pvr_lights, & + & surf_normal, color_param%pvr_lighting_real, & + & x4_model(1), x4_model(1), color_surf, rgb(1)) +! + rgb(1:3) = rgb(1:3) * opa_current + rgb(4) = opa_current +! + call composite_alpha_blending(rgb, rgba_pixel) + deallocate(rgb) +! + end subroutine surface_rendering_with_light +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine compute_opacity(transfer_function_style, opa_value, & + & num_of_features, fea_point, value, opacity_local) +! + integer(kind = kint), intent(in) :: transfer_function_style + real(kind = kreal), intent(in) :: opa_value + integer(kind = kint), intent(in) :: num_of_features + real(kind = kreal), intent(in) :: fea_point(3,num_of_features) + real(kind = kreal), intent(in) :: value +! + real(kind = kreal), intent(out) :: opacity_local +! + integer(kind = kint) :: i, min_type + real(kind = kreal) :: mint, t +! +! + mint = 1.0d-17 + min_type = 1 + opacity_local = zero + if (transfer_function_style .eq. iflag_anbient) then + opacity_local = opa_value + else if(transfer_function_style .eq. iflag_pointlinear) then + opacity_local = opa_value + do i = 1, num_of_features-1 + if(value .le. fea_point(1,1)) then + opacity_local = fea_point(3,1) + exit + else if(value .ge. fea_point(1,num_of_features)) then + opacity_local = fea_point(3,num_of_features) + exit + else if(value.ge.fea_point(1,i) & + & .and. value.le.fea_point(1,i+1)) then + opacity_local = fea_point(3,i) & + & + (fea_point(3,i+1) - fea_point(3,i)) & + & * (value - fea_point(1,i)) & + & / (fea_point(1,i+1) - fea_point(1,i)) + exit + end if + end do + end if +! + end subroutine compute_opacity +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine phong_reflection(view_point_d, & + & num_of_lights, light_point, norm_v, k_ads, & + & in_point4, out_point4, color, rgb) +! + real(kind = kreal), intent(in) :: view_point_d(3) + real(kind = kreal), intent(in) :: k_ads(3) + real(kind = kreal), intent(in) :: norm_v(3) + integer(kind = kint), intent(in) :: num_of_lights + real(kind = kreal), intent(in) :: light_point(3,num_of_lights) +! + real(kind = kreal), intent(in) :: in_point4(4) + real(kind = kreal), intent(in) :: out_point4(4) +! + real(kind = kreal), intent(in) :: color(3) +! + real(kind = kreal), intent(inout) :: rgb(3) +! + integer(kind = kint) :: j + real(kind = kreal) :: cosalpha, costheta + real(kind = kreal) :: lp_norm, vp_norm, hp_norm, norm + real(kind = kreal) :: inprodLN, inprodVN, inprodHN + real(kind = kreal) :: coef + real(kind = kreal), allocatable :: lp(:), vp(:), hp(:), vo(:) + real(kind = kreal) :: x4_mid(4) +! + allocate(vo(3)) + allocate(lp(3), vp(3), hp(3)) +! + rgb(1:3) = zero + x4_mid(1:4) = half*(out_point4(1:4) + in_point4(1:4)) + vo(1:3) = view_point_d(1:3) - norm_v(1:3) +! + do j = 1, num_of_lights + lp(1:3) = light_point(1:3,j) - x4_mid(1:3) + vp(1:3) = - x4_mid(1:3) + hp(1:3) = (lp(1:3) + vp(1:3)) / two +! + lp_norm = sqrt( lp(1)*lp(1) + lp(2)*lp(2) + lp(3)*lp(3) ) + vp_norm = sqrt( vp(1)*vp(1) + vp(2)*vp(2) + vp(3)*vp(3) ) + hp_norm = sqrt( hp(1)*hp(1) + hp(2)*hp(2) + hp(3)*hp(3) ) + norm = sqrt( vo(1)*vo(1) + vo(2)*vo(2) + vo(3)*vo(3) ) +! + if(abs(lp_norm) .gt. EPSILON) lp(1:3) = lp(1:3) / lp_norm + if(abs(vp_norm) .gt. EPSILON) vp(1:3) = vp(1:3) / vp_norm + if(abs(hp_norm) .gt. EPSILON) hp(1:3) = hp(1:3) / hp_norm + if(abs(norm) .gt. EPSILON) vo(1:3) = vo(1:3) / norm +! + inprodLN = vo(1)*lp(1) + vo(2)*lp(2) + vo(3)*lp(3) + inprodVN = vo(1)*vp(1) + vo(2)*vp(2) + vo(3)*vp(3) + inprodHN = vo(1)*hp(1) + vo(2)*hp(2) + vo(3)*hp(3) +! + cosalpha = inprodLN + costheta = inprodLN*inprodVN & + & - sqrt(one-inprodLN*inprodLN) & + & *sqrt(one-inprodVN*inprodVN) + cosalpha = abs(cosalpha) +! + if(cosalpha .gt. zero) then + coef = k_ads(1) + k_ads(2)*cosalpha + k_ads(3)*costheta**6 + else + coef = k_ads(1) + end if + rgb(1:3) = rgb(1:3) + color(1:3) * coef + end do + deallocate(vo, lp, vp, hp) +! + end subroutine phong_reflection +! +! ---------------------------------------------------------------------- +! + subroutine composite_alpha_blending(rgba_src, rgba_tgt) +! + real(kind = kreal), intent(in) :: rgba_src(4) + real(kind = kreal), intent(inout) :: rgba_tgt(4) +! +! This us is backward casting!! +! + rgba_tgt(4) = rgba_src(4) + rgba_tgt(4) * (one - rgba_src(4)) + rgba_tgt(1:3) = rgba_src(1:3) & + & + rgba_tgt(1:3) * (one - rgba_src(4)) +! + end subroutine composite_alpha_blending +! +! ---------------------------------------------------------------------- +! + subroutine alpha_blending(rgba_src, rgba_tgt) +! + real(kind = kreal), intent(in) :: rgba_src(4) + real(kind = kreal), intent(inout) :: rgba_tgt(4) +! + real(kind = kreal) :: rgba_bck(4), a_rgba +! +! + rgba_bck(1:4) = rgba_tgt(1:4) +! + rgba_tgt(4) = rgba_src(4) + rgba_bck(4) * (one - rgba_src(4)) + if(rgba_tgt(4) .eq. zero) then + rgba_tgt(1:3) = zero + else + a_rgba = one / rgba_tgt(4) + rgba_tgt(1:3) = rgba_src(1:3) * (rgba_src(4)*a_rgba) & + & + rgba_bck(1:3) * (rgba_bck(4)*a_rgba) & + & * (one - rgba_src(4)) + end if +! + end subroutine alpha_blending +! +! ---------------------------------------------------------------------- +! + end module set_rgba_4_each_pixel diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_MPI_quilt_bitmap_IO.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_MPI_quilt_bitmap_IO.f90 new file mode 100644 index 00000000..afaa77f0 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_MPI_quilt_bitmap_IO.f90 @@ -0,0 +1,242 @@ +!>@file t_MPI_quilt_bitmap_IO.f90 +!!@brief module t_MPI_quilt_bitmap_IO +!! +!!@author H. Matsui +!!@date Programmed on May., 2021 +!! +!>@brief Quilt format bitmap data IO with MPI-IO +!! +!!@verbatim +!! subroutine init_quilt_rgb_images(file_prefix, iflag_gz, & +!! & n_column_row, npixel_xy, quilt_d) +!! character(len = kchara), intent(in) :: file_prefix +!! integer(kind = kint), intent(in) :: iflag_gz +!! integer(kind = kint), intent(in) :: n_column_row(2) +!! integer(kind = kint), intent(in) :: npixel_xy(2) +!! type(MPI_quilt_bitmap_IO), intent(inout) :: quilt_d +!! +!! subroutine alloc_quilt_rgb_images(npixel_xy, quilt_d) +!! subroutine dealloc_quilt_rgb_images(quilt_d) +!! integer(kind = kint), intent(in) :: npixel_xy(2) +!! type(MPI_quilt_bitmap_IO), intent(inout) :: quilt_d +!! +!! subroutine alloc_each_rgb_image(npix_xy, image) +!! subroutine dealloc_each_rgb_image(image) +!! integer(kind = kint), intent(in) :: npix_xy(2) +!! type(each_rgb_image), intent(inout) :: image +!!@endverbatim +! + module t_MPI_quilt_bitmap_IO +! + use m_precision + use m_constants + use calypso_mpi +! + implicit none +! + type each_rgb_image +!> Independent file prefix + character(len = kchara) :: each_prefix +!> File format flag (BMP or PNG) + integer(kind = kint) :: image_format +!> Horizontal number of pixel + integer(kind = kint) :: npix_xy(2) + character(len=1), allocatable :: rgb(:,:,:) + end type each_rgb_image +! + type MPI_quilt_bitmap_IO +!> Sequence of file prefix + character(len = kchara) :: image_seq_prefix +!> File format flag (BMP, PNG, or Quilt BMP) + integer(kind = kint) :: image_seq_format +! +!> Number of images + integer(kind = kint) :: n_image +!> Number of row and columns of images + integer(kind = kint) :: n_column_row(2) +! +!> Number of images in each process + integer(kind = kint) :: num_image_lc +!> Number of pixel (Horizontal, Vertical) + integer(kind = kint) :: npixel_xy(2) +!> RGB images + type(each_rgb_image), allocatable :: images(:) +!> Image index in each process + integer(kind = kint), allocatable :: icou_each_pe(:) + end type MPI_quilt_bitmap_IO +! + private :: count_local_image_pe_quilt, set_local_image_pe_quilt +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine init_quilt_rgb_images(file_prefix, iflag_gz, & + & n_column_row, npixel_xy, quilt_d) +! + use set_parallel_file_name + use output_image_sel_4_png +! + character(len = kchara), intent(in) :: file_prefix + integer(kind = kint), intent(in) :: iflag_gz + integer(kind = kint), intent(in) :: n_column_row(2) + integer(kind = kint), intent(in) :: npixel_xy(2) +! + type(MPI_quilt_bitmap_IO), intent(inout) :: quilt_d +! + integer(kind = kint) :: i +! +! + quilt_d%n_column_row(1:2) = n_column_row(1:2) + quilt_d%n_image = n_column_row(1) * n_column_row(2) + call count_local_image_pe_quilt & + & (quilt_d%n_image, quilt_d%num_image_lc) +! + quilt_d%image_seq_prefix = file_prefix + + if(iflag_gz .gt. 0) then + quilt_d%image_seq_format = iflag_QUILT_BMP_GZ + else + quilt_d%image_seq_format = iflag_QUILT_BMP + end if + + quilt_d%npixel_xy(1:2) = npixel_xy(1:2) + call alloc_quilt_rgb_images(quilt_d) + do i = 1, quilt_d%num_image_lc + quilt_d%images(i)%image_format = quilt_d%image_seq_format + quilt_d%images(i)%each_prefix & + & = add_int_suffix(i, quilt_d%image_seq_prefix) + call alloc_each_rgb_image(quilt_d%npixel_xy, quilt_d%images(i)) + end do +! + call set_local_image_pe_quilt(quilt_d%n_image, & + & quilt_d%num_image_lc, quilt_d%icou_each_pe) +! + end subroutine init_quilt_rgb_images +! +! ---------------------------------------------------------------------- +! + subroutine dealloc_quilt_rgb_images(quilt_d) +! + type(MPI_quilt_bitmap_IO), intent(inout) :: quilt_d + integer(kind = kint) :: i +! + do i = 1, quilt_d%num_image_lc + call dealloc_each_rgb_image(quilt_d%images(i)) + end do + deallocate(quilt_d%images, quilt_d%icou_each_pe) +! + end subroutine dealloc_quilt_rgb_images +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine alloc_quilt_rgb_images(quilt_d) +! + type(MPI_quilt_bitmap_IO), intent(inout) :: quilt_d +! +! + allocate(quilt_d%icou_each_pe(quilt_d%num_image_lc)) + allocate(quilt_d%images(quilt_d%num_image_lc)) +! + quilt_d%icou_each_pe(1:quilt_d%num_image_lc) = -1 +! + end subroutine alloc_quilt_rgb_images +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine count_local_image_pe_quilt(num_image, num_image_lc) +! + integer(kind = kint), intent(in) :: num_image + integer(kind = kint), intent(inout) :: num_image_lc +! + integer(kind = kint) :: icou, ip +! + icou = 0 + do ip = 0, num_image-1 + if(mod(ip,nprocs) .eq. my_rank) icou = icou + 1 + end do + num_image_lc = icou +! + end subroutine count_local_image_pe_quilt +! +! ---------------------------------------------------------------------- +! + subroutine set_local_image_pe_quilt & + & (num_image, num_image_lc, icou_each_pe) +! + integer(kind = kint), intent(in) :: num_image + integer(kind = kint), intent(in) :: num_image_lc + integer(kind = kint), intent(inout) & + & :: icou_each_pe(num_image_lc) +! + integer(kind = kint) :: icou, ip +! + icou = 0 + do ip = 0, num_image-1 + if(mod(ip,nprocs) .eq. my_rank) then + icou = icou + 1 + icou_each_pe(icou) = ip + 1 + end if + end do +! + end subroutine set_local_image_pe_quilt +! +! ---------------------------------------------------------------------- +! + subroutine sel_write_seq_image_files(num_image_lc, icou_each_pe, & + & images) +! + use set_parallel_file_name + use output_image_sel_4_png +! + integer(kind = kint), intent(in) :: num_image_lc + integer(kind = kint), intent(in) :: icou_each_pe(num_image_lc) +! + type(each_rgb_image), intent(in) :: images(num_image_lc) +! + integer(kind = kint) :: icou, ip +! + do icou = 1, num_image_lc + ip = icou_each_pe(icou) + write(*,*) ip, '-th output file from process', my_rank + call sel_output_image_file & + & (images(icou)%image_format, images(icou)%each_prefix, & + & images(icou)%npix_xy(1), images(icou)%npix_xy(2), & + & images(icou)%rgb) + end do +! + end subroutine sel_write_seq_image_files +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine alloc_each_rgb_image(npix_xy, image) +! + integer(kind = kint), intent(in) :: npix_xy(2) + type(each_rgb_image), intent(inout) :: image +! + image%npix_xy(1:2) = npix_xy(1:2) + allocate(image%rgb(3,image%npix_xy(1),image%npix_xy(2))) +! + end subroutine alloc_each_rgb_image +! +! ---------------------------------------------------------------------- +! + subroutine dealloc_each_rgb_image(image) +! + type(each_rgb_image), intent(inout) :: image +! + if(allocated(image%rgb) .eqv. .FALSE.) return + deallocate(image%rgb) + image%npix_xy(1:2) = 0 + image%image_format = 0 +! + end subroutine dealloc_each_rgb_image +! +! ---------------------------------------------------------------------- +! + end module t_MPI_quilt_bitmap_IO diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_VIZ_mesh_field.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_VIZ_mesh_field.f90 new file mode 100644 index 00000000..b92b9659 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_VIZ_mesh_field.f90 @@ -0,0 +1,197 @@ + !>@file t_VIZ_mesh_field.f90 +!!@brief module t_VIZ_mesh_field +!! +!!@author H. Matsui +!!@date Programmed in June, 2006 +! +!>@brief Data structuresa for visualizers +!! +!!@verbatim +!! subroutine link_jacobians_4_viz(next_tbl, jacobians, VIZ_DAT) +!! subroutine unlink_jacobians_4_viz(VIZ_DAT) +!! type(mesh_data), intent(inout), target :: geofem +!! type(next_nod_ele_table), intent(in), target :: next_tbl +!! type(jacobians_type), intent(in), target :: jacobians +!! type(VIZ_mesh_field), intent(inout) :: VIZ_DAT +!! subroutine init_mesh_data_for_vizs(elps_VIZ, viz_step, mesh, & +!! & VIZ_DAT, m_SR) +!! type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ +!! type(VIZ_step_params), intent(in) :: viz_step +!! type(mesh_geometry), intent(inout) :: mesh +!! type(VIZ_mesh_field), intent(inout) :: VIZ_DAT +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module t_VIZ_mesh_field +! + use m_precision + use m_machine_parameter +! + use t_comm_table + use t_phys_data + use t_next_node_ele_4_node + use t_shape_functions + use t_jacobians + use t_VIZ_step_parameter + use t_para_double_numbering + use t_parallel_surface_indices + use t_elapsed_labels_4_VIZ +! + implicit none +! +!> Structure of data for visualization + type VIZ_mesh_field +!> Stracture for Jacobians + type(jacobians_type) :: jacobians_v +!> Structure of included element list for each node + type(next_nod_ele_table) :: next_tbl_v +! +!!> Structure of shape function for PVR and fieldline +! type(shape_finctions_at_points) :: spfs +!> Stracture for Jacobians + type(jacobians_type), pointer :: jacobians +!> Structure of neighboring list for each node + type(next_nod_ele_table), pointer :: next_tbl +! +!> Structure of element communication table + type(communication_table) :: ele_comm +!> Double numbering for surface + type(paralell_surface_indices) :: para_surf +! +! +!> Structure of edge communication table + type(communication_table) :: edge_comm +!> Structure of edge communication table + type(communication_table) :: surf_comm +! +!> Double numbering for node + type(node_ele_double_number) :: inod_dbl +!> Double numbering for element + type(node_ele_double_number) :: iele_dbl +!> Double numbering for surface + type(node_ele_double_number) :: isurf_dbl + end type VIZ_mesh_field +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine link_jacobians_4_viz(next_tbl, jacobians, VIZ_DAT) +! + type(next_nod_ele_table), intent(in), target :: next_tbl + type(jacobians_type), intent(in), target :: jacobians + type(VIZ_mesh_field), intent(inout) :: VIZ_DAT +! + VIZ_DAT%next_tbl => next_tbl + VIZ_DAT%jacobians => jacobians +! + end subroutine link_jacobians_4_viz +! +! ---------------------------------------------------------------------- +! + subroutine unlink_jacobians_4_viz(VIZ_DAT) +! + type(VIZ_mesh_field), intent(inout) :: VIZ_DAT +! + nullify(VIZ_DAT%jacobians, VIZ_DAT%next_tbl) +! + end subroutine unlink_jacobians_4_viz +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine init_mesh_data_for_vizs(elps_VIZ, viz_step, mesh, & + & VIZ_DAT, m_SR) +! + use m_work_time + use t_elapsed_labels_4_VIZ + use t_work_time + use int_volume_of_domain + use set_element_id_4_node + use parallel_FEM_mesh_init + use const_element_comm_tables + use const_surface_comm_table + use set_normal_vectors +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(VIZ_step_params), intent(in) :: viz_step +! + type(mesh_geometry), intent(inout) :: mesh + type(VIZ_mesh_field), intent(inout) :: VIZ_DAT + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: iflag +! + iflag = viz_step%FLINE_t%increment + viz_step%LIC_t%increment & + & + viz_step%TRACER_t%increment + if(iflag .gt. 0) then +! ----- Construct Element communication table + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+16) + if(iflag_debug.gt.0) write(*,*)' const_ele_comm_table' + call const_ele_comm_table & + & (mesh%node, mesh%nod_comm, mesh%ele, & + & VIZ_DAT%ele_comm, m_SR) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+16) + end if +! + iflag = viz_step%FLINE_t%increment + viz_step%TRACER_t%increment + if(iflag .gt. 0) then +! ----- Construct Surface communication table + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+16) + if(iflag_debug.gt.0) write(*,*)' const_surf_comm_table' + call const_surf_comm_table(mesh%node, mesh%nod_comm, & + & VIZ_DAT%surf_comm, mesh%surf, m_SR) +! + call alloc_double_numbering(mesh%node%numnod, & + & VIZ_DAT%inod_dbl) + call alloc_double_numbering(mesh%ele%numele, & + & VIZ_DAT%iele_dbl) + call set_node_ele_double_address & + & (mesh%node, mesh%ele, mesh%nod_comm, & + & VIZ_DAT%ele_comm, VIZ_DAT%inod_dbl, VIZ_DAT%iele_dbl, & + & m_SR%SR_sig, m_SR%SR_i) +! + call alloc_double_numbering(mesh%surf%numsurf, & + & VIZ_DAT%isurf_dbl) + call set_ele_double_numbering & + & (mesh%surf%numsurf, mesh%surf%ie_surf(1,1), & + & VIZ_DAT%surf_comm, VIZ_DAT%inod_dbl, VIZ_DAT%isurf_dbl, & + & m_SR%SR_sig, m_SR%SR_i) +! + call init_para_surf_indices & + & (mesh, VIZ_DAT%ele_comm, VIZ_DAT%surf_comm, & + & VIZ_DAT%iele_dbl, VIZ_DAT%isurf_dbl, VIZ_DAT%para_surf, & + & m_SR) +! + call dealloc_double_numbering(VIZ_DAT%isurf_dbl) + call dealloc_double_numbering(VIZ_DAT%iele_dbl) + call dealloc_double_numbering(VIZ_DAT%inod_dbl) + call dealloc_comm_table(VIZ_DAT%surf_comm) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+16) + end if +! +! ----- Construct Edge communication table + iflag = viz_step%PSF_t%increment + viz_step%ISO_t%increment & + & + viz_step%MAP_t%increment + if(iflag .gt. 0) then + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+17) + if(iflag_debug .gt. 0) write(*,*) 'const_edge_comm_table' + call const_edge_comm_table(mesh%node, mesh%nod_comm, & + & VIZ_DAT%edge_comm, mesh%edge, m_SR) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+17) + end if + call calypso_mpi_barrier +! + end subroutine init_mesh_data_for_vizs +! +! ---------------------------------------------------------------------- +! + end module t_VIZ_mesh_field diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_4_pvr.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_4_pvr.f90 new file mode 100644 index 00000000..45a24509 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_4_pvr.f90 @@ -0,0 +1,305 @@ +!>@file t_control_data_4_pvr.f90 +!!@brief module t_control_data_4_pvr +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for parallel volume rendering +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine deallocate_cont_dat_pvr(pvr_ctl) +!! subroutine reset_pvr_update_flags(pvr_ctl) +!! type(pvr_parameter_ctl), intent(inout) :: pvr_ctl +!! +!! subroutine add_field_4_pvr_to_fld_ctl(pvr_ctl, field_ctl) +!! type(pvr_parameter_ctl), intent(in) :: pvr_ctl +!! type(ctl_array_c3), intent(inout) :: field_ctl +!! +!! subroutine dup_pvr_ctl(org_pvr, new_pvr) +!! subroutine copy_pvr_update_flag(org_pvr, new_pvr) +!! type(pvr_parameter_ctl), intent(in) :: org_pvr +!! type(pvr_parameter_ctl), intent(inout) :: new_pvr +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! example of control for Kemo's volume rendering +!! +!!begin volume_rendering (BMP or PNG) +!! updated_sign go +!! pvr_file_prefix pvr_temp +!! pvr_output_format PNG +!! monitoring_mode YES +!! +!! streo_imaging YES +!! anaglyph_switch NO +!! quilt_3d_imaging YES +!!! +!! output_field temperature +!! output_component scalar +!!! +!! begin plot_area_ctl +!! ... +!! end plot_area_ctl +!!! +!! begin view_transform_ctl +!! ... +!! end view_transform_ctl +!! +!! begin lighting_ctl +!! ... +!! end lighting_ctl +!! +!! begin pvr_color_ctl +!! ... +!! end pvr_color_ctl +!!! +!! begin colorbar_ctl +!! ... +!! end colorbar_ctl +!!! +!! array section_ctl +!! file surface_define ctl_psf_eq +!! begin surface_define +!! ... +!! end surface_define +!! end array section_ctl +!!! +!! array isosurface_ctl 2 +!! begin isosurface_ctl +!! isosurf_value 0.3 +!! opacity_ctl 0.9 +!! surface_direction normal +!! end isosurface_ctl +!! ... +!! end array isosurface_ctl +!!! +!! begin snapshot_movie_ctl +!! ... +!! end snapshot_movie_ctl +!!! +!!end volume_rendering +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_control_data_4_pvr +! + use m_precision + use calypso_mpi +! + use m_machine_parameter + use t_read_control_elements + use t_ctl_data_4_view_transfer + use t_control_array_integer + use t_control_array_character + use t_control_array_chara2real + use t_ctl_data_pvr_colormap_bar + use t_ctl_data_pvr_light + use t_ctl_data_pvr_movie + use t_ctl_data_quilt_image + use t_control_data_pvr_sections + use t_control_data_pvr_isosurfs + use t_control_data_pvr_tracers + use t_ctl_data_pvr_area + use skip_comment_f +! + implicit none +! +! +!> Structure of control data for PVR rendering + type pvr_parameter_ctl +!> Control block name + character(len = kchara) :: block_name = 'volume_rendering' +! +!> file name for modelview matrix + character(len=kchara) :: fname_mat_ctl = 'NO_FILE' +!> Structure for modelview marices + type(modeview_ctl) :: mat +! +!> file name for lighting parameter + character(len=kchara) :: fname_pvr_light_c = 'NO_FILE' +!> Structure for lighting + type(pvr_light_ctl) :: light +! +!> file name for colormap and colorbar + character(len=kchara) :: fname_cmap_cbar_c = 'NO_FILE' +!> Structure for colormap and colorbar + type(pvr_colormap_bar_ctl) :: cmap_cbar_c +! +!> Structure for image rotation + type(pvr_movie_ctl) :: movie +!> Structure of quilt image controls + type(quilt_image_ctl) :: quilt_c +! + type(read_character_item) :: updated_ctl +! +!> File prefix of output image file + type(read_character_item) :: file_head_ctl +!> File format of output image file + type(read_character_item) :: file_fmt_ctl + type(read_character_item) :: monitoring_ctl +! + type(read_character_item) :: streo_ctl + type(read_character_item) :: anaglyph_ctl + type(read_character_item) :: quilt_ctl +! +!> Structure for element group list for PVR +!!@n group_4_monitor_ctl%c_tbl: Name of element group for PVR + type(pvr_render_area_ctl) :: render_area_c +! +!> Structure of field name for rendering + type(read_character_item) :: pvr_field_ctl +!> Structure of component name for rendering + type(read_character_item) :: pvr_comp_ctl +! +! +!> constrol structure for section rendering + type(pvr_sections_ctl) :: pvr_scts_c +!> constrol structure for isosurface rendering + type(pvr_isosurfs_ctl) :: pvr_isos_c +!> constrol structure for fieldline rendering + type(pvr_tracers_ctl) :: pvr_flines_c +!> constrol structure for tracer rendering + type(pvr_tracers_ctl) :: pvr_tracers_c +! +! Top level flag + integer(kind = kint) :: i_pvr_ctl = 0 + end type pvr_parameter_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine deallocate_cont_dat_pvr(pvr_ctl) +! + type(pvr_parameter_ctl), intent(inout) :: pvr_ctl +! +! + call reset_pvr_light_flags(pvr_ctl%light) + call reset_quilt_image_ctl(pvr_ctl%quilt_c) + call dealloc_pvr_movie_control_flags(pvr_ctl%movie) +! + call dealloc_view_transfer_ctl(pvr_ctl%mat) + call dealloc_pvr_light_crl(pvr_ctl%light) + call deallocate_pvr_cmap_cbar(pvr_ctl%cmap_cbar_c) +! + call dealloc_pvr_render_area_ctl(pvr_ctl%render_area_c) +! + call dealloc_pvr_isosurfs_ctl(pvr_ctl%pvr_isos_c) + call dealloc_pvr_sections_ctl(pvr_ctl%pvr_scts_c) +! + call dealloc_pvr_tracers_ctl(pvr_ctl%pvr_flines_c) + call dealloc_pvr_tracers_ctl(pvr_ctl%pvr_tracers_c) +! + pvr_ctl%updated_ctl%iflag = 0 + pvr_ctl%file_head_ctl%iflag = 0 + pvr_ctl%file_fmt_ctl%iflag = 0 + pvr_ctl%anaglyph_ctl%iflag = 0 + pvr_ctl%pvr_field_ctl%iflag = 0 + pvr_ctl%pvr_comp_ctl%iflag = 0 +! + pvr_ctl%fname_mat_ctl = 'NO_FILE' + pvr_ctl%fname_pvr_light_c = 'NO_FILE' + pvr_ctl%fname_cmap_cbar_c = 'NO_FILE' +! + pvr_ctl%i_pvr_ctl = 0 +! + end subroutine deallocate_cont_dat_pvr +! +! --------------------------------------------------------------------- +! + subroutine reset_pvr_update_flags(pvr_ctl) +! + type(pvr_parameter_ctl), intent(inout) :: pvr_ctl +! + pvr_ctl%i_pvr_ctl = 0 + pvr_ctl%updated_ctl%iflag = 0 +! + end subroutine reset_pvr_update_flags +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine add_field_4_pvr_to_fld_ctl(pvr_ctl, field_ctl) +! + use t_control_array_character3 + use add_nodal_fields_ctl +! + type(pvr_parameter_ctl), intent(in) :: pvr_ctl + type(ctl_array_c3), intent(inout) :: field_ctl +! +! + if(pvr_ctl%pvr_field_ctl%iflag .gt. 0) then + call add_viz_name_ctl & + & (pvr_ctl%pvr_field_ctl%charavalue, field_ctl) + end if +! + end subroutine add_field_4_pvr_to_fld_ctl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dup_pvr_ctl(org_pvr, new_pvr) +! + use t_ctl_data_4_view_transfer + use bcast_control_arrays +! + type(pvr_parameter_ctl), intent(in) :: org_pvr + type(pvr_parameter_ctl), intent(inout) :: new_pvr +! +! + new_pvr%block_name = org_pvr%block_name + new_pvr%i_pvr_ctl = org_pvr%i_pvr_ctl + new_pvr%fname_mat_ctl = org_pvr%fname_mat_ctl + new_pvr%fname_cmap_cbar_c = org_pvr%fname_cmap_cbar_c + new_pvr%fname_pvr_light_c = org_pvr%fname_pvr_light_c +! + call dup_view_transfer_ctl(org_pvr%mat, new_pvr%mat) +! + call dup_pvr_isosurfs_ctl(org_pvr%pvr_isos_c, new_pvr%pvr_isos_c) + call dup_pvr_sections_ctl(org_pvr%pvr_scts_c, new_pvr%pvr_scts_c) +! + call dup_pvr_tracers_ctl(org_pvr%pvr_flines_c, & + & new_pvr%pvr_flines_c) + call dup_pvr_tracers_ctl(org_pvr%pvr_tracers_c, & + & new_pvr%pvr_tracers_c) +! + call dup_lighting_ctl(org_pvr%light, new_pvr%light) + call dup_pvr_cmap_cbar(org_pvr%cmap_cbar_c, new_pvr%cmap_cbar_c) +! + call dup_quilt_image_ctl(org_pvr%quilt_c, new_pvr%quilt_c) + call dup_pvr_movie_control_flags(org_pvr%movie, new_pvr%movie) + call dup_pvr_render_area_ctl(org_pvr%render_area_c, & + & new_pvr%render_area_c) +! + call copy_chara_ctl(org_pvr%updated_ctl, new_pvr%updated_ctl) + call copy_chara_ctl(org_pvr%file_head_ctl, new_pvr%file_head_ctl) + call copy_chara_ctl(org_pvr%file_fmt_ctl, new_pvr%file_fmt_ctl) + call copy_chara_ctl(org_pvr%monitoring_ctl, & + & new_pvr%monitoring_ctl) +! + call copy_chara_ctl(org_pvr%streo_ctl, new_pvr%streo_ctl) + call copy_chara_ctl(org_pvr%anaglyph_ctl, new_pvr%anaglyph_ctl) + call copy_chara_ctl(org_pvr%quilt_ctl, new_pvr%quilt_ctl) +! + call copy_chara_ctl(org_pvr%pvr_field_ctl, new_pvr%pvr_field_ctl) + call copy_chara_ctl(org_pvr%pvr_comp_ctl, new_pvr%pvr_comp_ctl) +! + end subroutine dup_pvr_ctl +! +! --------------------------------------------------------------------- +! + subroutine copy_pvr_update_flag(org_pvr, new_pvr) +! + type(pvr_parameter_ctl), intent(in) :: org_pvr + type(pvr_parameter_ctl), intent(inout) :: new_pvr +! +! + call copy_chara_ctl(org_pvr%updated_ctl, new_pvr%updated_ctl) +! + end subroutine copy_pvr_update_flag +! +! --------------------------------------------------------------------- +! + end module t_control_data_4_pvr diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvr_isosurfs.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvr_isosurfs.f90 new file mode 100644 index 00000000..71e95134 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvr_isosurfs.f90 @@ -0,0 +1,294 @@ +!>@file t_control_data_pvr_isosurfs.f90 +!!@brief module t_control_data_pvr_isosurfs +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for parallel volume rendering +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine read_pvr_isosurfs_ctl & +!! & (id_control, hd_block, pvr_isos_c, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_c +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_isosurfs_ctl & +!! & (id_control, hd_block, pvr_isos_c, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_isosurfs_ctl), intent(in) :: pvr_isos_c +!! integer(kind = kint), intent(inout) :: level +!! subroutine alloc_pvr_isosurfs_ctl(pvr_isos_c) +!! subroutine dealloc_pvr_isosurfs_ctl(pvr_isos_c) +!! subroutine init_pvr_isosurfs_ctl(hd_block, pvr_isos_c) +!! type(buffer_for_control), intent(inout) :: c_buf +!! +!! subroutine dup_pvr_isosurfs_ctl(org_pvr_iso_c, new_pvr_isos_c) +!! type(pvr_isosurfs_ctl), intent(in) :: org_pvr_iso_c +!! type(pvr_isosurfs_ctl), intent(inout) :: new_pvr_isos_c +!! +!! subroutine append_pvr_isosurf_ctl(idx_in, hd_block, pvr_isos_c) +!! subroutine delete_pvr_isosurf_ctl(idx_in, pvr_isos_c) +!! integer(kind = kint), intent(in) :: idx_in +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array isosurface_ctl +!! begin isosurface_ctl +!! isosurf_value 0.3 +!! opacity_ctl 0.9 +!! surface_direction normal +!! end isosurface_ctl +!! ... +!! end array isosurface_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_control_data_pvr_isosurfs +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_array_character + use t_control_array_real + use t_ctl_data_pvr_isosurface + use skip_comment_f +! + implicit none +! +! + type pvr_isosurfs_ctl +!> Control block name + character(len = kchara) :: block_name = 'isosurface_ctl' +! + integer(kind = kint) :: num_pvr_iso_ctl = 0 + type(pvr_isosurf_ctl), allocatable :: pvr_iso_ctl(:) + end type pvr_isosurfs_ctl +! + private :: reset_pvr_isosurfs_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_pvr_isosurfs_ctl & + & (id_control, hd_block, pvr_isos_c, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_c + type(buffer_for_control), intent(inout) :: c_buf +! + integer(kind = kint) :: n_append +! +! + if(check_array_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(allocated(pvr_isos_c%pvr_iso_ctl)) return + call alloc_pvr_isosurfs_ctl(pvr_isos_c) +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_array_flag(c_buf, hd_block)) exit +! + if(check_begin_flag(c_buf, hd_block)) then + n_append = pvr_isos_c%num_pvr_iso_ctl + call append_pvr_isosurf_ctl(n_append, hd_block, pvr_isos_c) + call read_pvr_isosurface_ctl(id_control, hd_block, & + & pvr_isos_c%pvr_iso_ctl(pvr_isos_c%num_pvr_iso_ctl), & + & c_buf) + end if + end do +! + end subroutine read_pvr_isosurfs_ctl +! +! ----------------------------------------------------------------------- +! + subroutine write_pvr_isosurfs_ctl & + & (id_control, hd_block, pvr_isos_c, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_isosurfs_ctl), intent(in) :: pvr_isos_c + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: i +! +! + if(pvr_isos_c%num_pvr_iso_ctl .le. 0) return +! + level = write_array_flag_for_ctl(id_control, level, hd_block) + do i = 1, pvr_isos_c%num_pvr_iso_ctl + call write_pvr_isosurface_ctl(id_control, hd_block, & + & pvr_isos_c%pvr_iso_ctl(i), level) + end do + level = write_end_array_flag_for_ctl(id_control, level, & + & hd_block) +! + end subroutine write_pvr_isosurfs_ctl +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine dealloc_pvr_isosurfs_ctl(pvr_isos_c) +! + type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_c +! +! + if(allocated(pvr_isos_c%pvr_iso_ctl)) then + call reset_pvr_isosurfs_ctl(pvr_isos_c) + deallocate(pvr_isos_c%pvr_iso_ctl) + end if +! + pvr_isos_c%num_pvr_iso_ctl = 0 +! + end subroutine dealloc_pvr_isosurfs_ctl +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_isosurfs_ctl(pvr_isos_c) +! + type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_c +! +! + allocate(pvr_isos_c%pvr_iso_ctl(pvr_isos_c%num_pvr_iso_ctl)) + call reset_pvr_isosurfs_ctl(pvr_isos_c) +! + end subroutine alloc_pvr_isosurfs_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_isosurfs_ctl(hd_block, pvr_isos_c) +! + character(len=kchara), intent(in) :: hd_block + type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_c +! +! + pvr_isos_c%block_name = hd_block + pvr_isos_c%num_pvr_iso_ctl = 0 +! + end subroutine init_pvr_isosurfs_ctl +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine append_pvr_isosurf_ctl(idx_in, hd_block, pvr_isos_c) +! + integer(kind = kint), intent(in) :: idx_in + character(len=kchara), intent(in) :: hd_block + type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_c +! + type(pvr_isosurfs_ctl) :: tmp_pvr_isos + integer(kind = kint) :: i +! +! + if(idx_in.lt.0 .or. idx_in.gt.pvr_isos_c%num_pvr_iso_ctl) return +! + tmp_pvr_isos%num_pvr_iso_ctl = pvr_isos_c%num_pvr_iso_ctl + call alloc_pvr_isosurfs_ctl(tmp_pvr_isos) + do i = 1, tmp_pvr_isos%num_pvr_iso_ctl + call dup_pvr_isosurface_ctl(pvr_isos_c%pvr_iso_ctl(i), & + & tmp_pvr_isos%pvr_iso_ctl(i)) + end do +! + call dealloc_pvr_isosurfs_ctl(pvr_isos_c) + pvr_isos_c%num_pvr_iso_ctl = tmp_pvr_isos%num_pvr_iso_ctl + 1 + call alloc_pvr_isosurfs_ctl(pvr_isos_c) +! + do i = 1, idx_in + call dup_pvr_isosurface_ctl(tmp_pvr_isos%pvr_iso_ctl(i), & + & pvr_isos_c%pvr_iso_ctl(i)) + end do + call init_pvr_isosurface_ctl_label(hd_block, & + & pvr_isos_c%pvr_iso_ctl(idx_in+1)) + do i = idx_in+1, tmp_pvr_isos%num_pvr_iso_ctl + call dup_pvr_isosurface_ctl(tmp_pvr_isos%pvr_iso_ctl(i), & + & pvr_isos_c%pvr_iso_ctl(i+1)) + end do +! + call dealloc_pvr_isosurfs_ctl(tmp_pvr_isos) +! + end subroutine append_pvr_isosurf_ctl +! +! ----------------------------------------------------------------------- +! + subroutine delete_pvr_isosurf_ctl(idx_in, pvr_isos_c) +! + integer(kind = kint), intent(in) :: idx_in + type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_c +! + type(pvr_isosurfs_ctl) :: tmp_pvr_isos + integer(kind = kint) :: i +! +! + if(idx_in.le.0 .or. idx_in.gt.pvr_isos_c%num_pvr_iso_ctl) return +! + tmp_pvr_isos%num_pvr_iso_ctl = pvr_isos_c%num_pvr_iso_ctl + call alloc_pvr_isosurfs_ctl(tmp_pvr_isos) + do i = 1, tmp_pvr_isos%num_pvr_iso_ctl + call dup_pvr_isosurface_ctl(pvr_isos_c%pvr_iso_ctl(i), & + & tmp_pvr_isos%pvr_iso_ctl(i)) + end do +! + call dealloc_pvr_isosurfs_ctl(pvr_isos_c) + pvr_isos_c%num_pvr_iso_ctl = tmp_pvr_isos%num_pvr_iso_ctl - 1 + call alloc_pvr_isosurfs_ctl(pvr_isos_c) +! + do i = 1, idx_in-1 + call dup_pvr_isosurface_ctl(tmp_pvr_isos%pvr_iso_ctl(i), & + & pvr_isos_c%pvr_iso_ctl(i)) + end do + do i = idx_in, tmp_pvr_isos%num_pvr_iso_ctl + call dup_pvr_isosurface_ctl(tmp_pvr_isos%pvr_iso_ctl(i+1), & + & pvr_isos_c%pvr_iso_ctl(i)) + end do +! + call dealloc_pvr_isosurfs_ctl(tmp_pvr_isos) +! + end subroutine delete_pvr_isosurf_ctl +! +! ----------------------------------------------------------------------- +! + subroutine dup_pvr_isosurfs_ctl(org_pvr_isos_c, new_pvr_isos_c) +! + type(pvr_isosurfs_ctl), intent(in) :: org_pvr_isos_c + type(pvr_isosurfs_ctl), intent(inout) :: new_pvr_isos_c +! + integer(kind = kint) :: i +! +! + new_pvr_isos_c%block_name = org_pvr_isos_c%block_name + new_pvr_isos_c%num_pvr_iso_ctl = org_pvr_isos_c%num_pvr_iso_ctl + call alloc_pvr_isosurfs_ctl(new_pvr_isos_c) + do i = 1, org_pvr_isos_c%num_pvr_iso_ctl + call dup_pvr_isosurface_ctl(org_pvr_isos_c%pvr_iso_ctl(i), & + & new_pvr_isos_c%pvr_iso_ctl(i)) + end do +! + end subroutine dup_pvr_isosurfs_ctl +! +! --------------------------------------------------------------------- +! + subroutine reset_pvr_isosurfs_ctl(pvr_isos_ctl) +! + type(pvr_isosurfs_ctl), intent(inout) :: pvr_isos_ctl +! + integer(kind = kint) :: i +! + do i = 1, pvr_isos_ctl%num_pvr_iso_ctl + call reset_pvr_isosurface_ctl(pvr_isos_ctl%pvr_iso_ctl(i)) + end do +! + end subroutine reset_pvr_isosurfs_ctl +! +! --------------------------------------------------------------------- +! + end module t_control_data_pvr_isosurfs diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvr_sections.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvr_sections.f90 new file mode 100644 index 00000000..e280dd1f --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvr_sections.f90 @@ -0,0 +1,291 @@ +!>@file t_control_data_pvr_sections.f90 +!!@brief module t_control_data_pvr_sections +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for parallel volume rendering +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine alloc_pvr_sections_ctl(pvr_scts_c) +!! subroutine dealloc_pvr_sections_ctl(pvr_scts_c) +!! subroutine init_pvr_sections_ctl(hd_block, pvr_scts_c) +!! type(pvr_sections_ctl), intent(inout) :: pvr_scts_c +!! +!! subroutine read_pvr_sections_ctl & +!! & (id_control, hd_block, pvr_scts_c, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_sections_ctl), intent(inout) :: pvr_scts_c +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_sections_ctl & +!! & (id_control, hd_block, pvr_scts_c, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_sections_ctl), intent(in) :: pvr_scts_c +!! integer(kind = kint), intent(inout) :: level +!! +!! subroutine append_pvr_section_ctl(idx_in, hd_block, & +!! & pvr_scts_c) +!! subroutine delete_pvr_section_ctl(idx_in, pvr_scts_c) +!! type(pvr_sections_ctl), intent(inout) :: pvr_scts_c +!! subroutine dup_pvr_sections_ctl(org_pvr_scts_c, new_pvr_scts_c) +!! type(pvr_section_ctl), intent(in) & +!! & :: org_pvr_sect_c(num_pvr_sect) +!! type(pvr_section_ctl), intent(inout) & +!! & :: new_pvr_sect_c(num_pvr_sect) +!! +!! subroutine dealloc_pvr_section_ctl(pvr_sect_ctl) +!! type(pvr_section_ctl), intent(inout) :: pvr_sect_ctl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array section_ctl +!! file surface_define ctl_psf_eq +!! begin surface_define +!! ... +!! end surface_define +!! +!! opacity_ctl 0.9 +!! end array section_ctl +!!! +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_control_data_pvr_sections +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_data_4_psf_def + use t_control_array_real + use t_control_array_character + use t_control_array_chara2real + use t_ctl_data_pvr_section + use skip_comment_f +! + implicit none +! +! + type pvr_sections_ctl +!> Control block name + character(len = kchara) :: block_name = 'section_ctl' +! + integer(kind = kint) :: num_pvr_sect_ctl = 0 + type(pvr_section_ctl), allocatable :: pvr_sect_ctl(:) + end type pvr_sections_ctl +! + private :: dup_pvr_section_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine dealloc_pvr_sections_ctl(pvr_scts_c) +! + type(pvr_sections_ctl), intent(inout) :: pvr_scts_c +! + integer(kind = kint) :: i +! + if(allocated(pvr_scts_c%pvr_sect_ctl) .eqv. .FALSE.) return +! + do i = 1, pvr_scts_c%num_pvr_sect_ctl + call dealloc_pvr_section_ctl(pvr_scts_c%pvr_sect_ctl(i)) + end do + deallocate(pvr_scts_c%pvr_sect_ctl) +! + pvr_scts_c%num_pvr_sect_ctl = 0 +! + end subroutine dealloc_pvr_sections_ctl +! +! ----------------------------------------------------------------------- +! + subroutine alloc_pvr_sections_ctl(pvr_scts_c) +! + type(pvr_sections_ctl), intent(inout) :: pvr_scts_c +! +! + allocate(pvr_scts_c%pvr_sect_ctl(pvr_scts_c%num_pvr_sect_ctl)) +! + end subroutine alloc_pvr_sections_ctl +! +! ----------------------------------------------------------------------- +! + subroutine init_pvr_sections_ctl(hd_block, pvr_scts_c) +! + character(len=kchara), intent(in) :: hd_block + type(pvr_sections_ctl), intent(inout) :: pvr_scts_c +! +! + pvr_scts_c%block_name = hd_block + pvr_scts_c%num_pvr_sect_ctl = 0 +! + end subroutine init_pvr_sections_ctl +! +! ----------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine read_pvr_sections_ctl & + & (id_control, hd_block, pvr_scts_c, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_sections_ctl), intent(inout) :: pvr_scts_c + type(buffer_for_control), intent(inout) :: c_buf +! + integer(kind = kint) :: n_append +! + if(check_array_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(allocated(pvr_scts_c%pvr_sect_ctl)) return + call alloc_pvr_sections_ctl(pvr_scts_c) +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_array_flag(c_buf, hd_block)) exit +! + if(check_begin_flag(c_buf, hd_block)) then + n_append = pvr_scts_c%num_pvr_sect_ctl + call append_pvr_section_ctl(n_append, hd_block, pvr_scts_c) +! + call read_pvr_section_ctl & + & (id_control, hd_block, pvr_scts_c%num_pvr_sect_ctl, & + & pvr_scts_c%pvr_sect_ctl(pvr_scts_c%num_pvr_sect_ctl), & + & c_buf) + end if + end do +! + end subroutine read_pvr_sections_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_pvr_sections_ctl & + & (id_control, hd_block, pvr_scts_c, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_sections_ctl), intent(in) :: pvr_scts_c + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: i +! +! + if(pvr_scts_c%num_pvr_sect_ctl .le. 0) return +! + level = write_array_flag_for_ctl(id_control, level, hd_block) + do i = 1, pvr_scts_c%num_pvr_sect_ctl + write(*,'(3a,i4)') '! ', trim(hd_block), ' No. ', i + call write_pvr_section_ctl(id_control, hd_block, & + & pvr_scts_c%pvr_sect_ctl(i), level) + end do + level = write_end_array_flag_for_ctl(id_control, level, & + & hd_block) +! + end subroutine write_pvr_sections_ctl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine append_pvr_section_ctl(idx_in, hd_block, pvr_scts_c) +! + integer(kind = kint), intent(in) :: idx_in + character(len=kchara), intent(in) :: hd_block + type(pvr_sections_ctl), intent(inout) :: pvr_scts_c +! + type(pvr_sections_ctl) :: tmp_pvr_scts + integer(kind = kint) :: i +! +! + if(idx_in.lt.0 .or. idx_in.gt.pvr_scts_c%num_pvr_sect_ctl) return +! + tmp_pvr_scts%num_pvr_sect_ctl = pvr_scts_c%num_pvr_sect_ctl + call alloc_pvr_sections_ctl(tmp_pvr_scts) + do i = 1, tmp_pvr_scts%num_pvr_sect_ctl + call dup_pvr_section_ctl(pvr_scts_c%pvr_sect_ctl(i), & + & tmp_pvr_scts%pvr_sect_ctl(i)) + end do +! + call dealloc_pvr_sections_ctl(pvr_scts_c) + pvr_scts_c%num_pvr_sect_ctl = tmp_pvr_scts%num_pvr_sect_ctl + 1 + call alloc_pvr_sections_ctl(pvr_scts_c) +! + do i = 1, idx_in + call dup_pvr_section_ctl(tmp_pvr_scts%pvr_sect_ctl(i), & + & pvr_scts_c%pvr_sect_ctl(i)) + end do + call init_pvr_section_ctl_label(hd_block, & + & pvr_scts_c%pvr_sect_ctl(idx_in+1)) + do i = idx_in+1, tmp_pvr_scts%num_pvr_sect_ctl + call dup_pvr_section_ctl(tmp_pvr_scts%pvr_sect_ctl(i), & + & pvr_scts_c%pvr_sect_ctl(i+1)) + end do +! + call dealloc_pvr_sections_ctl(tmp_pvr_scts) +! + end subroutine append_pvr_section_ctl +! +! ----------------------------------------------------------------------- +! + subroutine delete_pvr_section_ctl(idx_in, pvr_scts_c) +! + integer(kind = kint), intent(in) :: idx_in + type(pvr_sections_ctl), intent(inout) :: pvr_scts_c +! + type(pvr_sections_ctl) :: tmp_pvr_scts + integer(kind = kint) :: i +! +! + if(idx_in.le.0 .or. idx_in.gt.pvr_scts_c%num_pvr_sect_ctl) return +! + tmp_pvr_scts%num_pvr_sect_ctl = pvr_scts_c%num_pvr_sect_ctl + call alloc_pvr_sections_ctl(tmp_pvr_scts) + do i = 1, tmp_pvr_scts%num_pvr_sect_ctl + call dup_pvr_section_ctl(pvr_scts_c%pvr_sect_ctl(i), & + & tmp_pvr_scts%pvr_sect_ctl(i)) + end do +! + call dealloc_pvr_sections_ctl(pvr_scts_c) + pvr_scts_c%num_pvr_sect_ctl = tmp_pvr_scts%num_pvr_sect_ctl - 1 + call alloc_pvr_sections_ctl(pvr_scts_c) +! + do i = 1, idx_in-1 + call dup_pvr_section_ctl(tmp_pvr_scts%pvr_sect_ctl(i), & + & pvr_scts_c%pvr_sect_ctl(i)) + end do + do i = idx_in, pvr_scts_c%num_pvr_sect_ctl + call dup_pvr_section_ctl(tmp_pvr_scts%pvr_sect_ctl(i+1), & + & pvr_scts_c%pvr_sect_ctl(i)) + end do +! + call dealloc_pvr_sections_ctl(tmp_pvr_scts) +! + end subroutine delete_pvr_section_ctl +! +! ----------------------------------------------------------------------- +! + subroutine dup_pvr_sections_ctl(org_pvr_scts_c, new_pvr_scts_c) +! + type(pvr_sections_ctl), intent(in) :: org_pvr_scts_c + type(pvr_sections_ctl), intent(inout) :: new_pvr_scts_c +! + integer(kind = kint) :: i +! + new_pvr_scts_c%block_name = org_pvr_scts_c%block_name + new_pvr_scts_c%num_pvr_sect_ctl = org_pvr_scts_c%num_pvr_sect_ctl + call alloc_pvr_sections_ctl(new_pvr_scts_c) +! + do i = 1, org_pvr_scts_c%num_pvr_sect_ctl + call dup_pvr_section_ctl(org_pvr_scts_c%pvr_sect_ctl(i), & + & new_pvr_scts_c%pvr_sect_ctl(i)) + end do +! + end subroutine dup_pvr_sections_ctl +! +! --------------------------------------------------------------------- +! + end module t_control_data_pvr_sections diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvr_tracers.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvr_tracers.f90 new file mode 100644 index 00000000..105fb5dc --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvr_tracers.f90 @@ -0,0 +1,305 @@ +!>@file t_control_data_pvr_tracers.f90 +!!@brief module t_control_data_pvr_tracers +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for parallel volume rendering +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine read_pvr_tracers_ctl & +!! & (id_control, hd_block, pvr_tracers_c, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_tracers_ctl), intent(inout) :: pvr_tracers_c +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_tracers_ctl & +!! & (id_control, hd_block, pvr_tracers_c, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_tracers_ctl), intent(in) :: pvr_tracers_c +!! integer(kind = kint), intent(inout) :: level +!! subroutine alloc_pvr_tracers_ctl(pvr_tracers_c) +!! subroutine dealloc_pvr_tracers_ctl(pvr_tracers_c) +!! subroutine init_pvr_tracerss_ctl(hd_block, pvr_tracers_c) +!! type(buffer_for_control), intent(inout) :: c_buf +!! +!! subroutine dup_pvr_tracers_ctl(org_pvr_iso_c, new_pvr_isos_c) +!! type(pvr_tracers_ctl), intent(in) :: org_pvr_iso_c +!! type(pvr_tracers_ctl), intent(inout) :: new_pvr_isos_c +!! +!! subroutine append_pvr_tracers_ctl(idx_in, hd_block, & +!! & pvr_tracers_c) +!! subroutine delete_pvr_tracers_ctl(idx_in, pvr_tracers_c) +!! integer(kind = kint), intent(in) :: idx_in +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_tracers_ctl), intent(inout) :: pvr_tracers_c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array isosurface_ctl +!! begin isosurface_ctl +!! isosurf_value 0.3 +!! opacity_ctl 0.9 +!! surface_direction normal +!! end isosurface_ctl +!! ... +!! end array isosurface_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_control_data_pvr_tracers +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_array_character + use t_control_array_real + use t_ctl_data_pvr_tracer + use skip_comment_f +! + implicit none +! +! + type pvr_tracers_ctl +!> Control block name + character(len = kchara) :: block_name = 'tracers_ctl' +! + integer(kind = kint) :: num_pvr_tracer_ctl = 0 + type(pvr_tracer_ctl), allocatable :: pvr_trc_c(:) + end type pvr_tracers_ctl +! + private :: reset_pvr_tracers_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_pvr_tracers_ctl & + & (id_control, hd_block, pvr_tracers_c, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_tracers_ctl), intent(inout) :: pvr_tracers_c + type(buffer_for_control), intent(inout) :: c_buf +! + integer(kind = kint) :: n_append +! +! + if(check_array_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(allocated(pvr_tracers_c%pvr_trc_c)) return + call alloc_pvr_tracers_ctl(pvr_tracers_c) +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_array_flag(c_buf, hd_block)) exit +! + if(check_begin_flag(c_buf, hd_block)) then + n_append = pvr_tracers_c%num_pvr_tracer_ctl + call append_pvr_tracers_ctl(n_append, hd_block, & + & pvr_tracers_c) + call read_pvr_tracer_ctl(id_control, hd_block, & + & pvr_tracers_c%pvr_trc_c(pvr_tracers_c%num_pvr_tracer_ctl), & + & c_buf) + end if + end do +! + end subroutine read_pvr_tracers_ctl +! +! ----------------------------------------------------------------------- +! + subroutine write_pvr_tracers_ctl & + & (id_control, hd_block, pvr_tracers_c, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_tracers_ctl), intent(in) :: pvr_tracers_c + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: i +! +! + if(pvr_tracers_c%num_pvr_tracer_ctl .le. 0) return +! + level = write_array_flag_for_ctl(id_control, level, hd_block) + do i = 1, pvr_tracers_c%num_pvr_tracer_ctl + call write_pvr_tracer_ctl(id_control, hd_block, & + & pvr_tracers_c%pvr_trc_c(i), level) + end do + level = write_end_array_flag_for_ctl(id_control, level, & + & hd_block) +! + end subroutine write_pvr_tracers_ctl +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine dealloc_pvr_tracers_ctl(pvr_tracers_c) +! + type(pvr_tracers_ctl), intent(inout) :: pvr_tracers_c +! +! + if(allocated(pvr_tracers_c%pvr_trc_c)) then + call reset_pvr_tracers_ctl(pvr_tracers_c) + deallocate(pvr_tracers_c%pvr_trc_c) + end if +! + pvr_tracers_c%num_pvr_tracer_ctl = 0 +! + end subroutine dealloc_pvr_tracers_ctl +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_tracers_ctl(pvr_tracers_c) +! + type(pvr_tracers_ctl), intent(inout) :: pvr_tracers_c + integer(kind = kint) :: num +! + num = pvr_tracers_c%num_pvr_tracer_ctl + allocate(pvr_tracers_c%pvr_trc_c(num)) + call reset_pvr_tracers_ctl(pvr_tracers_c) +! + end subroutine alloc_pvr_tracers_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_tracerss_ctl(hd_block, pvr_tracers_c) +! + character(len=kchara), intent(in) :: hd_block + type(pvr_tracers_ctl), intent(inout) :: pvr_tracers_c +! +! + pvr_tracers_c%block_name = hd_block + pvr_tracers_c%num_pvr_tracer_ctl = 0 +! + end subroutine init_pvr_tracerss_ctl +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine append_pvr_tracers_ctl(idx_in, hd_block, & + & pvr_tracers_c) +! + integer(kind = kint), intent(in) :: idx_in + character(len=kchara), intent(in) :: hd_block + type(pvr_tracers_ctl), intent(inout) :: pvr_tracers_c +! + type(pvr_tracers_ctl) :: pvr_trcs_tmp + integer(kind = kint) :: i +! +! + if(idx_in.lt.0 & + & .or. idx_in.gt.pvr_tracers_c%num_pvr_tracer_ctl) return +! + pvr_trcs_tmp%num_pvr_tracer_ctl & + & = pvr_tracers_c%num_pvr_tracer_ctl + call alloc_pvr_tracers_ctl(pvr_trcs_tmp) + do i = 1, pvr_trcs_tmp%num_pvr_tracer_ctl + call dup_pvr_tracer_ctl(pvr_tracers_c%pvr_trc_c(i), & + & pvr_trcs_tmp%pvr_trc_c(i)) + end do +! + call dealloc_pvr_tracers_ctl(pvr_tracers_c) + pvr_tracers_c%num_pvr_tracer_ctl & + & = pvr_trcs_tmp%num_pvr_tracer_ctl + 1 + call alloc_pvr_tracers_ctl(pvr_tracers_c) +! + do i = 1, idx_in + call dup_pvr_tracer_ctl(pvr_trcs_tmp%pvr_trc_c(i), & + & pvr_tracers_c%pvr_trc_c(i)) + end do + call init_pvr_tracer_ctl_label(hd_block, & + & pvr_tracers_c%pvr_trc_c(idx_in+1)) + do i = idx_in+1, pvr_trcs_tmp%num_pvr_tracer_ctl + call dup_pvr_tracer_ctl(pvr_trcs_tmp%pvr_trc_c(i), & + & pvr_tracers_c%pvr_trc_c(i+1)) + end do +! + call dealloc_pvr_tracers_ctl(pvr_trcs_tmp) +! + end subroutine append_pvr_tracers_ctl +! +! ----------------------------------------------------------------------- +! + subroutine delete_pvr_tracers_ctl(idx_in, pvr_tracers_c) +! + integer(kind = kint), intent(in) :: idx_in + type(pvr_tracers_ctl), intent(inout) :: pvr_tracers_c +! + type(pvr_tracers_ctl) :: pvr_trcs_tmp + integer(kind = kint) :: i +! +! + if(idx_in.le.0 & + & .or. idx_in.gt.pvr_tracers_c%num_pvr_tracer_ctl) return +! + pvr_trcs_tmp%num_pvr_tracer_ctl & + & = pvr_tracers_c%num_pvr_tracer_ctl + call alloc_pvr_tracers_ctl(pvr_trcs_tmp) + do i = 1, pvr_trcs_tmp%num_pvr_tracer_ctl + call dup_pvr_tracer_ctl(pvr_tracers_c%pvr_trc_c(i), & + & pvr_trcs_tmp%pvr_trc_c(i)) + end do +! + call dealloc_pvr_tracers_ctl(pvr_tracers_c) + pvr_tracers_c%num_pvr_tracer_ctl & + & = pvr_trcs_tmp%num_pvr_tracer_ctl - 1 + call alloc_pvr_tracers_ctl(pvr_tracers_c) +! + do i = 1, idx_in-1 + call dup_pvr_tracer_ctl(pvr_trcs_tmp%pvr_trc_c(i), & + & pvr_tracers_c%pvr_trc_c(i)) + end do + do i = idx_in, pvr_trcs_tmp%num_pvr_tracer_ctl + call dup_pvr_tracer_ctl(pvr_trcs_tmp%pvr_trc_c(i+1), & + & pvr_tracers_c%pvr_trc_c(i)) + end do +! + call dealloc_pvr_tracers_ctl(pvr_trcs_tmp) +! + end subroutine delete_pvr_tracers_ctl +! +! ----------------------------------------------------------------------- +! + subroutine dup_pvr_tracers_ctl(org_pvr_trcs_c, new_pvr_trcs_c) +! + type(pvr_tracers_ctl), intent(in) :: org_pvr_trcs_c + type(pvr_tracers_ctl), intent(inout) :: new_pvr_trcs_c +! + integer(kind = kint) :: i +! +! + new_pvr_trcs_c%block_name = org_pvr_trcs_c%block_name + new_pvr_trcs_c%num_pvr_tracer_ctl & + & = org_pvr_trcs_c%num_pvr_tracer_ctl + call alloc_pvr_tracers_ctl(new_pvr_trcs_c) + do i = 1, org_pvr_trcs_c%num_pvr_tracer_ctl + call dup_pvr_tracer_ctl(org_pvr_trcs_c%pvr_trc_c(i), & + & new_pvr_trcs_c%pvr_trc_c(i)) + end do +! + end subroutine dup_pvr_tracers_ctl +! +! --------------------------------------------------------------------- +! + subroutine reset_pvr_tracers_ctl(pvr_isos_ctl) +! + type(pvr_tracers_ctl), intent(inout) :: pvr_isos_ctl +! + integer(kind = kint) :: i +! + do i = 1, pvr_isos_ctl%num_pvr_tracer_ctl + call reset_pvr_tracer_ctl(pvr_isos_ctl%pvr_trc_c(i)) + end do +! + end subroutine reset_pvr_tracers_ctl +! +! --------------------------------------------------------------------- +! + end module t_control_data_pvr_tracers diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvrs.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvrs.f90 new file mode 100644 index 00000000..8f9e4a46 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_pvrs.f90 @@ -0,0 +1,298 @@ +!>@file t_control_data_pvrs.f90 +!!@brief module t_control_data_pvrs +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +! +!>@brief structure of control data for multiple PVRs +!! +!!@verbatim +!! subroutine alloc_pvr_ctl_struct(pvr_ctls) +!! subroutine dealloc_pvr_ctl_struct(pvr_ctls) +!! subroutine init_pvr_ctls_labels(hd_pvr_ctl, pvr_ctls) +!! character(len = kchara), intent(in) :: hd_pvr_ctl +!! type(volume_rendering_controls), intent(inout) :: pvr_ctls +!! +!! subroutine read_files_4_pvr_ctl & +!! & (id_control, hd_pvr_ctl, pvr_ctls, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len = kchara), intent(in) :: hd_pvr_ctl +!! type(volume_rendering_controls), intent(inout) :: pvr_ctls +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_files_4_pvr_ctl & +!! & (id_control, hd_pvr_ctl, pvr_ctls, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len = kchara), intent(in) :: hd_pvr_ctl +!! type(volume_rendering_controls), intent(in) :: pvr_ctls +!! integer(kind = kint), intent(inout) :: level +!! +!! subroutine add_fields_4_pvrs_to_fld_ctl(pvr_ctl, field_ctl) +!! type(volume_rendering_controls), intent(in) :: pvr_ctls +!! type(ctl_array_c3), intent(inout) :: field_ctl +!! +!! subroutine append_pvr_ctl_struct(idx_in, hd_block, pvr_ctls) +!! subroutine delete_pvr_ctl_struct(idx_in, hd_block, pvr_ctls) +!! integer(kind = kint), intent(in) :: idx_in +!! character(len=kchara), intent(in) :: hd_block +!! type(volume_rendering_controls), intent(inout) :: pvr_ctls +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array volume_rendering 1 +!! file volume_rendering 'ctl_pvr_temp' +!! end array volume_rendering +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_control_data_pvrs +! + use m_precision +! + use m_machine_parameter + use t_control_data_4_pvr +! + implicit none +! + type volume_rendering_controls +!> Control block name + character(len = kchara) :: block_name = 'volume_rendering' +! + integer(kind = kint) :: num_pvr_ctl = 0 + character(len = kchara), allocatable :: fname_pvr_ctl(:) + type(pvr_parameter_ctl), allocatable :: pvr_ctl_type(:) + end type volume_rendering_controls +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_ctl_struct(pvr_ctls) +! + type(volume_rendering_controls), intent(inout) :: pvr_ctls +! +! + allocate(pvr_ctls%fname_pvr_ctl(pvr_ctls%num_pvr_ctl)) + allocate(pvr_ctls%pvr_ctl_type(pvr_ctls%num_pvr_ctl)) +! + end subroutine alloc_pvr_ctl_struct +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_ctl_struct(pvr_ctls) +! + type(volume_rendering_controls), intent(inout) :: pvr_ctls +! + integer(kind = kint) :: i +! +! + if(allocated(pvr_ctls%fname_pvr_ctl)) then + do i = 1, pvr_ctls%num_pvr_ctl + call deallocate_cont_dat_pvr(pvr_ctls%pvr_ctl_type(i)) + end do +! + deallocate(pvr_ctls%pvr_ctl_type, pvr_ctls%fname_pvr_ctl) + end if + pvr_ctls%num_pvr_ctl = 0 +! + end subroutine dealloc_pvr_ctl_struct +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_ctls_labels(hd_pvr_ctl, pvr_ctls) +! + character(len = kchara), intent(in) :: hd_pvr_ctl + type(volume_rendering_controls), intent(inout) :: pvr_ctls +! +! + pvr_ctls%block_name = hd_pvr_ctl + pvr_ctls%num_pvr_ctl = 0 +! + end subroutine init_pvr_ctls_labels +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine read_files_4_pvr_ctl & + & (id_control, hd_pvr_ctl, pvr_ctls, c_buf) +! + use t_read_control_elements + use skip_comment_f + use write_control_elements + use ctl_file_each_pvr_IO +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: hd_pvr_ctl +! + type(volume_rendering_controls), intent(inout) :: pvr_ctls + type(buffer_for_control), intent(inout) :: c_buf +! + integer(kind = kint) :: n_append +! +! + if(check_array_flag(c_buf, hd_pvr_ctl) .eqv. .FALSE.) return + if(allocated(pvr_ctls%fname_pvr_ctl)) return + call alloc_pvr_ctl_struct(pvr_ctls) +! + do + call load_one_line_from_control(id_control, hd_pvr_ctl, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_array_flag(c_buf, hd_pvr_ctl)) exit +! + if(check_file_flag(c_buf, hd_pvr_ctl) & + & .or. check_begin_flag(c_buf, hd_pvr_ctl)) then + n_append = pvr_ctls%num_pvr_ctl + call append_pvr_ctl_struct(n_append, hd_pvr_ctl, pvr_ctls) +! + call write_multi_ctl_file_message & + & (hd_pvr_ctl, pvr_ctls%num_pvr_ctl, c_buf%level) + call sel_read_control_pvr(id_control, hd_pvr_ctl, & + & pvr_ctls%fname_pvr_ctl(pvr_ctls%num_pvr_ctl), & + & pvr_ctls%pvr_ctl_type(pvr_ctls%num_pvr_ctl), c_buf) + end if + end do +! + end subroutine read_files_4_pvr_ctl +! +! -------------------------------------------------------------------- +! + subroutine write_files_4_pvr_ctl & + & (id_control, hd_pvr_ctl, pvr_ctls, level) +! + use t_read_control_elements + use skip_comment_f + use ctl_file_each_pvr_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: hd_pvr_ctl +! + type(volume_rendering_controls), intent(in) :: pvr_ctls + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: i +! + if(pvr_ctls%num_pvr_ctl .le. 0) return +! + level = write_array_flag_for_ctl(id_control, level, hd_pvr_ctl) + do i = 1, pvr_ctls%num_pvr_ctl + write(*,'(3a,i4,a)', ADVANCE='NO') '! ', trim(hd_pvr_ctl), & + & ' No. ', i + call sel_write_control_pvr(id_control, hd_pvr_ctl, & + & pvr_ctls%fname_pvr_ctl(i), pvr_ctls%pvr_ctl_type(i), level) + end do + level = write_end_array_flag_for_ctl(id_control, level, & + & hd_pvr_ctl) +! + end subroutine write_files_4_pvr_ctl +! +! -------------------------------------------------------------------- +! + subroutine add_fields_4_pvrs_to_fld_ctl(pvr_ctls, field_ctl) +! + use t_control_array_character3 +! + type(volume_rendering_controls), intent(in) :: pvr_ctls + type(ctl_array_c3), intent(inout) :: field_ctl +! + integer(kind = kint) :: i_pvr +! +! + do i_pvr = 1, pvr_ctls%num_pvr_ctl + call add_field_4_pvr_to_fld_ctl & + & (pvr_ctls%pvr_ctl_type(i_pvr), field_ctl) + end do +! + end subroutine add_fields_4_pvrs_to_fld_ctl +! +! --------------------------------------------------------------------- +! -------------------------------------------------------------------- +! + subroutine append_pvr_ctl_struct(idx_in, hd_block, pvr_ctls) +! + use ctl_data_each_pvr_IO +! + integer(kind = kint), intent(in) :: idx_in + character(len=kchara), intent(in) :: hd_block + type(volume_rendering_controls), intent(inout) :: pvr_ctls +! + type(volume_rendering_controls) :: tmp_pvrs_c + integer(kind = kint) :: i +! +! + if(idx_in.lt.0 .or. idx_in.gt.pvr_ctls%num_pvr_ctl) return +! + tmp_pvrs_c%num_pvr_ctl = pvr_ctls%num_pvr_ctl + call alloc_pvr_ctl_struct(tmp_pvrs_c) + do i = 1, pvr_ctls%num_pvr_ctl + call dup_pvr_ctl(pvr_ctls%pvr_ctl_type(i), & + & tmp_pvrs_c%pvr_ctl_type(i)) + tmp_pvrs_c%fname_pvr_ctl(i) = pvr_ctls%fname_pvr_ctl(i) + end do +! + call dealloc_pvr_ctl_struct(pvr_ctls) + pvr_ctls%num_pvr_ctl = tmp_pvrs_c%num_pvr_ctl + 1 + call alloc_pvr_ctl_struct(pvr_ctls) +! + do i = 1, idx_in + call dup_pvr_ctl(tmp_pvrs_c%pvr_ctl_type(i), & + & pvr_ctls%pvr_ctl_type(i)) + pvr_ctls%fname_pvr_ctl(i) = tmp_pvrs_c%fname_pvr_ctl(i) + end do +! + call init_pvr_ctl_label(hd_block, & + & pvr_ctls%pvr_ctl_type(idx_in+1)) + pvr_ctls%fname_pvr_ctl(idx_in+1) = 'NO_FILE' +! + do i = idx_in+1, tmp_pvrs_c%num_pvr_ctl + call dup_pvr_ctl(tmp_pvrs_c%pvr_ctl_type(i), & + & pvr_ctls%pvr_ctl_type(i+1)) + pvr_ctls%fname_pvr_ctl(i+1) = tmp_pvrs_c%fname_pvr_ctl(i) + end do +! + call dealloc_pvr_ctl_struct(tmp_pvrs_c) +! + end subroutine append_pvr_ctl_struct +! +! --------------------------------------------------------------------- +! + subroutine delete_pvr_ctl_struct(idx_in, pvr_ctls) +! + integer(kind = kint), intent(in) :: idx_in + type(volume_rendering_controls), intent(inout) :: pvr_ctls +! + type(volume_rendering_controls) :: tmp_pvrs_c + integer(kind = kint) :: i +! +! + if(idx_in.le.0 .or. idx_in.gt.pvr_ctls%num_pvr_ctl) return +! + tmp_pvrs_c%num_pvr_ctl = pvr_ctls%num_pvr_ctl + call alloc_pvr_ctl_struct(tmp_pvrs_c) + do i = 1, pvr_ctls%num_pvr_ctl + call dup_pvr_ctl(pvr_ctls%pvr_ctl_type(i), & + & tmp_pvrs_c%pvr_ctl_type(i)) + tmp_pvrs_c%fname_pvr_ctl(i) = pvr_ctls%fname_pvr_ctl(i) + end do +! + call dealloc_pvr_ctl_struct(pvr_ctls) + pvr_ctls%num_pvr_ctl = tmp_pvrs_c%num_pvr_ctl + 1 + call alloc_pvr_ctl_struct(pvr_ctls) +! + do i = 1, idx_in-1 + call dup_pvr_ctl(tmp_pvrs_c%pvr_ctl_type(i), & + & pvr_ctls%pvr_ctl_type(i)) + pvr_ctls%fname_pvr_ctl(i) = tmp_pvrs_c%fname_pvr_ctl(i) + end do + do i = idx_in, pvr_ctls%num_pvr_ctl + call dup_pvr_ctl(tmp_pvrs_c%pvr_ctl_type(i+1), & + & pvr_ctls%pvr_ctl_type(i)) + pvr_ctls%fname_pvr_ctl(i) = tmp_pvrs_c%fname_pvr_ctl(i+1) + end do +! + call dealloc_pvr_ctl_struct(tmp_pvrs_c) +! + end subroutine delete_pvr_ctl_struct +! +! --------------------------------------------------------------------- +! + end module t_control_data_pvrs diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_viz4.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_viz4.f90 new file mode 100644 index 00000000..e2a18e0f --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_data_viz4.f90 @@ -0,0 +1,197 @@ +!>@file t_control_data_viz4.f90 +!!@brief module t_control_data_viz4 +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Control data structure for visualization controls +!! +!!@verbatim +!! subroutine dealloc_viz4_controls(viz_ctls) +!! type(vis4_controls), intent(inout) :: viz_ctls +!! type(buffer_for_control), intent(inout) :: c_buf +!! +!! subroutine add_fields_viz4_to_fld_ctl(viz_ctls, field_ctl) +!! type(vis4_controls), intent(in) :: viz_ctls +!! type(ctl_array_c3), intent(inout) :: field_ctl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! begin visual_control +!! array cross_section_ctl +!! .... +!! end array cross_section_ctl +!! +!! array isosurface_ctl +!! .... +!! end array isosurface_ctl +!! +!! array map_rendering_ctl +!! .... +!! end array map_rendering_ctl +!! +!! array volume_rendering +!! .... +!! end array volume_rendering +!! +!! array fieldline +!! .... +!! end array fieldline +!! +!! array LIC_rendering +!! .... +!! end array LIC_rendering +!! +!! delta_t_sectioning_ctl 1.0e-3 +!! i_step_sectioning_ctl 400 +!! delta_t_isosurface_ctl 1.0e-3 +!! i_step_isosurface_ctl 400 +!! delta_t_map_projection_ctl 1.0e-3 +!! i_step_map_projection_ctl 400 +!! delta_t_pvr_ctl 1.0e-2 +!! i_step_pvr_ctl 400 +!! delta_t_fline_ctl 1.0e-1 +!! i_step_fline_ctl 400 +!! delta_t_field_ctl 1.0e-3 +!! i_step_field_ctl 800 +!! output_field_file_fmt_ctl 'VTK' +!! end visual_control +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! +! + module t_control_data_viz4 +! + use m_precision +! + use m_machine_parameter + use t_control_data_sections + use t_control_data_isosurfaces + use t_control_data_maps + use t_control_data_pvrs + use t_control_data_flines + use t_control_array_character + use t_control_array_real + use t_control_array_integer +! + implicit none +! +!> Structures of visualization controls + type vis4_controls +!> Block name + character(len=kchara) :: block_name = 'visualizer' +!> Structures of setioning controls + type(section_controls) :: psf_ctls +!> Structures of isosurface controls + type(isosurf_controls) :: iso_ctls +!> Structures of map projection controls + type(map_rendering_controls) :: map_ctls +!> Structures of volume rendering controls + type(volume_rendering_controls) :: pvr_ctls +!> Structures of fieldline controls + type(fieldline_controls) :: fline_ctls +! +!> Increment for sectioning + type(read_integer_item) :: i_step_psf_v_ctl +!> Increment for isosurface + type(read_integer_item) :: i_step_iso_v_ctl +!> Increment for map projection + type(read_integer_item) :: i_step_map_v_ctl +!> Increment for volume rendering + type(read_integer_item) :: i_step_pvr_v_ctl +!> Increment for field line + type(read_integer_item) :: i_step_fline_v_ctl +!> Increment for field data output + type(read_integer_item) :: i_step_ucd_v_ctl +! +!> time interval for sectioning + type(read_real_item) :: delta_t_psf_v_ctl +!> time interval for isosurface + type(read_real_item) :: delta_t_iso_v_ctl +!> time interval for map projection + type(read_real_item) :: delta_t_map_v_ctl +!> time interval for volume rendering + type(read_real_item) :: delta_t_pvr_v_ctl +!> time interval for field line + type(read_real_item) :: delta_t_fline_v_ctl +!> time interval for field data output + type(read_real_item) :: delta_t_ucd_v_ctl +! +!> File format for field data output + type(read_character_item) :: output_field_file_fmt_ctl +! +! + integer (kind=kint) :: i_viz_control = 0 + end type vis4_controls +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine dealloc_viz4_controls(viz_ctls) +! + type(vis4_controls), intent(inout) :: viz_ctls +! +! + call dealloc_psf_ctl_stract(viz_ctls%psf_ctls) + call dealloc_iso_ctl_stract(viz_ctls%iso_ctls) + call dealloc_map_ctl_stract(viz_ctls%map_ctls) + call dealloc_pvr_ctl_struct(viz_ctls%pvr_ctls) + call dealloc_fline_ctl_struct(viz_ctls%fline_ctls) +! + viz_ctls%delta_t_psf_v_ctl%iflag = 0 + viz_ctls%delta_t_iso_v_ctl%iflag = 0 + viz_ctls%delta_t_map_v_ctl%iflag = 0 + viz_ctls%delta_t_pvr_v_ctl%iflag = 0 + viz_ctls%delta_t_fline_v_ctl%iflag = 0 + viz_ctls%delta_t_ucd_v_ctl%iflag = 0 +! + viz_ctls%i_step_psf_v_ctl%iflag = 0 + viz_ctls%i_step_iso_v_ctl%iflag = 0 + viz_ctls%i_step_map_v_ctl%iflag = 0 + viz_ctls%i_step_pvr_v_ctl%iflag = 0 + viz_ctls%i_step_fline_v_ctl%iflag = 0 + viz_ctls%i_step_ucd_v_ctl%iflag = 0 +! + viz_ctls%i_viz_control = 0 +! + end subroutine dealloc_viz4_controls +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine add_fields_viz4_to_fld_ctl(viz_ctls, field_ctl) +! + use t_control_array_character3 +! + type(vis4_controls), intent(in) :: viz_ctls + type(ctl_array_c3), intent(inout) :: field_ctl +! +! + if(viz_ctls%psf_ctls%num_psf_ctl .gt. 0) then + call add_fields_4_psfs_to_fld_ctl(viz_ctls%psf_ctls, field_ctl) + end if +! + if(viz_ctls%iso_ctls%num_iso_ctl .gt. 0) then + call add_fields_4_isos_to_fld_ctl(viz_ctls%iso_ctls, field_ctl) + end if +! + if(viz_ctls%map_ctls%num_map_ctl .gt. 0) then + call add_fields_4_maps_to_fld_ctl(viz_ctls%map_ctls, field_ctl) + end if +! +! + if(viz_ctls%pvr_ctls%num_pvr_ctl .gt. 0) then + call add_fields_4_pvrs_to_fld_ctl(viz_ctls%pvr_ctls, field_ctl) + end if +! + if(viz_ctls%fline_ctls%num_fline_ctl .gt. 0) then + call add_fields_4_flines_to_fld_ctl(viz_ctls%fline_ctls, & + & field_ctl) + end if +! + end subroutine add_fields_viz4_to_fld_ctl +! +! --------------------------------------------------------------------- +! + end module t_control_data_viz4 diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_params_4_pvr.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_params_4_pvr.f90 new file mode 100644 index 00000000..97a37fda --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_params_4_pvr.f90 @@ -0,0 +1,159 @@ +!>@file t_control_params_4_pvr.f90 +!! module t_control_params_4_pvr +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!> @brief Structures for parameteres for volume rendering +!! +!!@verbatim +!! subroutine alloc_pvr_element_group(pvr_area) +!! subroutine dealloc_pvr_element_group(pvr_area) +!! type(viz_area_parameter), intent(inout) :: pvr_area +!!@endverbatim +! + module t_control_params_4_pvr +! + use m_precision + use m_constants + use output_image_sel_4_png +! + implicit none +! +! + real(kind = kreal), parameter :: SMALL_RAY_TRACE = 0.1d0 + real(kind = kreal), parameter :: SMALL_NORM = -0.1d0 +! + integer(kind = kint), parameter :: IFLAG_NO_MOVIE = 0 + integer(kind = kint), parameter :: I_ROTATE_MOVIE = 1 + integer(kind = kint), parameter :: I_ZOOM = 2 + integer(kind = kint), parameter :: I_START_END_VIEW = 3 + integer(kind = kint), parameter :: I_LOOKINGLASS = 4 + integer(kind = kint), parameter :: I_LIC_KERNEL = 5 +! +!> Structure for field parameter for PVR + type pvr_field_parameter +!> Field type for PVR data + integer(kind = kint) :: id_field = 0 +!> Component flag for PVR data + integer(kind = kint) :: id_component = 0 +!> Number of component of data for Rendering + integer(kind = kint) :: num_original_comp = 0 +!> Field name of data for Rendering + character(len = kchara) :: field_name + end type pvr_field_parameter +! +!> Structure for rendering area by element group + type viz_area_parameter +!> Number of Element group for volume rendering + integer(kind = kint) :: nele_grp_area_pvr = 0 +!> Element group list for volume rendering + integer(kind = kint), allocatable :: id_ele_grp_area_pvr(:) + end type viz_area_parameter +! +!> Structure for view parameteres + type pvr_view_parameter +!> Number of pixels for image + integer(kind = kint) :: n_pvr_pixel(2) = (/0,0/) +! +!> Defined flag for perspective view + integer(kind = kint) :: iflag_perspective = 0 +!> Apature of perspective view + real(kind = kreal) :: perspective_angle = zero +!> Aspect ratio between horiaontal and vertical + real(kind = kreal) :: perspective_xy_ratio = zero +!> Near distance for perspective view + real(kind = kreal) :: perspective_near = zero +!> Farther distance for perspective view + real(kind = kreal) :: perspective_far = zero +! +! +!> Defined flag for modelview matrix + integer(kind = kint) :: iflag_modelview_mat = 0 +!> Modelview matrix + real(kind = kreal) :: modelview(4,4) +! +! +!> Defined flag for view rotation + integer(kind = kint) :: iflag_rotation = 0 +!> View rotatin + real(kind = kreal) :: rotation_pvr(4) = (/zero,zero,zero,zero/) +! +!> Defined flag for scale factor + integer(kind = kint) :: iflag_scale_fact = 0 +!> Scale factor + real(kind = kreal) :: scale_factor_pvr(3) = (/one,one,one/) +! +!> Defined flag for eye point in viewer coordinate + integer(kind = kint) :: iflag_viewpt_in_view = 0 +!> Position of eye point in viewer coordinate + real(kind = kreal) :: viewpt_in_viewer_pvr(4) & + & = (/zero,zero,zero,zero/) +! +!> Defined flag for lookatpoint + integer(kind = kint) :: iflag_lookpoint = 0 +!> Position to look at + real(kind = kreal) :: lookat_vec(3) = (/zero,zero,zero/) +! +!> Defined flag for up-direction + integer(kind = kint) :: iflag_updir = 0 +!> Vector for up-direction + real(kind = kreal) :: up_direction_vec(3) = (/zero,zero,zero/) +! +!> Defined flag for viewpoint + integer(kind = kint) :: iflag_viewpoint = 0 +!> Position of viewpoint + real(kind = kreal) :: viewpoint(3) = (/zero,zero,zero/) + end type pvr_view_parameter +! +!> movie parameters + type pvr_movie_parameter +!> Integer flag for movie output + integer(kind = kint) :: iflag_movie_mode = IFLAG_NO_MOVIE +! +!> Number of frames + integer(kind = kint) :: num_frame = 0 +!> Number of row and column of image array (horizontal, vertical) + integer(kind = kint) :: n_column_row_movie(2) = 0 +! +!> Rotatin axis: id_rot_axis + integer(kind = kint) :: id_rot_axis = 3 +!> Rotation range + real(kind = kreal) :: angle_range(2) = 0.0d0 +! +!> Apature range + real(kind = kreal) :: apature_range(2) = 0.0d0 +!> Apature range + real(kind = kreal) :: peak_range(2) = 0.0d0 + end type pvr_movie_parameter +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_element_group(pvr_area) +! + type(viz_area_parameter), intent(inout) :: pvr_area +! + allocate(pvr_area%id_ele_grp_area_pvr(pvr_area%nele_grp_area_pvr)) +! + if(pvr_area%nele_grp_area_pvr .le. 0) return + pvr_area%id_ele_grp_area_pvr = 0 +! + end subroutine alloc_pvr_element_group +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_element_group(pvr_area) +! + type(viz_area_parameter), intent(inout) :: pvr_area +! + deallocate(pvr_area%id_ele_grp_area_pvr) +! + end subroutine dealloc_pvr_element_group +! +! --------------------------------------------------------------------- +! + end module t_control_params_4_pvr diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_params_stereo_pvr.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_params_stereo_pvr.f90 new file mode 100644 index 00000000..238280f2 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_control_params_stereo_pvr.f90 @@ -0,0 +1,153 @@ +!>@file t_control_params_stereo_pvr.f90 +!! module t_control_params_stereo_pvr +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!> @brief Structures for parameteres for stereo volume rendering +!! +!!@verbatim +!! real(kind = kreal) function each_eye_from_middle & +!! & (i_img, stereo_def) +!! type(pvr_stereo_parameter), intent(in) :: stereo_def +!! subroutine set_pvr_stereo_control(pvr_ctl, stereo_def) +!! type(pvr_parameter_ctl), intent(in) :: pvr_ctl +!! type(pvr_stereo_parameter), intent(inout) :: stereo_def +!!@endverbatim +! + module t_control_params_stereo_pvr +! + use m_precision + use m_constants +! + implicit none +! +! +!> Stereo view parameters + type pvr_stereo_parameter +!> Flag to make anaglyph images with fixed view + logical :: flag_anaglyph = .FALSE. +!> Flag to make quilt images with fixed view + logical :: flag_quilt = .FALSE. +! +!> Number of images + integer(kind = kint) :: num_views = 0 +!> Number of row and column of image array (horizontal, vertical) + integer(kind = kint) :: n_column_row_view(2) = 0 +! +!> Flag to defeine eye separation by angle + logical :: flag_eye_separation_angle = .FALSE. +!> Flag to stepping eye position by angle + logical :: flag_setp_eye_separation_angle = .FALSE. +! +!> Focal length for streo view + real(kind = kreal) :: focalLength = one +!> Eye separation for streo view + real(kind = kreal) :: eye_separation = zero +!> Eye separation angle for streo view + real(kind = kreal) :: eye_sep_angle = zero + end type pvr_stereo_parameter +! +! --------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + real(kind = kreal) function each_eye_from_middle & + & (i_img, stereo_def) +! + integer(kind = kint), intent(in) :: i_img + type(pvr_stereo_parameter), intent(in) :: stereo_def +! + real(kind = kreal) :: pi_180, range, rstep, each_eye, separation +! +! + pi_180 = four * atan(one) / 180.0d0 + rstep = half - dble(i_img-1) / dble(stereo_def%num_views-1) + if(stereo_def%flag_setp_eye_separation_angle) then + if(stereo_def%flag_eye_separation_angle) then + each_eye = stereo_def%focalLength & + & * tan(pi_180 * rstep * stereo_def%eye_sep_angle) + else + range = two * atan(half*stereo_def%eye_separation & + & / stereo_def%focalLength) + each_eye = stereo_def%focalLength * tan(rstep * range) + end if + else + if(stereo_def%flag_eye_separation_angle) then + separation = stereo_def%focalLength & + & * tan(half * pi_180 * stereo_def%eye_sep_angle) + else + separation = stereo_def%eye_separation + end if + each_eye = separation * rstep + end if + each_eye_from_middle = each_eye +! + end function each_eye_from_middle +! +! ----------------------------------------------------------------------- +! + subroutine set_pvr_stereo_control(pvr_ctl, stereo_def) +! + use t_control_data_4_pvr + use set_area_4_viz + use skip_comment_f +! + type(pvr_parameter_ctl), intent(in) :: pvr_ctl + type(pvr_stereo_parameter), intent(inout) :: stereo_def +! +! + stereo_def%flag_quilt = .FALSE. + if(yes_flag(pvr_ctl%quilt_ctl%charavalue)) then + stereo_def%flag_quilt = .TRUE. + end if +! + stereo_def%flag_anaglyph = .FALSE. + if(yes_flag(pvr_ctl%anaglyph_ctl%charavalue)) then + stereo_def%flag_anaglyph = .TRUE. + end if +! + stereo_def%num_views = 0 + call set_pvr_quilt_num_control(pvr_ctl%quilt_c, stereo_def) +! + end subroutine set_pvr_stereo_control +! +! --------------------------------------------------------------------- +! + subroutine set_pvr_quilt_num_control(quilt_c, stereo_def) +! + use t_ctl_data_quilt_image +! + type(quilt_image_ctl), intent(in) :: quilt_c + type(pvr_stereo_parameter), intent(inout) :: stereo_def +! +! + if(stereo_def%flag_quilt) then + if(quilt_c%i_quilt_image .eq. 0) then + stereo_def%flag_quilt = .FALSE. + else if(quilt_c%num_column_row_ctl%iflag .gt. 0) then + stereo_def%n_column_row_view(1:2) & + & = quilt_c%num_column_row_ctl%intvalue(1:2) + stereo_def%num_views = stereo_def%n_column_row_view(1) & + & * stereo_def%n_column_row_view(2) + else if(quilt_c%num_row_column_ctl%iflag .gt. 0) then + stereo_def%n_column_row_view(1) & + & = quilt_c%num_row_column_ctl%intvalue(2) + stereo_def%n_column_row_view(2) & + & = quilt_c%num_row_column_ctl%intvalue(1) + stereo_def%num_views = stereo_def%n_column_row_view(1) & + & * stereo_def%n_column_row_view(2) + end if + else if(stereo_def%flag_anaglyph) then + stereo_def%n_column_row_view(1) = 2 + stereo_def%n_column_row_view(2) = 1 + stereo_def%num_views = 2 + end if +! + end subroutine set_pvr_quilt_num_control +! +! --------------------------------------------------------------------- +! + end module t_control_params_stereo_pvr diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_projection.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_projection.f90 new file mode 100644 index 00000000..45b32282 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_projection.f90 @@ -0,0 +1,292 @@ +!>@file t_ctl_data_4_projection.f90 +!!@brief module t_ctl_data_4_projection +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief Control inputs for PVR projection and streo parameter +!! +!!@verbatim +!! subroutine init_projection_mat_ctl_label(hd_block, proj) +!! subroutine read_projection_mat_ctl & +!! & (id_control, hd_block, proj, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(projection_ctl), intent(inout) :: proj +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_projection_mat_ctl & +!! & (id_control, hd_block, proj, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(projection_ctl), intent(in) :: proj +!! integer(kind = kint), intent(inout) :: level +!! subroutine reset_projection_view_ctl(proj) +!! type(projection_ctl), intent(inout) :: proj +!! subroutine copy_projection_mat_ctl(org_proj, new_proj) +!! type(projection_ctl), intent(in) :: org_proj +!! type(projection_ctl), intent(inout) :: new_proj +!! logical function cmp_projection_ctl(proj1, proj2) +!! type(projection_ctl), intent(in) :: proj1, proj2 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Input example +!! +!! begin projection_matrix_ctl +!! perspective_angle_ctl 10.0 +!! perspective_xy_ratio_ctl 1.0 +!! perspective_near_ctl 0.5 +!! perspective_far_ctl 1000.0 +!! +!! horizontal_range_ctl -2.4 2.4 +!! vertical_range_ctl -1.2 1.2 +!! end projection_matrix_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +!! +! + module t_ctl_data_4_projection +! + use m_precision +! + use m_constants + use m_machine_parameter + use t_read_control_elements + use t_control_array_real + use t_control_array_real2 +! + implicit none +! +! +!> Structure of projection parameters + type projection_ctl +!> Control block name + character(len = kchara) :: block_name = 'projection_matrix_ctl' +!> Structure of perspective view angle + type(read_real_item) :: perspective_angle_ctl +!> Structure of aspect ration of screen + type(read_real_item) :: perspective_xy_ratio_ctl +!> Structure of Near point of view + type(read_real_item) :: perspective_near_ctl +!> Structure of Far point of view + type(read_real_item) :: perspective_far_ctl +! +!> Structure of horizontal screen range + type(read_real2_item) :: horizontal_range_ctl +!> Structure of vertical screen range + type(read_real2_item) :: vertical_range_ctl + + integer (kind=kint) :: i_project_mat = 0 + end type projection_ctl +! +! 4th level for projection_matrix + character(len=kchara), parameter, private & + & :: hd_perspect_angle = 'perspective_angle_ctl' + character(len=kchara), parameter, private & + & :: hd_perspect_xy = 'perspective_xy_ratio_ctl' + character(len=kchara), parameter, private & + & :: hd_perspect_near = 'perspective_near_ctl' + character(len=kchara), parameter, private & + & :: hd_perspect_far = 'perspective_far_ctl' +! + character(len=kchara), parameter, private & + & :: hd_horizontal_range = 'horizontal_range_ctl' + character(len=kchara), parameter, private & + & :: hd_vertical_range = 'vertical_range_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_projection_mat_ctl & + & (id_control, hd_block, proj, c_buf) +! + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(projection_ctl), intent(inout) :: proj + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + if (proj%i_project_mat.gt.0) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_real_ctl_type(c_buf, hd_perspect_angle, & + & proj%perspective_angle_ctl) + call read_real_ctl_type(c_buf, hd_perspect_xy, & + & proj%perspective_xy_ratio_ctl) + call read_real_ctl_type(c_buf, hd_perspect_near, & + & proj%perspective_near_ctl) + call read_real_ctl_type(c_buf, hd_perspect_far, & + & proj%perspective_far_ctl) +! + call read_real2_ctl_type(c_buf, hd_horizontal_range, & + & proj%horizontal_range_ctl) + call read_real2_ctl_type(c_buf, hd_vertical_range, & + & proj%vertical_range_ctl) + end do + proj%i_project_mat = 1 +! + end subroutine read_projection_mat_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_projection_mat_ctl & + & (id_control, hd_block, proj, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(projection_ctl), intent(in) :: proj +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(proj%i_project_mat .le. 0) return +! + maxlen = len_trim(hd_perspect_angle) + maxlen = max(maxlen, len_trim(hd_perspect_xy)) + maxlen = max(maxlen, len_trim(hd_perspect_near)) + maxlen = max(maxlen, len_trim(hd_perspect_far)) + maxlen = max(maxlen, len_trim(hd_horizontal_range)) + maxlen = max(maxlen, len_trim(hd_vertical_range)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_real_ctl_type(id_control, level, maxlen, & + & proj%perspective_angle_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & proj%perspective_xy_ratio_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & proj%perspective_near_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & proj%perspective_far_ctl) +! + call write_real2_ctl_type(id_control, level, maxlen, & + & proj%horizontal_range_ctl) + call write_real2_ctl_type(id_control, level, maxlen, & + & proj%vertical_range_ctl) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_projection_mat_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_projection_mat_ctl_label(hd_block, proj) +! + character(len=kchara), intent(in) :: hd_block +! + type(projection_ctl), intent(inout) :: proj +! +! + proj%block_name = hd_block + call init_real_ctl_item_label(hd_perspect_angle, & + & proj%perspective_angle_ctl) + call init_real_ctl_item_label(hd_perspect_xy, & + & proj%perspective_xy_ratio_ctl) + call init_real_ctl_item_label(hd_perspect_near, & + & proj%perspective_near_ctl) + call init_real_ctl_item_label(hd_perspect_far, & + & proj%perspective_far_ctl) +! + call init_real2_ctl_item_label(hd_horizontal_range, & + & proj%horizontal_range_ctl) + call init_real2_ctl_item_label(hd_vertical_range, & + & proj%vertical_range_ctl) +! + end subroutine init_projection_mat_ctl_label +! +! --------------------------------------------------------------------- +! + logical function cmp_projection_ctl(proj1, proj2) +! + use skip_comment_f +! + type(projection_ctl), intent(in) :: proj1, proj2 +! + cmp_projection_ctl = .FALSE. + if(proj1%i_project_mat .ne. proj2%i_project_mat) return + if(cmp_no_case(trim(proj1%block_name), & + & trim(proj2%block_name)) .eqv. .FALSE.) return +! + if(cmp_read_real_item(proj1%perspective_angle_ctl, & + & proj2%perspective_angle_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real_item(proj1%perspective_xy_ratio_ctl, & + & proj2%perspective_xy_ratio_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real_item(proj1%perspective_near_ctl, & + & proj2%perspective_near_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real_item(proj1%perspective_far_ctl, & + & proj2%perspective_far_ctl) & + & .eqv. .FALSE.) return +! + if(cmp_read_real2_item(proj1%horizontal_range_ctl, & + & proj2%horizontal_range_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real2_item(proj1%vertical_range_ctl, & + & proj2%vertical_range_ctl) & + & .eqv. .FALSE.) return + cmp_projection_ctl = .TRUE. +! + end function cmp_projection_ctl +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine reset_projection_view_ctl(proj) +! + type(projection_ctl), intent(inout) :: proj +! +! + proj%perspective_angle_ctl%iflag = 0 + proj%perspective_xy_ratio_ctl%iflag = 0 + proj%perspective_near_ctl%iflag = 0 + proj%perspective_far_ctl%iflag = 0 + proj%horizontal_range_ctl%iflag = 0 + proj%vertical_range_ctl%iflag = 0 +! + proj%i_project_mat = 0 +! + end subroutine reset_projection_view_ctl +! +! --------------------------------------------------------------------- +! + subroutine copy_projection_mat_ctl(org_proj, new_proj) +! + type(projection_ctl), intent(in) :: org_proj + type(projection_ctl), intent(inout) :: new_proj +! +! + new_proj%block_name = org_proj%block_name + new_proj%i_project_mat = org_proj%i_project_mat +! + call copy_real_ctl(org_proj%perspective_angle_ctl, & + & new_proj%perspective_angle_ctl) + call copy_real_ctl(org_proj%perspective_xy_ratio_ctl, & + & new_proj%perspective_xy_ratio_ctl) + call copy_real_ctl(org_proj%perspective_near_ctl, & + & new_proj%perspective_near_ctl) + call copy_real_ctl(org_proj%perspective_far_ctl, & + & new_proj%perspective_far_ctl) +! + call copy_real2_ctl(org_proj%horizontal_range_ctl, & + & new_proj%horizontal_range_ctl) + call copy_real2_ctl(org_proj%vertical_range_ctl, & + & new_proj%vertical_range_ctl) +! + end subroutine copy_projection_mat_ctl +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_4_projection diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_screen_pixel.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_screen_pixel.f90 new file mode 100644 index 00000000..5a02ea98 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_screen_pixel.f90 @@ -0,0 +1,209 @@ +!>@file t_ctl_data_4_screen_pixel.f90 +!!@brief module t_ctl_data_4_screen_pixel +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief Control inputs for PVR projection and streo parameter +!! +!!@verbatim +!! subroutine init_image_size_ctl_label(hd_block, pixel) +!! subroutine read_image_size_ctl & +!! & (id_control, hd_block, pixel, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(screen_pixel_ctl), intent(inout) :: pixel +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_image_size_ctl & +!! & (id_control, hd_block, pixel, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(screen_pixel_ctl), intent(in) :: pixel +!! integer(kind = kint), intent(inout) :: level +!! logical function cmp_screen_pixel_ctl(pixel1, pixel2) +!! type(screen_pixel_ctl), intent(in) :: pixel1, pixel2 +!! subroutine reset_image_size_ctl(pixel) +!! subroutine copy_image_size_ctl(org_pixel, new_pixel) +!! type(screen_pixel_ctl), intent(in) :: org_pixel +!! type(screen_pixel_ctl), intent(inout) :: new_pixel +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Input example +!! +!! begin image_size_ctl +!! x_pixel_ctl 640 +!! y_pixel_ctl 480 +!! end image_size_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +!! +! + module t_ctl_data_4_screen_pixel +! + use m_precision +! + use m_constants + use m_machine_parameter + use t_read_control_elements + use t_control_array_integer +! + implicit none +! +! +! +!> Structure of screen resolution + type screen_pixel_ctl +!> Control block name + character(len = kchara) :: block_name = 'image_size_ctl' +!> Structure of number of horizontal pixels + type(read_integer_item) :: num_xpixel_ctl +!> Structure of number of vertical pixels + type(read_integer_item) :: num_ypixel_ctl +! +! 3rd level for view_transform_define + integer (kind=kint) :: i_image_size = 0 + end type screen_pixel_ctl +! +! 4th level for image size + character(len=kchara), parameter, private & + & :: hd_x_pixel = 'x_pixel_ctl' + character(len=kchara), parameter, private & + & :: hd_y_pixel = 'y_pixel_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_image_size_ctl & + & (id_control, hd_block, pixel, c_buf) +! + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(screen_pixel_ctl), intent(inout) :: pixel + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + if (pixel%i_image_size.gt.0) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_integer_ctl_type & + & (c_buf, hd_x_pixel, pixel%num_xpixel_ctl) + call read_integer_ctl_type & + & (c_buf, hd_y_pixel, pixel%num_ypixel_ctl) + end do + pixel%i_image_size = 1 +! + end subroutine read_image_size_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_image_size_ctl & + & (id_control, hd_block, pixel, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(screen_pixel_ctl), intent(in) :: pixel +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(pixel%i_image_size .le. 0) return +! + maxlen = len_trim(hd_x_pixel) + maxlen = max(maxlen, len_trim(hd_y_pixel)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_integer_ctl_type(id_control, level, maxlen, & + & pixel%num_xpixel_ctl) + call write_integer_ctl_type(id_control, level, maxlen, & + & pixel%num_ypixel_ctl) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_image_size_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_image_size_ctl_label(hd_block, pixel) +! + character(len=kchara), intent(in) :: hd_block + type(screen_pixel_ctl), intent(inout) :: pixel +! +! + pixel%block_name = hd_block + call init_int_ctl_item_label(hd_x_pixel, pixel%num_xpixel_ctl) + call init_int_ctl_item_label(hd_y_pixel, pixel%num_ypixel_ctl) +! + end subroutine init_image_size_ctl_label +! +! --------------------------------------------------------------------- +! + logical function cmp_screen_pixel_ctl(pixel1, pixel2) +! + use skip_comment_f +! + type(screen_pixel_ctl), intent(in) :: pixel1, pixel2 +! + cmp_screen_pixel_ctl = .FALSE. + if(pixel1%i_image_size .ne. pixel2%i_image_size) return + if(cmp_no_case(trim(pixel1%block_name), & + & trim(pixel2%block_name)) .eqv. .FALSE.) return +! + if(cmp_read_integer_item(pixel1%num_xpixel_ctl, & + & pixel2%num_xpixel_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_integer_item(pixel1%num_ypixel_ctl, & + & pixel2%num_ypixel_ctl) & + & .eqv. .FALSE.) return + cmp_screen_pixel_ctl = .TRUE. +! + end function cmp_screen_pixel_ctl +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine reset_image_size_ctl(pixel) +! + type(screen_pixel_ctl), intent(inout) :: pixel +! +! + pixel%num_xpixel_ctl%iflag = 0 + pixel%num_ypixel_ctl%iflag = 0 +! + pixel%i_image_size = 0 +! + end subroutine reset_image_size_ctl +! +! --------------------------------------------------------------------- +! + subroutine copy_image_size_ctl(org_pixel, new_pixel) +! + type(screen_pixel_ctl), intent(in) :: org_pixel + type(screen_pixel_ctl), intent(inout) :: new_pixel +! +! + new_pixel%block_name = org_pixel%block_name + new_pixel%i_image_size = org_pixel%i_image_size +! + call copy_integer_ctl(org_pixel%num_xpixel_ctl, & + & new_pixel%num_xpixel_ctl) + call copy_integer_ctl(org_pixel%num_ypixel_ctl, & + & new_pixel%num_ypixel_ctl) +! + end subroutine copy_image_size_ctl +! +! ---------------------------------------------------------------------- +! + end module t_ctl_data_4_screen_pixel diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_streo_view.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_streo_view.f90 new file mode 100644 index 00000000..b952e1e0 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_streo_view.f90 @@ -0,0 +1,261 @@ +!>@file t_ctl_data_4_streo_view.f90 +!!@brief module t_ctl_data_4_streo_view +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief Control inputs for PVR streo parameter +!! +!!@verbatim +!! subroutine init_stereo_view_ctl_label(hd_block, streo) +!! subroutine read_stereo_view_ctl & +!! & (id_control, hd_block, streo, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(streo_view_ctl), intent(inout) :: streo +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_stereo_view_ctl & +!! & (id_control, hd_block, streo, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(streo_view_ctl), intent(in) :: streo +!! integer(kind = kint), intent(inout) :: level +!! logical function cmp_streo_view_ctl(streo1, streo2) +!! type(streo_view_ctl), intent(in) :: streo1, streo2 +!! +!! subroutine reset_stereo_view_ctl(streo) +!! type(streo_view_ctl), intent(inout) :: streo +!! subroutine copy_stereo_view_ctl(org_streo, new_streo) +!! type(streo_view_ctl), intent(in) :: org_streo +!! type(streo_view_ctl), intent(inout) :: new_streo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Input example +!! +!! begin stereo_view_parameter_ctl +!! focal_distance_ctl 40.0 +!! eye_separation_ctl 0.5 +!! eye_separation_angle 35.0 +!! eye_separation_step_by_angle ON +!! end stereo_view_parameter_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +!! +! + module t_ctl_data_4_streo_view +! + use m_precision +! + use m_constants + use m_machine_parameter + use t_read_control_elements + use t_control_array_character + use t_control_array_real +! + implicit none +! +!> Structure of streo view parameters + type streo_view_ctl +!> Control block name + character(len = kchara) :: block_name & + & = 'stereo_view_parameter_ctl' +!> Structure of focal point + type(read_real_item) :: focalpoint_ctl +!> Structure of eye separation + type(read_real_item) :: eye_separation_ctl +!> Structure of eye separation angle (degree) + type(read_real_item) :: eye_sep_angle_ctl +!> Switch to eye moving step by angle + type(read_character_item) :: step_eye_sep_angle_ctl +! + integer (kind=kint) :: i_stereo_view = 0 + end type streo_view_ctl +! +! 4th level for stereo view + character(len=kchara), parameter, private & + & :: hd_focaldistance = 'focal_distance_ctl' + character(len=kchara), parameter, private & + & :: hd_eye_separation = 'eye_separation_ctl' + character(len=kchara), parameter, private & + & :: hd_eye_sep_angle = 'eye_separation_angle' + character(len=kchara), parameter, private & + & :: hd_eye_step_mode = 'eye_separation_step_by_angle' +! +! Old label + character(len=kchara), parameter, private & + & :: hd_focalpoint = 'focal_point_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_stereo_view_ctl & + & (id_control, hd_block, streo, c_buf) +! + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(streo_view_ctl), intent(inout) :: streo + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + if (streo%i_stereo_view.gt.0) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_real_ctl_type(c_buf, hd_focaldistance, & + & streo%focalpoint_ctl) + call read_real_ctl_type(c_buf, hd_focalpoint, & + & streo%focalpoint_ctl) +! + call read_real_ctl_type(c_buf, hd_eye_separation, & + & streo%eye_separation_ctl) + call read_real_ctl_type(c_buf, hd_eye_sep_angle, & + & streo%eye_sep_angle_ctl) +! + call read_chara_ctl_type(c_buf, hd_eye_step_mode, & + & streo%step_eye_sep_angle_ctl) + end do + streo%i_stereo_view = 1 +! + end subroutine read_stereo_view_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_stereo_view_ctl & + & (id_control, hd_block, streo, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(streo_view_ctl), intent(in) :: streo +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(streo%i_stereo_view .le. 0) return +! + maxlen = len_trim(hd_focaldistance) + maxlen = max(maxlen, len_trim(hd_eye_separation)) + maxlen = max(maxlen, len_trim(hd_eye_sep_angle)) + maxlen = max(maxlen, len_trim(hd_eye_step_mode)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_real_ctl_type(id_control, level, maxlen, & + & streo%focalpoint_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & streo%eye_separation_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & streo%eye_sep_angle_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & streo%step_eye_sep_angle_ctl) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_stereo_view_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_stereo_view_ctl_label(hd_block, streo) +! + character(len=kchara), intent(in) :: hd_block + type(streo_view_ctl), intent(inout) :: streo +! +! + streo%block_name = hd_block + call init_real_ctl_item_label(hd_focaldistance, & + & streo%focalpoint_ctl) + call init_real_ctl_item_label(hd_focalpoint, & + & streo%focalpoint_ctl) +! + call init_real_ctl_item_label(hd_eye_separation, & + & streo%eye_separation_ctl) + call init_real_ctl_item_label(hd_eye_sep_angle, & + & streo%eye_sep_angle_ctl) +! + call init_chara_ctl_item_label(hd_eye_step_mode, & + & streo%step_eye_sep_angle_ctl) +! + end subroutine init_stereo_view_ctl_label +! +! --------------------------------------------------------------------- +! + logical function cmp_streo_view_ctl(streo1, streo2) +! + use skip_comment_f +! + type(streo_view_ctl), intent(in) :: streo1, streo2 +! + cmp_streo_view_ctl = .FALSE. + if(streo1%i_stereo_view .ne. streo2%i_stereo_view) return + if(cmp_no_case(trim(streo1%block_name), & + & trim(streo2%block_name)) .eqv. .FALSE.) return +! + if(cmp_read_real_item(streo1%focalpoint_ctl, & + & streo2%focalpoint_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real_item(streo1%eye_separation_ctl, & + & streo2%eye_separation_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real_item(streo1%eye_sep_angle_ctl, & + & streo2%eye_sep_angle_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(streo1%step_eye_sep_angle_ctl, & + & streo2%step_eye_sep_angle_ctl) & + & .eqv. .FALSE.) return + cmp_streo_view_ctl = .TRUE. +! + end function cmp_streo_view_ctl +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine reset_stereo_view_ctl(streo) +! + type(streo_view_ctl), intent(inout) :: streo +! +! + streo%focalpoint_ctl%iflag = 0 + streo%eye_separation_ctl%iflag = 0 + streo%eye_sep_angle_ctl%iflag = 0 + streo%step_eye_sep_angle_ctl%iflag = 0 +! + streo%i_stereo_view = 0 +! + end subroutine reset_stereo_view_ctl +! +! --------------------------------------------------------------------- +! + subroutine copy_stereo_view_ctl(org_streo, new_streo) +! + type(streo_view_ctl), intent(in) :: org_streo + type(streo_view_ctl), intent(inout) :: new_streo +! +! + new_streo%block_name = org_streo%block_name + new_streo%i_stereo_view = org_streo%i_stereo_view +! + call copy_real_ctl(org_streo%focalpoint_ctl, & + & new_streo%focalpoint_ctl) + call copy_real_ctl(org_streo%eye_separation_ctl, & + & new_streo%eye_separation_ctl) + call copy_real_ctl(org_streo%eye_sep_angle_ctl, & + & new_streo%eye_sep_angle_ctl) + call copy_chara_ctl(org_streo%step_eye_sep_angle_ctl, & + & new_streo%step_eye_sep_angle_ctl) +! + end subroutine copy_stereo_view_ctl +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_4_streo_view diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_view_transfer.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_view_transfer.f90 new file mode 100644 index 00000000..006f866f --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_4_view_transfer.f90 @@ -0,0 +1,342 @@ +!>@file t_ctl_data_4_view_transfer.f90 +!!@brief module t_ctl_data_4_view_transfer +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!>@brief Control inputs for PVR view parameter +!! +!!@verbatim +!! subroutine dealloc_view_transfer_ctl(mat) +!! type(modeview_ctl), intent(inout) :: mat +!! subroutine dup_view_transfer_ctl(org_mat, new_mat) +!! type(modeview_ctl), intent(in) :: org_mat +!! type(modeview_ctl), intent(inout) :: new_mat +!! logical function cmp_modeview_ctl(mat1, mat2) +!! type(modeview_ctl), intent(in) :: mat1, mat2 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Input example +! +!! begin view_transform_ctl +!! +!! begin image_size_ctl +!! x_pixel_ctl 640 +!! y_pixel_ctl 480 +!! end image_size_ctl +!! +!! array look_at_point_ctl +!! look_at_point_ctl x 3.0 +!! look_at_point_ctl y -8.0 +!! look_at_point_ctl z 6.0 +!! end array look_at_point_ctl +!! +!! array eye_position_ctl +!! eye_position_ctl x 3.0 +!! eye_position_ctl y -8.0 +!! eye_position_ctl z 6.0 +!! end array eye_position_ctl +!! +!! array up_direction_ctl +!! up_direction_ctl x 0.0 +!! up_direction_ctl y 0.0 +!! up_direction_ctl z 1.0 +!! end array up_direction_ctl +!! +!! array view_rotation_vec_ctl +!! view_rotation_vec_ctl x 0.0 +!! view_rotation_vec_ctl y 0.0 +!! view_rotation_vec_ctl z 1.0 +!! end array view_rotation_vec_ctl +!! +!! view_rotation_deg_ctl 60.0 +!! +!! scale_factor_ctl 1.0 +!! array scale_factor_vec_ctl +!! scale_factor_vec_ctl x 0.0 +!! scale_factor_vec_ctl y 0.0 +!! scale_factor_vec_ctl z 1.0 +!! end array scale_factor_vec_ctl +!! +!! array eye_position_in_viewer_ctl +!! eye_position_in_viewer_ctl x 0.0 +!! eye_position_in_viewer_ctl y 0.0 +!! eye_position_in_viewer_ctl z 10.0 +!! end array eye_position_in_viewer_ctl +!! +!! array modelview_matrix_ctl +!! modelview_matrix_ctl 1 1 1.0 end +!! modelview_matrix_ctl 2 1 0.0 end +!! modelview_matrix_ctl 3 1 0.0 end +!! modelview_matrix_ctl 4 1 0.0 end +!! +!! modelview_matrix_ctl 1 2 0.0 end +!! modelview_matrix_ctl 2 2 1.0 end +!! modelview_matrix_ctl 3 2 0.0 end +!! modelview_matrix_ctl 4 2 0.0 end +!! +!! modelview_matrix_ctl 1 3 0.0 end +!! modelview_matrix_ctl 2 3 0.0 end +!! modelview_matrix_ctl 3 3 1.0 end +!! modelview_matrix_ctl 4 3 0.0 end +!! +!! modelview_matrix_ctl 1 4 0.0 end +!! modelview_matrix_ctl 2 4 0.0 end +!! modelview_matrix_ctl 3 4 0.0 end +!! modelview_matrix_ctl 4 4 1.0 end +!! end array modelview_matrix_ctl +!! +!! Orthogonal view....( perspective_near_ctl = perspective_far_ctl) +!! +!! projection_type_ctl Aitoff, xy_plane, xz_plane, yz_plane +!! begin projection_matrix_ctl +!! perspective_angle_ctl 10.0 +!! perspective_xy_ratio_ctl 1.0 +!! perspective_near_ctl 0.5 +!! perspective_far_ctl 1000.0 +!! +!! horizontal_range_ctl -2.4 2.4 +!! vertical_range_ctl -1.2 1.2 +!! end projection_matrix_ctl +!! +!! begin stereo_view_parameter_ctl +!! focal_distance_ctl 40.0 +!! eye_separation_ctl 0.5 +!! end stereo_view_parameter_ctl +!! +!! end view_transform_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +!! +! + module t_ctl_data_4_view_transfer +! + use m_precision +! + use m_constants + use m_machine_parameter + use t_read_control_elements + use t_control_array_real + use t_control_array_character + use t_control_array_charareal + use t_control_array_chara2real + use t_ctl_data_4_screen_pixel + use t_ctl_data_4_projection + use t_ctl_data_4_streo_view + use skip_comment_f +! + implicit none +! +! +!> Structure for modelview marices + type modeview_ctl +!> Control block name + character(len = kchara) :: block_name = 'view_transform_ctl' +! +!> Structure of screen resolution + type(screen_pixel_ctl) :: pixel +!> Structure for projection parameters + type(projection_ctl) :: proj +!> Structure of streo view parameters + type(streo_view_ctl) :: streo +! +!> Structure for opacity controls +!!@n modelview_mat_ctl%c1_tbl: 1st component name for matrix +!!@n modelview_mat_ctl%c2_tbl: 2nd component name for matrix +!!@n modelview_mat_ctl%vect: Modelview matrix + type(ctl_array_c2r) :: modelview_mat_ctl +! +!> Structure for look at controls +!!@n lookpoint_ctl%c_tbl: component of lookpoint +!!@n lookpoint_ctl%vect: Position of lookpoint + type(ctl_array_cr) :: lookpoint_ctl +! +!> Structure for viewpoint controls +!!@n viewpoint_ctl%c_tbl: Direction of viewpoint +!!@n viewpoint_ctl%vect: Position of viewpoint + type(ctl_array_cr) :: viewpoint_ctl +! +!> Structure for Up-directions controls +!!@n up_dir_ctl%c_tbl: Direction of Up-directions +!!@n up_dir_ctl%vect: Position of Up-directions + type(ctl_array_cr) :: up_dir_ctl +! +!> Structure for rotation of object +!!@n view_rot_vec_ctl%c_tbl: Direction of rotatin vector +!!@n view_rot_vec_ctl%vect: rotation vector + type(ctl_array_cr) :: view_rot_vec_ctl +! +!> Structure for rotation of rotatin angle of view + type(read_real_item) :: view_rotation_deg_ctl +!> Structure for scale factor + type(read_real_item) :: scale_factor_ctl +! +!> Structure for scale factor controls +!!@n scale_vector_ctl%c_tbl: Direction of scale factor +!!@n scale_vector_ctl%vect: Position of scale factor + type(ctl_array_cr) :: scale_vector_ctl +! +!> Structure for viewpoint in viewer controls +!!@n viewpt_in_viewer_ctl%c_tbl: Direction of viewpoint in viewer +!!@n viewpt_in_viewer_ctl%vect: Position of viewpoint in viewer + type(ctl_array_cr) :: viewpt_in_viewer_ctl +! +!> Structure for projection type for 2D plot + type(read_character_item) :: projection_type_ctl +! +!> loaded flag + integer (kind=kint) :: i_view_transform = 0 +! +!> Consistency check flag + logical :: flag_checked = .FALSE. + end type modeview_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine dealloc_view_transfer_ctl(mat) +! + type(modeview_ctl), intent(inout) :: mat +! +! + mat%i_view_transform = 0 +! + call dealloc_control_array_c2_r(mat%modelview_mat_ctl) + mat%modelview_mat_ctl%num = 0 + mat%modelview_mat_ctl%icou = 0 +! + call dealloc_control_array_c_r(mat%lookpoint_ctl) + call dealloc_control_array_c_r(mat%viewpoint_ctl) + call dealloc_control_array_c_r(mat%up_dir_ctl) + mat%lookpoint_ctl%num = 0 + mat%viewpoint_ctl%num = 0 + mat%up_dir_ctl%num = 0 + mat%lookpoint_ctl%icou = 0 + mat%viewpoint_ctl%icou = 0 + mat%up_dir_ctl%icou = 0 +! + call dealloc_control_array_c_r(mat%view_rot_vec_ctl) + call dealloc_control_array_c_r(mat%scale_vector_ctl) + call dealloc_control_array_c_r(mat%viewpt_in_viewer_ctl) + mat%view_rot_vec_ctl%num = 0 + mat%scale_vector_ctl%num = 0 + mat%viewpt_in_viewer_ctl%num = 0 + mat%view_rot_vec_ctl%icou = 0 + mat%scale_vector_ctl%icou = 0 + mat%viewpt_in_viewer_ctl%icou = 0 +! +! + mat%view_rotation_deg_ctl%realvalue = 0.0d0 + mat%scale_factor_ctl%realvalue = 1.0d0 +! + mat%view_rotation_deg_ctl%iflag = 0 + mat%scale_factor_ctl%iflag = 0 +! + mat%projection_type_ctl%iflag = 0 +! + call reset_image_size_ctl(mat%pixel) + call reset_projection_view_ctl(mat%proj) + call reset_stereo_view_ctl(mat%streo) +! + end subroutine dealloc_view_transfer_ctl +! +! --------------------------------------------------------------------- +! + subroutine dup_view_transfer_ctl(org_mat, new_mat) +! + type(modeview_ctl), intent(in) :: org_mat + type(modeview_ctl), intent(inout) :: new_mat +! +! + new_mat%block_name = org_mat%block_name + new_mat%i_view_transform = org_mat%i_view_transform +! + call dup_control_array_c_r(org_mat%lookpoint_ctl, & + & new_mat%lookpoint_ctl) + call dup_control_array_c_r(org_mat%viewpoint_ctl, & + & new_mat%viewpoint_ctl) + call dup_control_array_c_r(org_mat%up_dir_ctl, & + & new_mat%up_dir_ctl) +! + call dup_control_array_c_r(org_mat%view_rot_vec_ctl, & + & new_mat%view_rot_vec_ctl) + call dup_control_array_c_r(org_mat%scale_vector_ctl, & + & new_mat%scale_vector_ctl) + call dup_control_array_c_r(org_mat%viewpt_in_viewer_ctl, & + & new_mat%viewpt_in_viewer_ctl) +! + call dup_control_array_c2_r(org_mat%modelview_mat_ctl, & + & new_mat%modelview_mat_ctl) +! + call copy_real_ctl(org_mat%view_rotation_deg_ctl, & + & new_mat%view_rotation_deg_ctl) + call copy_real_ctl(org_mat%scale_factor_ctl, & + & new_mat%scale_factor_ctl) +! + call copy_chara_ctl(org_mat%projection_type_ctl, & + & new_mat%projection_type_ctl) +! + call copy_projection_mat_ctl(org_mat%proj, new_mat%proj) + call copy_image_size_ctl(org_mat%pixel, new_mat%pixel) + call copy_stereo_view_ctl(org_mat%streo, new_mat%streo) +! + end subroutine dup_view_transfer_ctl +! +! --------------------------------------------------------------------- +! + logical function cmp_modeview_ctl(mat1, mat2) +! + type(modeview_ctl), intent(in) :: mat1, mat2 +! + cmp_modeview_ctl = .FALSE. + if(mat1%i_view_transform .ne. mat2%i_view_transform) return + if(cmp_no_case(trim(mat1%block_name), & + & trim(mat2%block_name)) .eqv. .FALSE.) return +! + if(cmp_screen_pixel_ctl(mat1%pixel, mat2%pixel) & + & .eqv. .FALSE.) return + if(cmp_projection_ctl(mat1%proj, mat2%proj) .eqv. .FALSE.) return + if(cmp_streo_view_ctl(mat1%streo, mat2%streo) & + & .eqv. .FALSE.) return +! + if(cmp_control_array_c2_r(mat1%modelview_mat_ctl, & + & mat2%modelview_mat_ctl) & + & .eqv. .FALSE.) return +! + if(cmp_control_array_c_r(mat1%lookpoint_ctl, mat2%lookpoint_ctl) & + & .eqv. .FALSE.) return + if(cmp_control_array_c_r(mat1%viewpoint_ctl, mat2%viewpoint_ctl) & + & .eqv. .FALSE.) return + if(cmp_control_array_c_r(mat1%up_dir_ctl, mat2%up_dir_ctl) & + & .eqv. .FALSE.) return + if(cmp_control_array_c_r(mat1%view_rot_vec_ctl, & + & mat2%view_rot_vec_ctl) & + & .eqv. .FALSE.) return + if(cmp_control_array_c_r(mat1%scale_vector_ctl, & + & mat2%scale_vector_ctl) & + & .eqv. .FALSE.) return + if(cmp_control_array_c_r(mat1%viewpt_in_viewer_ctl, & + & mat2%viewpt_in_viewer_ctl) & + & .eqv. .FALSE.) return +! + if(cmp_read_real_item(mat1%view_rotation_deg_ctl, & + & mat2%view_rotation_deg_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real_item(mat1%scale_factor_ctl, & + & mat2%scale_factor_ctl) & + & .eqv. .FALSE.) return +! + if(cmp_read_chara_item(mat1%projection_type_ctl, & + & mat2%projection_type_ctl) & + & .eqv. .FALSE.) return +! + cmp_modeview_ctl = .TRUE. +! + end function cmp_modeview_ctl +! +! -------------------------------------------------------------------- +! + end module t_ctl_data_4_view_transfer diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_area.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_area.f90 new file mode 100644 index 00000000..594aefbc --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_area.f90 @@ -0,0 +1,184 @@ +!>@file t_ctl_data_pvr_area.f90 +!!@brief module t_ctl_data_pvr_area +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for parallel volume rendering +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine int_pvr_render_area_ctl(hd_block, render_area_c) +!! subroutine read_pvr_render_area_ctl & +!! & (id_control, hd_block, render_area_c, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_render_area_ctl), intent(inout) :: render_area_c +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_render_area_ctl & +!! & (id_control, hd_block, render_area_c, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_render_area_ctl), intent(in) :: render_area_c +!! integer(kind = kint), intent(inout) :: level +!! subroutine dup_pvr_render_area_ctl(org_rarea_c, new_rarea_c) +!! type(pvr_render_area_ctl), intent(in) :: org_rarea_c +!! type(pvr_render_area_ctl), intent(inout) :: new_rarea_c +!! subroutine dealloc_pvr_render_area_ctl(render_area_c) +!! type(pvr_render_area_ctl), intent(inout) :: render_area_c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! begin plot_area_ctl +!! array chosen_ele_grp_ctl 1 +!! chosen_ele_grp_ctl outer_core +!! end array chosen_ele_grp_ctl +!! +!! array surface_enhanse_ctl 2 +!! surface_enhanse_ctl ICB reverse_surface 0.7 +!! surface_enhanse_ctl CMB forward_surface 0.4 +!! end array surface_enhanse_ctl +!! end plot_area_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_pvr_area +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_array_character + use t_control_array_chara2real + use skip_comment_f +! + implicit none +! +! + type pvr_render_area_ctl +!> Control block name + character(len = kchara) :: block_name = 'FEM_sleeve_ctl' +! + type(ctl_array_chara) :: pvr_area_ctl + type(ctl_array_c2r) :: surf_enhanse_ctl +! + integer(kind = kint) :: i_plot_area = 0 + end type pvr_render_area_ctl +! +! 4th level for area group +! + character(len=kchara) :: hd_plot_grp = 'chosen_ele_grp_ctl' + character(len=kchara) :: hd_sf_enhanse = 'surface_enhanse_ctl' +! + private :: hd_plot_grp, hd_sf_enhanse +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_pvr_render_area_ctl & + & (id_control, hd_block, render_area_c, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_render_area_ctl), intent(inout) :: render_area_c + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(render_area_c%i_plot_area .gt. 0) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! +! + call read_control_array_c1(id_control, hd_plot_grp, & + & render_area_c%pvr_area_ctl, c_buf) + call read_control_array_c2_r(id_control, hd_sf_enhanse, & + & render_area_c%surf_enhanse_ctl, c_buf) + end do + render_area_c%i_plot_area = 1 +! + end subroutine read_pvr_render_area_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_pvr_render_area_ctl & + & (id_control, hd_block, render_area_c, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_render_area_ctl), intent(in) :: render_area_c + integer(kind = kint), intent(inout) :: level +! +! + if(render_area_c%i_plot_area .le. 0) return +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_control_array_c1(id_control, level, & + & render_area_c%pvr_area_ctl) + call write_control_array_c2_r(id_control, level, & + & render_area_c%surf_enhanse_ctl) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_pvr_render_area_ctl +! +! --------------------------------------------------------------------- +! + subroutine int_pvr_render_area_ctl(hd_block, render_area_c) +! + character(len=kchara), intent(in) :: hd_block + type(pvr_render_area_ctl), intent(inout) :: render_area_c +! +! + render_area_c%block_name = hd_block + call init_chara_ctl_array_label(hd_plot_grp, & + & render_area_c%pvr_area_ctl) + call init_c2_r_ctl_array_label(hd_sf_enhanse, & + & render_area_c%surf_enhanse_ctl) +! + end subroutine int_pvr_render_area_ctl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dup_pvr_render_area_ctl(org_rarea_c, new_rarea_c) +! + type(pvr_render_area_ctl), intent(in) :: org_rarea_c + type(pvr_render_area_ctl), intent(inout) :: new_rarea_c +! +! + call dup_control_array_c1(org_rarea_c%pvr_area_ctl, & + & new_rarea_c%pvr_area_ctl) + call dup_control_array_c2_r(org_rarea_c%surf_enhanse_ctl, & + & new_rarea_c%surf_enhanse_ctl) +! + new_rarea_c%i_plot_area = org_rarea_c%i_plot_area + new_rarea_c%block_name = org_rarea_c%block_name +! + end subroutine dup_pvr_render_area_ctl +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_render_area_ctl(render_area_c) +! + type(pvr_render_area_ctl), intent(inout) :: render_area_c +! +! + call dealloc_control_array_chara(render_area_c%pvr_area_ctl) + call dealloc_control_array_c2_r(render_area_c%surf_enhanse_ctl) + render_area_c%pvr_area_ctl%icou = 0 + render_area_c%surf_enhanse_ctl%icou = 0 +! + render_area_c%i_plot_area = 0 +! + end subroutine dealloc_pvr_render_area_ctl +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_pvr_area diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_colorbar.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_colorbar.f90 new file mode 100644 index 00000000..5fed87d7 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_colorbar.f90 @@ -0,0 +1,183 @@ +!>@file t_ctl_data_pvr_colorbar.f90 +!!@brief module t_ctl_data_pvr_colorbar +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief colormap control data for parallel volume rendering +!! +!!@verbatim +!! subroutine reset_pvr_colorbar_ctl_flags(cbar_ctl) +!! type(pvr_colorbar_ctl), intent(inout) :: cbar_ctl +!! subroutine copy_pvr_colorbar_ctl(org_cbar_c, new_cbar_c) +!! type(pvr_colorbar_ctl), intent(in) :: org_cbar_c +!! type(pvr_colorbar_ctl), intent(inout) :: new_cbar_c +!! logical function cmp_pvr_colorbar_ctl(cbar_ctl1, cbar_ctl2) +!! type(read_character_item), intent(in) :: cbar_ctl1, cbar_ctl2 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! example of color control for Kemo's volume rendering +!! +!!begin volume_rendering (BMP or PNG) +!! begin colorbar_ctl +!! colorbar_switch_ctl ON +!! colorbar_scale_ctl ON +!! colorbar_position_ctl 'side' or 'bottom' +!! zeromarker_switch ON +!! colorbar_range 0.0 1.0 +!! font_size_ctl 3 +!! num_grid_ctl 4 +!!! +!! axis_label_switch ON +!! time_label_switch ON +!! map_grid_switch ON +!! end colorbar_ctl +!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_pvr_colorbar +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_ctl_data_4_view_transfer + use t_control_array_character + use t_control_array_integer + use t_control_array_real2 +! + implicit none +! + type pvr_colorbar_ctl +!> Control block name + character(len = kchara) :: block_name = 'colorbar_ctl' +! + type(read_character_item) :: colorbar_switch_ctl + type(read_character_item) :: colorbar_scale_ctl + type(read_character_item) :: colorbar_position_ctl + type(read_character_item) :: zeromarker_flag_ctl + type(read_integer_item) :: font_size_ctl + type(read_integer_item) :: ngrid_cbar_ctl + type(read_real2_item) :: cbar_range_ctl +! + type(read_character_item) :: axis_switch_ctl + type(read_character_item) :: time_switch_ctl + type(read_character_item) :: mapgrid_switch_ctl +! +! 2nd level for volume rendering + integer(kind = kint) :: i_pvr_colorbar = 0 + end type pvr_colorbar_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine reset_pvr_colorbar_ctl_flags(cbar_ctl) +! + type(pvr_colorbar_ctl), intent(inout) :: cbar_ctl +! +! + cbar_ctl%colorbar_switch_ctl%iflag = 0 + cbar_ctl%colorbar_scale_ctl%iflag = 0 + cbar_ctl%colorbar_position_ctl%iflag = 0 + cbar_ctl%font_size_ctl%iflag = 0 + cbar_ctl%ngrid_cbar_ctl%iflag = 0 + cbar_ctl%zeromarker_flag_ctl%iflag = 0 + cbar_ctl%cbar_range_ctl%iflag = 0 +! + cbar_ctl%i_pvr_colorbar = 0 +! + end subroutine reset_pvr_colorbar_ctl_flags +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine copy_pvr_colorbar_ctl(org_cbar_c, new_cbar_c) +! + type(pvr_colorbar_ctl), intent(in) :: org_cbar_c + type(pvr_colorbar_ctl), intent(inout) :: new_cbar_c +! +! + new_cbar_c%i_pvr_colorbar = org_cbar_c%i_pvr_colorbar +! + call copy_integer_ctl(org_cbar_c%font_size_ctl, & + & new_cbar_c%font_size_ctl) + call copy_integer_ctl(org_cbar_c%ngrid_cbar_ctl, & + & new_cbar_c%ngrid_cbar_ctl) +! + call copy_chara_ctl(org_cbar_c%colorbar_switch_ctl, & + & new_cbar_c%colorbar_switch_ctl) + call copy_chara_ctl(org_cbar_c%colorbar_scale_ctl, & + & new_cbar_c%colorbar_scale_ctl) + call copy_chara_ctl(org_cbar_c%colorbar_position_ctl, & + & new_cbar_c%colorbar_position_ctl) + call copy_chara_ctl(org_cbar_c%zeromarker_flag_ctl, & + & new_cbar_c%zeromarker_flag_ctl) +! + call copy_chara_ctl(org_cbar_c%axis_switch_ctl, & + & new_cbar_c%axis_switch_ctl) + call copy_chara_ctl(org_cbar_c%time_switch_ctl, & + & new_cbar_c%time_switch_ctl) + call copy_chara_ctl(org_cbar_c%mapgrid_switch_ctl, & + & new_cbar_c%mapgrid_switch_ctl) +! + call copy_real2_ctl(org_cbar_c%cbar_range_ctl, & + & new_cbar_c%cbar_range_ctl) +! + end subroutine copy_pvr_colorbar_ctl +! +! --------------------------------------------------------------------- +! + logical function cmp_pvr_colorbar_ctl(cbar_ctl1, cbar_ctl2) +! + use skip_comment_f +! + type(pvr_colorbar_ctl), intent(in) :: cbar_ctl1, cbar_ctl2 +! + cmp_pvr_colorbar_ctl = .FALSE. + if(cbar_ctl1%i_pvr_colorbar .ne. cbar_ctl2%i_pvr_colorbar) return + if(cmp_no_case(trim(cbar_ctl1%block_name), & + & trim(cbar_ctl2%block_name)) .eqv. .FALSE.) return + if(cmp_read_chara_item(cbar_ctl1%colorbar_switch_ctl, & + & cbar_ctl2%colorbar_switch_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(cbar_ctl1%colorbar_scale_ctl, & + & cbar_ctl2%colorbar_scale_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(cbar_ctl1%colorbar_position_ctl, & + & cbar_ctl2%colorbar_position_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(cbar_ctl1%zeromarker_flag_ctl, & + & cbar_ctl2%zeromarker_flag_ctl) & + & .eqv. .FALSE.) return +! +! + if(cmp_read_integer_item(cbar_ctl1%font_size_ctl, & + & cbar_ctl2%font_size_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_integer_item(cbar_ctl1%ngrid_cbar_ctl, & + & cbar_ctl2%ngrid_cbar_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real2_item(cbar_ctl1%cbar_range_ctl, & + & cbar_ctl2%cbar_range_ctl) & + & .eqv. .FALSE.) return +! + if(cmp_read_chara_item(cbar_ctl1%axis_switch_ctl, & + & cbar_ctl2%axis_switch_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(cbar_ctl1%time_switch_ctl, & + & cbar_ctl2%time_switch_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(cbar_ctl1%mapgrid_switch_ctl, & + & cbar_ctl2%mapgrid_switch_ctl) & + & .eqv. .FALSE.) return +! + cmp_pvr_colorbar_ctl = .TRUE. +! + end function cmp_pvr_colorbar_ctl +! +! -------------------------------------------------------------------- +! + end module t_ctl_data_pvr_colorbar diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_colormap.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_colormap.f90 new file mode 100644 index 00000000..8444506e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_colormap.f90 @@ -0,0 +1,258 @@ +!>@file t_ctl_data_pvr_colormap.f90 +!!@brief module t_ctl_data_pvr_colormap +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief colormap control data for parallel volume rendering +!! +!!@verbatim +!! subroutine reset_pvr_colormap_flags(color) +!! subroutine dealloc_pvr_color_crl(color) +!! type(pvr_colormap_ctl), intent(inout) :: color +!! subroutine dup_pvr_colordef_ctl(org_color, new_color) +!! type(pvr_colormap_ctl), intent(in) :: org_color +!! type(pvr_colormap_ctl), intent(inout) :: new_color +!! logical function cmp_pvr_colormap_ctl(color1, color2) +!! type(pvr_colormap_ctl), intent(in) :: color1, color2 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! example of color control for Kemo's volume rendering +!! +!! begin colormap_ctl +!! colormap_mode_ctl rainbow +!! background_color_ctl 0.0 0.0 0.0 +!!! +!! LIC_color_field magnetic_field +!! LIC_color_componenet magnitude +!! +!! LIC_transparent_field magnetic_field +!! LIC_transparent_componenet magnitude +!!! +!! data_mapping_ctl Colormap_list +!! array color_table_ctl 3 +!! color_table_ctl 0.0 0.0 +!! color_table_ctl 0.5 0.5 +!! color_table_ctl 1.0 1.0 +!! end array color_table_ctl +!!! +!! opacity_style_ctl point_linear +!! array linear_opacity_ctl 7 +!! linear_opacity_ctl 0.0 0.01 +!! linear_opacity_ctl 0.01 0.015 +!! linear_opacity_ctl 0.2 0.02 +!! linear_opacity_ctl 0.6 0.04 +!! linear_opacity_ctl 0.7 0.03 +!! linear_opacity_ctl 0.85 0.01 +!! linear_opacity_ctl 0.95 0.001 +!! end array linear_opacity_ctl +!! constant_opacity_ctl 0.003 +!!! +!! range_min_ctl 0.0 +!! range_max_ctl 1.0 +!! end colormap_ctl +!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_pvr_colormap +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_ctl_data_4_view_transfer + use t_control_array_character + use t_control_array_real + use t_control_array_real2 + use t_control_array_real3 +! + implicit none +! +! + type pvr_colormap_ctl +!> Control block name + character(len = kchara) :: block_name = 'colormap_ctl' +!! + type(read_character_item) :: lic_color_fld_ctl + type(read_character_item) :: lic_color_comp_ctl + type(read_character_item) :: lic_opacity_fld_ctl + type(read_character_item) :: lic_opacity_comp_ctl +! + type(read_character_item) :: colormap_mode_ctl + type(read_character_item) :: data_mapping_ctl + type(read_character_item) :: opacity_style_ctl +! + type(read_real_item) :: range_min_ctl + type(read_real_item) :: range_max_ctl + type(read_real_item) :: fix_opacity_ctl +! +!> Structure for color map controls +!!@n colortbl_ctl%vec1: field data value +!!@n colortbl_ctl%vec2: color map value + type(ctl_array_r2) :: colortbl_ctl +! +!> Structure for opacity controls +!!@n linear_opacity_ctl%vec1: field value to define opacity +!!@n linear_opacity_ctl%vec3: Opacity at this point + type(ctl_array_r2) :: linear_opacity_ctl +! +!> Structure for background color (R,G,B) + type(read_real3_item) :: background_color_ctl +! +! Top level +! 2nd level for color definition + integer (kind=kint) :: i_pvr_colordef = 0 + end type pvr_colormap_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine reset_pvr_colormap_flags(color) +! + type(pvr_colormap_ctl), intent(inout) :: color +! +! + color%lic_color_fld_ctl%iflag = 0 + color%lic_color_comp_ctl%iflag = 0 + color%lic_opacity_fld_ctl%iflag = 0 + color%lic_opacity_comp_ctl%iflag = 0 +! + color%colormap_mode_ctl%iflag = 0 + color%data_mapping_ctl%iflag = 0 + color%range_min_ctl%iflag = 0 + color%range_max_ctl%iflag = 0 + color%opacity_style_ctl%iflag = 0 + color%fix_opacity_ctl%iflag = 0 + color%background_color_ctl%iflag = 0 +! + color%i_pvr_colordef = 0 +! + end subroutine reset_pvr_colormap_flags +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_color_crl(color) +! + type(pvr_colormap_ctl), intent(inout) :: color +! +! + call reset_pvr_colormap_flags(color) + call dealloc_control_array_r2(color%linear_opacity_ctl) + call dealloc_control_array_r2(color%colortbl_ctl) +! + color%colortbl_ctl%num = 0 + color%colortbl_ctl%icou = 0 + color%linear_opacity_ctl%num = 0 + color%linear_opacity_ctl%icou = 0 +! + end subroutine dealloc_pvr_color_crl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dup_pvr_colordef_ctl(org_color, new_color) +! + type(pvr_colormap_ctl), intent(in) :: org_color + type(pvr_colormap_ctl), intent(inout) :: new_color +! +! + new_color%block_name = org_color%block_name + new_color%i_pvr_colordef = org_color%i_pvr_colordef +! + call dup_control_array_r2(org_color%colortbl_ctl, & + & new_color%colortbl_ctl) + call dup_control_array_r2(org_color%linear_opacity_ctl, & + & new_color%linear_opacity_ctl) +! + call copy_chara_ctl(org_color%lic_color_fld_ctl, & + & new_color%lic_color_fld_ctl) + call copy_chara_ctl(org_color%lic_color_comp_ctl, & + & new_color%lic_color_comp_ctl) + call copy_chara_ctl(org_color%lic_opacity_fld_ctl, & + & new_color%lic_opacity_fld_ctl) + call copy_chara_ctl(org_color%lic_opacity_comp_ctl, & + & new_color%lic_opacity_comp_ctl) +! + call copy_chara_ctl(org_color%colormap_mode_ctl, & + & new_color%colormap_mode_ctl) + call copy_chara_ctl(org_color%data_mapping_ctl, & + & new_color%data_mapping_ctl) + call copy_chara_ctl(org_color%opacity_style_ctl, & + & new_color%opacity_style_ctl) +! + call copy_real_ctl(org_color%range_min_ctl, & + & new_color%range_min_ctl) + call copy_real_ctl(org_color%range_max_ctl, & + & new_color%range_max_ctl) + call copy_real_ctl(org_color%fix_opacity_ctl, & + & new_color%fix_opacity_ctl) + call copy_real3_ctl(org_color%background_color_ctl, & + & new_color%background_color_ctl)! + end subroutine dup_pvr_colordef_ctl +! +! --------------------------------------------------------------------- +! + logical function cmp_pvr_colormap_ctl(color1, color2) +! + use skip_comment_f +! + type(pvr_colormap_ctl), intent(in) :: color1, color2 +! + cmp_pvr_colormap_ctl = .FALSE. + if(color1%i_pvr_colordef .ne. color2%i_pvr_colordef) return + if(cmp_no_case(trim(color1%block_name), & + & trim(color2%block_name)) .eqv. .FALSE.) return + if(cmp_read_chara_item(color1%lic_color_fld_ctl, & + & color2%lic_color_fld_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(color1%lic_color_comp_ctl, & + & color2%lic_color_comp_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(color1%lic_opacity_fld_ctl, & + & color2%lic_opacity_fld_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(color1%lic_opacity_comp_ctl, & + & color2%lic_opacity_comp_ctl) & + & .eqv. .FALSE.) return +! + if(cmp_read_chara_item(color1%colormap_mode_ctl, & + & color2%colormap_mode_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(color1%data_mapping_ctl, & + & color2%data_mapping_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_chara_item(color1%opacity_style_ctl, & + & color2%opacity_style_ctl) & + & .eqv. .FALSE.) return +! + if(cmp_read_real_item(color1%range_min_ctl, & + & color2%range_min_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real_item(color1%range_max_ctl, & + & color2%range_max_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real_item(color1%fix_opacity_ctl, & + & color2%fix_opacity_ctl) & + & .eqv. .FALSE.) return +! + if(cmp_control_array_r2(color1%colortbl_ctl, & + & color2%colortbl_ctl) & + & .eqv. .FALSE.) return + if(cmp_control_array_r2(color1%linear_opacity_ctl, & + & color2%linear_opacity_ctl) & + & .eqv. .FALSE.) return +! + if(cmp_read_real3_item(color1%background_color_ctl, & + & color2%background_color_ctl) & + & .eqv. .FALSE.) return +! + cmp_pvr_colormap_ctl = .TRUE. +! + end function cmp_pvr_colormap_ctl +! +! -------------------------------------------------------------------- +! + end module t_ctl_data_pvr_colormap diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_colormap_bar.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_colormap_bar.f90 new file mode 100644 index 00000000..62bc6985 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_colormap_bar.f90 @@ -0,0 +1,419 @@ +!>@file t_ctl_data_pvr_colormap_bar.f90 +!!@brief module t_ctl_data_pvr_colormap_bar +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief colormap control data for parallel volume rendering +!! +!!@verbatim +!! subroutine init_pvr_cmap_cbar_label(hd_block, cmap_cbar_c) +!! subroutine sel_read_ctl_pvr_colormap_file & +!! & (id_control, hd_block, file_name, cmap_cbar_c, c_buf) +!! subroutine read_pvr_cmap_cbar & +!! & (id_control, hd_block, cmap_cbar_c, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! character(len = kchara), intent(inout) :: file_name +!! type(pvr_colormap_bar_ctl), intent(inout) :: cmap_cbar_c +!! type(buffer_for_control), intent(inout) :: c_buf +!! type(pvr_colormap_bar_ctl), intent(inout) :: cmap_cbar_c +!! +!! subroutine sel_write_ctl_pvr_colormap_file & +!! & (id_control, hd_block, file_name, cmap_cbar_c, level) +!! subroutine write_control_pvr_colormap_file & +!! & (id_control, file_name, hd_block, cmap_cbar_c) +!! subroutine write_pvr_cmap_cbar(id_control, hd_block, & +!! & cmap_cbar_c, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len = kchara), intent(in) :: file_name +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_colormap_bar_ctl), intent(in) :: cmap_cbar_c +!! integer(kind = kint), intent(inout) :: level +!! +!! logical function cmp_pvr_colormap_bar_ctl(cmap_cbar1, & +!! & cmap_cbar2) +!! type(pvr_colormap_bar_ctl), intent(in) :: cmap_cbar1 +!! type(pvr_colormap_bar_ctl), intent(in) :: cmap_cbar2 +!! +!! subroutine deallocate_pvr_cmap_cbar(cmap_cbar_c) +!! type(pvr_colormap_bar_ctl), intent(inout) :: cmap_cbar_c +!! +!! subroutine dup_pvr_cmap_cbar(org_cmap_cbar_c, new_cmap_cbar_c) +!! type(pvr_colormap_bar_ctl), intent(in) :: org_cmap_cbar_c +!! type(pvr_colormap_bar_ctl), intent(inout) :: new_cmap_cbar_c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! example of color control for Kemo's volume rendering +!! +!! begin pvr_color_ctl (BMP or PNG) +!! begin colormap_ctl +!! colormap_mode_ctl rainbow +!! background_color_ctl 0.0 0.0 0.0 +!!! +!! LIC_color_field magnetic_field +!! LIC_color_componenet magnitude +!! +!! LIC_transparent_field magnetic_field +!! LIC_transparent_componenet magnitude +!!! +!! data_mapping_ctl Colormap_list +!! array color_table_ctl +!! color_table_ctl 0.0 0.0 +!! color_table_ctl 0.5 0.5 +!! color_table_ctl 1.0 1.0 +!! end array color_table_ctl +!!! +!! opacity_style_ctl point_linear +!! array linear_opacity_ctl +!! linear_opacity_ctl 0.0 0.01 +!! linear_opacity_ctl 0.01 0.015 +!! linear_opacity_ctl 0.2 0.02 +!! linear_opacity_ctl 0.6 0.04 +!! linear_opacity_ctl 0.7 0.03 +!! linear_opacity_ctl 0.85 0.01 +!! linear_opacity_ctl 0.95 0.001 +!! end array linear_opacity_ctl +!! constant_opacity_ctl 0.003 +!!! +!! range_min_ctl 0.0 +!! range_max_ctl 1.0 +!! end colormap_ctl +!! +!! begin colorbar_ctl +!! colorbar_switch_ctl ON +!! colorbar_position_ctl 'left' or 'bottom' +!! colorbar_scale_ctl ON +!! zeromarker_switch ON +!! colorbar_range 0.0 1.0 +!! font_size_ctl 3 +!! num_grid_ctl 4 +!!! +!! axis_label_switch ON +!! end colorbar_ctl +!! end pvr_color_ctl +!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_pvr_colormap_bar +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_ctl_data_pvr_colormap + use t_ctl_data_pvr_colorbar + use skip_comment_f +! + implicit none +! +! +!> Structure of control data for PVR colormap and colorbar + type pvr_colormap_bar_ctl +!> Control block name + character(len = kchara) :: block_name = 'pvr_color_ctl' +!> Structure for colormap + type(pvr_colormap_ctl) :: color +!> Structure for colorbar + type(pvr_colorbar_ctl) :: cbar_ctl +! + integer (kind=kint) :: i_cmap_cbar = 0 + end type pvr_colormap_bar_ctl +! +! 2nd level for colormap and colorbar +! + character(len=kchara) :: hd_colormap_file = "pvr_color_ctl" +! + character(len=kchara) :: hd_colormap = 'colormap_ctl' + character(len=kchara) :: hd_pvr_colorbar = 'colorbar_ctl' +! + private :: hd_colormap, hd_pvr_colorbar + private :: hd_colormap_file +! + private :: read_control_pvr_colormap_file +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine sel_read_ctl_pvr_colormap_file & + & (id_control, hd_block, file_name, cmap_cbar_c, c_buf) +! + use write_control_elements + use ctl_data_pvr_colorbar_IO + use ctl_data_pvr_colormap_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + character(len = kchara), intent(inout) :: file_name + type(pvr_colormap_bar_ctl), intent(inout) :: cmap_cbar_c + type(buffer_for_control), intent(inout) :: c_buf +! +! +! + if(check_file_flag(c_buf, hd_block)) then + file_name = third_word(c_buf) +! + call write_one_ctl_file_message & + & (hd_block, c_buf%level, file_name) + call read_control_pvr_colormap_file & + & (id_control+2, file_name, hd_block, cmap_cbar_c, c_buf) +! + else if(check_begin_flag(c_buf, hd_block)) then + file_name = 'NO_FILE' + call write_included_message(hd_block, c_buf%level) + call read_pvr_cmap_cbar(id_control, hd_block, & + & cmap_cbar_c, c_buf) + else if(cmap_cbar_c%i_cmap_cbar .eq. 0) then + file_name = 'NO_FILE' +! + call read_pvr_colordef_ctl(id_control, hd_colormap_file, & + & cmap_cbar_c%color, c_buf) + call read_pvr_colordef_ctl(id_control, hd_colormap, & + & cmap_cbar_c%color, c_buf) +! + call read_pvr_colorbar_ctl(id_control, hd_pvr_colorbar, & + & cmap_cbar_c%cbar_ctl, c_buf) + end if +! + end subroutine sel_read_ctl_pvr_colormap_file +! +! --------------------------------------------------------------------- +! + subroutine read_control_pvr_colormap_file & + & (id_control, file_name, hd_block, cmap_cbar_c, c_buf) +! + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(pvr_colormap_bar_ctl), intent(inout) :: cmap_cbar_c + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(no_file_flag(file_name)) then + write(*,*) 'Colormap control is included' + return + end if +! +! + c_buf%level = c_buf%level + 1 + open(id_control, file = file_name, status='old') +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit +! + call read_pvr_cmap_cbar(id_control, hd_block, & + & cmap_cbar_c, c_buf) + call read_pvr_cmap_cbar(id_control, hd_colormap_file, & + & cmap_cbar_c, c_buf) + if(cmap_cbar_c%i_cmap_cbar .gt. 0) exit + end do + close(id_control) +! + c_buf%level = c_buf%level - 1 +! + end subroutine read_control_pvr_colormap_file +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine read_pvr_cmap_cbar & + & (id_control, hd_block, cmap_cbar_c, c_buf) +! + use ctl_data_pvr_colorbar_IO + use ctl_data_pvr_colormap_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(pvr_colormap_bar_ctl), intent(inout) :: cmap_cbar_c + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(cmap_cbar_c%i_cmap_cbar .gt. 0) return + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_pvr_colordef_ctl(id_control, hd_colormap, & + & cmap_cbar_c%color, c_buf) + call read_pvr_colorbar_ctl(id_control, hd_pvr_colorbar, & + & cmap_cbar_c%cbar_ctl, c_buf) + end do + cmap_cbar_c%i_cmap_cbar = 1 +! + end subroutine read_pvr_cmap_cbar +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_cmap_cbar_label(hd_block, cmap_cbar_c) +! + use ctl_data_pvr_colorbar_IO + use ctl_data_pvr_colormap_IO +! + character(len=kchara), intent(in) :: hd_block + type(pvr_colormap_bar_ctl), intent(inout) :: cmap_cbar_c +! +! + cmap_cbar_c%block_name = hd_block + call init_pvr_colordef_ctl_labels(hd_colormap, & + & cmap_cbar_c%color) + call init_pvr_colorbar_ctl_label(hd_pvr_colorbar, & + & cmap_cbar_c%cbar_ctl) +! + end subroutine init_pvr_cmap_cbar_label +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine sel_write_ctl_pvr_colormap_file & + & (id_control, hd_block, file_name, cmap_cbar_c, level) +! + use ctl_data_pvr_colorbar_IO + use ctl_data_pvr_colormap_IO + use write_control_elements + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(pvr_colormap_bar_ctl), intent(in) :: cmap_cbar_c +! + integer(kind = kint), intent(inout) :: level +! +! + if(cmp_no_case(file_name, 'NO_FILE')) then + call write_pvr_colordef_ctl(id_control, hd_colormap, & + & cmap_cbar_c%color, level) + call write_pvr_colorbar_ctl(id_control, hd_pvr_colorbar, & + & cmap_cbar_c%cbar_ctl, level) + else if(id_control .eq. id_monitor) then + write(*,'(4a)') '! ', trim(hd_block), & + & ' should be written to file ... ', trim(file_name) + call write_pvr_colorbar_ctl(id_control, hd_pvr_colorbar, & + & cmap_cbar_c%cbar_ctl, level) + else + write(*,'(3a)') trim(hd_block), & + & ' is written to file ... ', trim(file_name) + call write_file_name_for_ctl_line(id_control, level, & + & hd_block, file_name) + call write_control_pvr_colormap_file & + & (id_control+2, file_name, hd_block, cmap_cbar_c) + end if +! + end subroutine sel_write_ctl_pvr_colormap_file +! +! --------------------------------------------------------------------- +! + subroutine write_control_pvr_colormap_file & + & (id_control, file_name, hd_block, cmap_cbar_c) +! + integer(kind = kint), intent(in) :: id_control + character(len = kchara), intent(in) :: file_name + character(len=kchara), intent(in) :: hd_block + type(pvr_colormap_bar_ctl), intent(in) :: cmap_cbar_c +! + integer(kind = kint) :: level +! +! + if(no_file_flag(file_name)) return +! + level = 0 + open(id_control, file = file_name) + call write_pvr_cmap_cbar(id_control, hd_block, & + & cmap_cbar_c, level) + close(id_control) +! + end subroutine write_control_pvr_colormap_file +! +! --------------------------------------------------------------------- +! + subroutine write_pvr_cmap_cbar(id_control, hd_block, & + & cmap_cbar_c, level) +! + use ctl_data_pvr_colorbar_IO + use ctl_data_pvr_colormap_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_colormap_bar_ctl), intent(in) :: cmap_cbar_c +! + integer(kind = kint), intent(inout) :: level +! +! + if(cmap_cbar_c%i_cmap_cbar .le. 0) return +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_pvr_colordef_ctl(id_control, hd_colormap, & + & cmap_cbar_c%color, level) + call write_pvr_colorbar_ctl(id_control, hd_pvr_colorbar, & + & cmap_cbar_c%cbar_ctl, level) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_pvr_cmap_cbar +! +! --------------------------------------------------------------------- +! + logical function cmp_pvr_colormap_bar_ctl(cmap_cbar1, & + & cmap_cbar2) +! + type(pvr_colormap_bar_ctl), intent(in) :: cmap_cbar1 + type(pvr_colormap_bar_ctl), intent(in) :: cmap_cbar2 +! + cmp_pvr_colormap_bar_ctl = .FALSE. + if(cmap_cbar1%i_cmap_cbar .ne. cmap_cbar2%i_cmap_cbar) return + if(cmp_no_case(trim(cmap_cbar1%block_name), & + & trim(cmap_cbar2%block_name)) .eqv. .FALSE.) return + if(cmp_pvr_colormap_ctl(cmap_cbar1%color, cmap_cbar2%color) & + & .eqv. .FALSE.) return + if(cmp_pvr_colorbar_ctl(cmap_cbar1%cbar_ctl, cmap_cbar2%cbar_ctl) & + & .eqv. .FALSE.) return +! + cmp_pvr_colormap_bar_ctl = .TRUE. +! + end function cmp_pvr_colormap_bar_ctl +! +! -------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine deallocate_pvr_cmap_cbar(cmap_cbar_c) +! + type(pvr_colormap_bar_ctl), intent(inout) :: cmap_cbar_c +! + call reset_pvr_colorbar_ctl_flags(cmap_cbar_c%cbar_ctl) + call dealloc_pvr_color_crl(cmap_cbar_c%color) +! + cmap_cbar_c%i_cmap_cbar = 0 +! + end subroutine deallocate_pvr_cmap_cbar +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dup_pvr_cmap_cbar(org_cmap_cbar_c, new_cmap_cbar_c) +! + type(pvr_colormap_bar_ctl), intent(in) :: org_cmap_cbar_c + type(pvr_colormap_bar_ctl), intent(inout) :: new_cmap_cbar_c +! +! + new_cmap_cbar_c%block_name = org_cmap_cbar_c%block_name + new_cmap_cbar_c%i_cmap_cbar = org_cmap_cbar_c%i_cmap_cbar +! + call dup_pvr_colordef_ctl(org_cmap_cbar_c%color, & + & new_cmap_cbar_c%color) + call copy_pvr_colorbar_ctl(org_cmap_cbar_c%cbar_ctl, & + & new_cmap_cbar_c%cbar_ctl) +! + end subroutine dup_pvr_cmap_cbar +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_pvr_colormap_bar diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_isosurface.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_isosurface.f90 new file mode 100644 index 00000000..daf7e818 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_isosurface.f90 @@ -0,0 +1,187 @@ +!>@file t_ctl_data_pvr_isosurface.f90 +!!@brief module t_ctl_data_pvr_isosurface +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief isosurface control data for parallel volume rendering +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine init_pvr_isosurface_ctl_label(hd_block, pvr_iso_ctl) +!! subroutine read_pvr_isosurface_ctl & +!! & (id_control, hd_block, pvr_iso_ctl, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_isosurf_ctl), intent(inout) :: pvr_iso_ctl +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_isosurface_ctl & +!! & (id_control, hd_block, pvr_iso_ctl, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_isosurf_ctl), intent(in) :: pvr_iso_ctl +!! integer(kind = kint), intent(inout) :: level +!! +!! subroutine dup_pvr_isosurface_ctl(org_pvr_iso_c, new_pvr_iso_c) +!! type(pvr_isosurf_ctl), intent(in) :: org_pvr_iso_c +!! type(pvr_isosurf_ctl), intent(inout) :: new_pvr_iso_c +!! subroutine reset_pvr_isosurface_ctl(pvr_iso_ctl) +!! type(pvr_isosurf_ctl), intent(inout) :: pvr_iso_ctl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! begin isosurface_ctl +!! isosurf_value 0.3 +!! opacity_ctl 0.9 +!! surface_direction normal +!! end isosurface_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_pvr_isosurface +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_array_character + use t_control_array_real + use skip_comment_f +! + implicit none +! +! + type pvr_isosurf_ctl +!> Control block name + character(len = kchara) :: block_name = 'isosurface_ctl' +! + type(read_character_item) :: isosurf_type_ctl + type(read_real_item) :: iso_value_ctl + type(read_real_item) :: opacity_ctl + integer(kind = kint) :: i_pvr_isosurf_ctl = 0 + end type pvr_isosurf_ctl +! +! 3rd level for isosurface +! + character(len=kchara) :: hd_isosurf_value = 'isosurf_value' + character(len=kchara) :: hd_pvr_opacity = 'opacity_ctl' + character(len=kchara) :: hd_iso_direction = 'surface_direction' +! + private :: hd_isosurf_value, hd_pvr_opacity, hd_iso_direction +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_pvr_isosurface_ctl & + & (id_control, hd_block, pvr_iso_ctl, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_isosurf_ctl), intent(inout) :: pvr_iso_ctl + type(buffer_for_control), intent(inout) :: c_buf +! +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_chara_ctl_type(c_buf, hd_iso_direction, & + & pvr_iso_ctl%isosurf_type_ctl) + call read_real_ctl_type & + & (c_buf, hd_isosurf_value, pvr_iso_ctl%iso_value_ctl) + call read_real_ctl_type & + & (c_buf, hd_pvr_opacity, pvr_iso_ctl%opacity_ctl) + end do + pvr_iso_ctl%i_pvr_isosurf_ctl = 1 +! + end subroutine read_pvr_isosurface_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_pvr_isosurface_ctl & + & (id_control, hd_block, pvr_iso_ctl, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_isosurf_ctl), intent(in) :: pvr_iso_ctl + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(pvr_iso_ctl%i_pvr_isosurf_ctl .le. 0) return +! + maxlen = len_trim(hd_iso_direction) + maxlen = max(maxlen, len_trim(hd_isosurf_value)) + maxlen = max(maxlen, len_trim(hd_pvr_opacity)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_iso_ctl%isosurf_type_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & pvr_iso_ctl%iso_value_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & pvr_iso_ctl%opacity_ctl) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_pvr_isosurface_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_isosurface_ctl_label(hd_block, pvr_iso_ctl) +! + character(len=kchara), intent(in) :: hd_block + type(pvr_isosurf_ctl), intent(inout) :: pvr_iso_ctl +! +! + pvr_iso_ctl%block_name = hd_block + call init_chara_ctl_item_label(hd_iso_direction, & + & pvr_iso_ctl%isosurf_type_ctl) + call init_real_ctl_item_label & + & (hd_isosurf_value, pvr_iso_ctl%iso_value_ctl) + call init_real_ctl_item_label & + & (hd_pvr_opacity, pvr_iso_ctl%opacity_ctl) +! + end subroutine init_pvr_isosurface_ctl_label +! +! --------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine dup_pvr_isosurface_ctl(org_pvr_iso_c, new_pvr_iso_c) +! + type(pvr_isosurf_ctl), intent(in) :: org_pvr_iso_c + type(pvr_isosurf_ctl), intent(inout) :: new_pvr_iso_c +! +! + call copy_chara_ctl(org_pvr_iso_c%isosurf_type_ctl, & + & new_pvr_iso_c%isosurf_type_ctl) + call copy_real_ctl(org_pvr_iso_c%iso_value_ctl, & + & new_pvr_iso_c%iso_value_ctl) + call copy_real_ctl(org_pvr_iso_c%opacity_ctl, & + & new_pvr_iso_c%opacity_ctl) +! + end subroutine dup_pvr_isosurface_ctl +! +! --------------------------------------------------------------------- +! + subroutine reset_pvr_isosurface_ctl(pvr_iso_ctl) +! + type(pvr_isosurf_ctl), intent(inout) :: pvr_iso_ctl +! +! + pvr_iso_ctl%isosurf_type_ctl%iflag = 0 + pvr_iso_ctl%iso_value_ctl%iflag = 0 + pvr_iso_ctl%opacity_ctl%iflag = 0 +! + pvr_iso_ctl%i_pvr_isosurf_ctl = 0 +! + end subroutine reset_pvr_isosurface_ctl +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_pvr_isosurface diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_light.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_light.f90 new file mode 100644 index 00000000..5d3b2abb --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_light.f90 @@ -0,0 +1,293 @@ +!>@file t_ctl_data_pvr_light.f90 +!!@brief module t_ctl_data_pvr_light +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief colormap control data for parallel volume rendering +!! +!!@verbatim +!! subroutine init_lighting_ctl_label(hd_block, light) +!! subroutine read_lighting_ctl(id_control, hd_block, light, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_light_ctl), intent(inout) :: light +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_lighting_ctl & +!! & (id_control, hd_block, light, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_light_ctl), intent(in) :: light +!! integer(kind = kint), intent(inout) :: level +!! logical function cmp_pvr_light_ctl(light1, light2) +!! type(pvr_light_ctl), intent(in) :: light1, light2 +!! +!! subroutine reset_pvr_light_flags(light) +!! subroutine dealloc_pvr_light_crl(light) +!! type(pvr_light_ctl), intent(inout) :: light +!! subroutine dup_lighting_ctl(org_light, new_light) +!! type(pvr_light_ctl), intent(in) :: org_light +!! type(pvr_light_ctl), intent(inout) :: new_light +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! example of color control for Kemo's volume rendering +!! +!! begin lighting_ctl +!! array position_of_lights +!! position_of_lights 0.0 0.0 0.0 end +!! position_of_lights -10.0 0.0 -10.0 end +!! position_of_lights -10.0 0.0 0.0 end +!! position_of_lights 0.0 10.0 0.0 end +!! end array position_of_lights +!!! +!! array sph_position_of_lights +!! sph_position_of_lights 10.0 0.0 0.0 end +!! sph_position_of_lights 10.0 30.0 -45.0 end +!! sph_position_of_lights 10.0 30.0 45.0 end +!! sph_position_of_lights 10.0 -45.0 180.0 end +!! end array sph_position_of_lights +!!! +!! ambient_coef_ctl 0.5 +!! diffuse_coef_ctl 5.6 +!! specular_coef_ctl 0.8 +!! end lighting_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_pvr_light +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_array_real + use t_control_array_real3 + use skip_comment_f +! + implicit none +! +! + type pvr_light_ctl +!> Control block name + character(len = kchara) :: block_name = 'lighting_ctl' +! + type(read_real_item) :: ambient_coef_ctl + type(read_real_item) :: diffuse_coef_ctl + type(read_real_item) :: specular_coef_ctl +! +!> Structure for light positions +!!@n light_position_ctl%vec1: X-component of light position +!!@n light_position_ctl%vec2: Y-component of light position +!!@n light_position_ctl%vec3: Z-component of light position + type(ctl_array_r3) :: light_position_ctl +!> Structure for light positions +!!@n light_sph_posi_ctl%vec1: r-component of light position +!!@n light_sph_posi_ctl%vec2: theta-component of light position +!!@n light_sph_posi_ctl%vec3: phi-component of light position + type(ctl_array_r3) :: light_sph_posi_ctl +! + integer (kind=kint) :: i_pvr_lighting = 0 + end type pvr_light_ctl +! +! +! 3rd level for lighting +! + character(len=kchara) :: hd_ambient = 'ambient_coef_ctl' + character(len=kchara) :: hd_diffuse = 'diffuse_coef_ctl' + character(len=kchara) :: hd_specular = 'specular_coef_ctl' + character(len=kchara) :: hd_light_xyz = 'position_of_lights' + character(len=kchara) :: hd_light_sph = 'sph_position_of_lights' +! + private :: hd_ambient, hd_diffuse, hd_specular + private :: hd_light_xyz, hd_light_sph +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_lighting_ctl(id_control, hd_block, light, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(pvr_light_ctl), intent(inout) :: light + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(light%i_pvr_lighting .gt. 0) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_control_array_r3(id_control, & + & hd_light_xyz, light%light_position_ctl, c_buf) + call read_control_array_r3(id_control, & + & hd_light_sph, light%light_sph_posi_ctl, c_buf) +! + call read_real_ctl_type & + & (c_buf, hd_ambient, light%ambient_coef_ctl ) + call read_real_ctl_type & + & (c_buf, hd_diffuse, light%diffuse_coef_ctl) + call read_real_ctl_type & + & (c_buf, hd_specular, light%specular_coef_ctl) + end do + light%i_pvr_lighting = 1 +! + end subroutine read_lighting_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_lighting_ctl & + & (id_control, hd_block, light, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_light_ctl), intent(in) :: light +! + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(light%i_pvr_lighting .le. 0) return +! + maxlen = len_trim(hd_ambient) + maxlen = max(maxlen, len_trim(hd_diffuse)) + maxlen = max(maxlen, len_trim(hd_specular)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_control_array_r3(id_control, level, & + & light%light_position_ctl) + call write_control_array_r3(id_control, level, & + & light%light_sph_posi_ctl) +! + call write_real_ctl_type(id_control, level, maxlen, & + & light%ambient_coef_ctl ) + call write_real_ctl_type(id_control, level, maxlen, & + & light%diffuse_coef_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & light%specular_coef_ctl) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_lighting_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_lighting_ctl_label(hd_block, light) +! + character(len=kchara), intent(in) :: hd_block + type(pvr_light_ctl), intent(inout) :: light +! +! + light%block_name = hd_block + call init_r3_ctl_array_label & + & (hd_light_xyz, light%light_position_ctl) + call init_r3_ctl_array_label & + & (hd_light_sph, light%light_sph_posi_ctl) +! + call init_real_ctl_item_label & + & (hd_ambient, light%ambient_coef_ctl) + call init_real_ctl_item_label & + & (hd_diffuse, light%diffuse_coef_ctl) + call init_real_ctl_item_label & + & (hd_specular, light%specular_coef_ctl) +! + end subroutine init_lighting_ctl_label +! +! --------------------------------------------------------------------- +! + logical function cmp_pvr_light_ctl(light1, light2) +! + type(pvr_light_ctl), intent(in) :: light1, light2 +! + cmp_pvr_light_ctl = .FALSE. + if(light1%i_pvr_lighting .ne. light2%i_pvr_lighting) return + if(cmp_no_case(trim(light1%block_name), & + & trim(light2%block_name)) .eqv. .FALSE.) return +! + if(cmp_read_real_item(light1%ambient_coef_ctl, & + & light2%ambient_coef_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real_item(light1%diffuse_coef_ctl, & + & light2%diffuse_coef_ctl) & + & .eqv. .FALSE.) return + if(cmp_read_real_item(light1%specular_coef_ctl, & + & light2%specular_coef_ctl) & + & .eqv. .FALSE.) return +! + if(cmp_control_array_r3(light1%light_position_ctl, & + & light2%light_position_ctl) & + & .eqv. .FALSE.) return + if(cmp_control_array_r3(light1%light_sph_posi_ctl, & + & light2%light_sph_posi_ctl) & + & .eqv. .FALSE.) return + cmp_pvr_light_ctl = .TRUE. +! + end function cmp_pvr_light_ctl +! +! -------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine reset_pvr_light_flags(light) +! + type(pvr_light_ctl), intent(inout) :: light +! +! + light%ambient_coef_ctl%iflag = 0 + light%diffuse_coef_ctl%iflag = 0 + light%specular_coef_ctl%iflag = 0 + light%i_pvr_lighting = 0 +! + end subroutine reset_pvr_light_flags +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_light_crl(light) +! + type(pvr_light_ctl), intent(inout) :: light +! + call dealloc_control_array_r3(light%light_sph_posi_ctl) + call dealloc_control_array_r3(light%light_position_ctl) + light%light_sph_posi_ctl%num = 0 + light%light_sph_posi_ctl%icou = 0 + light%light_position_ctl%num = 0 + light%light_position_ctl%icou = 0 +! + end subroutine dealloc_pvr_light_crl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dup_lighting_ctl(org_light, new_light) +! + type(pvr_light_ctl), intent(in) :: org_light + type(pvr_light_ctl), intent(inout) :: new_light +! +! + new_light%block_name = org_light%block_name + new_light%i_pvr_lighting = org_light%i_pvr_lighting +! + call dup_control_array_r3(org_light%light_position_ctl, & + & new_light%light_position_ctl) + call dup_control_array_r3(org_light%light_sph_posi_ctl, & + & new_light%light_sph_posi_ctl) +! + call copy_real_ctl(org_light%ambient_coef_ctl, & + & new_light%ambient_coef_ctl) + call copy_real_ctl(org_light%diffuse_coef_ctl, & + & new_light%diffuse_coef_ctl ) + call copy_real_ctl(org_light%specular_coef_ctl, & + & new_light%specular_coef_ctl) +! + end subroutine dup_lighting_ctl +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_pvr_light diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_movie.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_movie.f90 new file mode 100644 index 00000000..4238ae8f --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_movie.f90 @@ -0,0 +1,171 @@ +!>@file t_ctl_data_pvr_movie.f90 +!!@brief module t_ctl_data_pvr_movie +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for PVR movie from snapshot +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine dup_pvr_movie_control_flags(org_movie, new_movie) +!! type(pvr_movie_ctl), intent(in) :: org_movie +!! type(pvr_movie_ctl), intent(inout) :: new_movie +!! subroutine dealloc_pvr_movie_control_flags(movie) +!! type(pvr_movie_ctl), intent(inout) :: movie +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Avaiable parameters for movie_mode_ctl: +!! rotation, zoom, view_matrices, LIC_kernel, looking_glass +!! +!! begin snapshot_movie_ctl +!! movie_mode_ctl rotation +!! num_frames_ctl 120 +!! +!! rotation_axis_ctl z +!! +!! file start_view_control 'ctl_view_start' +!! file end_view_control 'ctl_view_end' +!! +!! array view_transform_ctl +!! file view_transform_ctl control_view +!! +!! begin view_transform_ctl +!! .. +!! end +!! end array view_transform_ctl +!! +!! angle_range 0.0 360.0 +!! apature_range 10.0 1.0 +!! +!! LIC_kernel_peak_range -0.8 0.8 +!! end snapshot_movie_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! movie_mode_ctl: view_matrices, rotation, apature, LIC_kernel +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_pvr_movie +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_data_4_psf + use t_control_array_character + use t_control_array_integer + use t_control_array_real2 + use t_control_array_integer2 + use t_ctl_data_4_view_transfer + use t_ctl_data_view_transfers + use skip_comment_f +! + implicit none +! +! + type pvr_movie_ctl +!> Control block name + character(len = kchara) :: block_name = 'snapshot_movie_ctl' +! +!> Structure of movie mode control + type(read_character_item) :: movie_mode_ctl +!> Structure of number of flame control + type(read_integer_item) :: num_frames_ctl +! +!> Structure of rotation axis control + type(read_character_item) :: rotation_axis_ctl +! +!> Structure of start and end of angle + type(read_real2_item) :: angle_range_ctl +!> Structure of start and end of apature + type(read_real2_item) :: apature_range_ctl +! +!> Structure of start and end of LIC kernel peak + type(read_real2_item) :: LIC_kernel_peak_range_ctl +! +!> file name for start modelview matrix + character(len=kchara) :: fname_view_start_ctl = 'NO_FILE' +!> file name for end modelview matrix + character(len=kchara) :: fname_view_end_ctl = 'NO_FILE' +!> Structure for start modelview marices + type(modeview_ctl) :: view_start_ctl +!> Structure for end modelview marices + type(modeview_ctl) :: view_end_ctl +! +! Lists of multiple view parameters + type(multi_modelview_ctl) :: mul_mmats_c +! +! 2nd level for volume rendering + integer (kind=kint) :: i_pvr_rotation = 0 + end type pvr_movie_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine dup_pvr_movie_control_flags(org_movie, new_movie) +! + type(pvr_movie_ctl), intent(in) :: org_movie + type(pvr_movie_ctl), intent(inout) :: new_movie +! +! + call dup_mul_view_trans_ctl(org_movie%mul_mmats_c, & + & new_movie%mul_mmats_c) +! + call copy_chara_ctl(org_movie%movie_mode_ctl, & + & new_movie%movie_mode_ctl) + call copy_integer_ctl(org_movie%num_frames_ctl, & + & new_movie%num_frames_ctl) +! + call copy_chara_ctl(org_movie%rotation_axis_ctl, & + & new_movie%rotation_axis_ctl) +! + call copy_real2_ctl(org_movie%angle_range_ctl, & + & new_movie%angle_range_ctl) + call copy_real2_ctl(org_movie%apature_range_ctl, & + & new_movie%apature_range_ctl) + call copy_real2_ctl(org_movie%LIC_kernel_peak_range_ctl, & + & new_movie%LIC_kernel_peak_range_ctl) +! + new_movie%fname_view_start_ctl = org_movie%fname_view_start_ctl + new_movie%fname_view_end_ctl = org_movie%fname_view_end_ctl + call dup_view_transfer_ctl(org_movie%view_start_ctl, & + & new_movie%view_start_ctl) + call dup_view_transfer_ctl(org_movie%view_end_ctl, & + & new_movie%view_end_ctl) +! + new_movie%i_pvr_rotation = org_movie%i_pvr_rotation + new_movie%block_name = org_movie%block_name +! + end subroutine dup_pvr_movie_control_flags +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_movie_control_flags(movie) +! + type(pvr_movie_ctl), intent(inout) :: movie +! +! + call dealloc_multi_modeview_ctl(movie%mul_mmats_c) +! + movie%movie_mode_ctl%iflag = 0 + movie%num_frames_ctl%iflag = 0 + movie%rotation_axis_ctl%iflag = 0 + movie%angle_range_ctl%iflag = 0 + movie%apature_range_ctl%iflag = 0 +! + movie%LIC_kernel_peak_range_ctl%iflag = 0 +! + call dealloc_view_transfer_ctl(movie%view_start_ctl) + call dealloc_view_transfer_ctl(movie%view_end_ctl) +! + movie%i_pvr_rotation = 0 +! + end subroutine dealloc_pvr_movie_control_flags +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_pvr_movie diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_section.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_section.f90 new file mode 100644 index 00000000..69d2bdde --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_section.f90 @@ -0,0 +1,226 @@ +!>@file t_ctl_data_pvr_section.f90 +!!@brief module t_ctl_data_pvr_section +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for parallel volume rendering +!! +!!@verbatim +!! subroutine dup_pvr_section_ctl(org_pvr_sect_c, new_pvr_sect_c) +!! type(pvr_section_ctl), intent(in) :: org_pvr_sect_c +!! type(pvr_section_ctl), intent(inout) :: new_pvr_sect_c +!! subroutine dealloc_pvr_section_ctl(pvr_sect_ctl) +!! type(pvr_section_ctl), intent(inout) :: pvr_sect_ctl +!! +!! subroutine init_pvr_section_ctl_label(hd_block, pvr_sect_ctl) +!! subroutine read_pvr_section_ctl & +!! & (id_control, hd_block, icou, pvr_sect_ctl, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_section_ctl), intent(inout) :: pvr_sect_ctl +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_section_ctl & +!! & (id_control, hd_block, pvr_sect_ctl, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_section_ctl), intent(inout) :: pvr_sect_ctl +!! integer(kind = kint), intent(inout) :: level +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array section_ctl +!! file surface_define ctl_psf_eq +!! begin surface_define +!! ... +!! end surface_define +!! +!! opacity_ctl 0.9 +!! +!! zeroline_switch_ctl On +!! isoline_color_mode color, white, or black +!! isoline_number_ctl 20 +!! isoline_range_ctl -0.5 0.5 +!! isoline_width_ctl 1.5 +!! grid_width_ctl 1.0 +!! +!! tangent_cylinder_switch_ctl On +!! inner_radius_ctl 0.53846 +!! outer_radius_ctl 1.53846 +!! end array section_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_pvr_section +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_data_4_psf_def + use t_control_array_real + use t_control_array_real2 + use t_control_array_integer + use t_control_array_character + use t_control_array_chara2real + use skip_comment_f +! + implicit none +! + type pvr_section_ctl +!> Block name + character(len=kchara) :: block_name = 'surface_define' +! +!> File name of control file to define surface + character(len = kchara) :: fname_sect_ctl = 'NO_FILE' +!> Structure to define surface + type(psf_define_ctl) :: psf_def_c +!> Structure to define opacity of surface + type(read_real_item) :: opacity_ctl +!> Structure of zero line switch + type(read_character_item) :: zeroline_switch_ctl + integer(kind = kint) :: i_pvr_sect_ctl = 0 + end type pvr_section_ctl +! + character(len=kchara), parameter, private & + & :: hd_surface_define = 'surface_define' + character(len=kchara), parameter, private & + & :: hd_pvr_opacity = 'opacity_ctl' +! + character(len=kchara), parameter, private & + & :: hd_pvr_sec_zeroline = 'zeroline_switch_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine dup_pvr_section_ctl(org_pvr_sect_c, new_pvr_sect_c) +! + type(pvr_section_ctl), intent(in) :: org_pvr_sect_c + type(pvr_section_ctl), intent(inout) :: new_pvr_sect_c +! +! + new_pvr_sect_c%block_name = org_pvr_sect_c%block_name + new_pvr_sect_c%i_pvr_sect_ctl = org_pvr_sect_c%i_pvr_sect_ctl + new_pvr_sect_c%fname_sect_ctl = org_pvr_sect_c%fname_sect_ctl + call dup_control_4_psf_def & + & (org_pvr_sect_c%psf_def_c, new_pvr_sect_c%psf_def_c) +! + call copy_real_ctl(org_pvr_sect_c%opacity_ctl, & + & new_pvr_sect_c%opacity_ctl) + call copy_chara_ctl(org_pvr_sect_c%zeroline_switch_ctl, & + & new_pvr_sect_c%zeroline_switch_ctl) +! + end subroutine dup_pvr_section_ctl +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_section_ctl(pvr_sect_ctl) +! + type(pvr_section_ctl), intent(inout) :: pvr_sect_ctl +! +! + call dealloc_cont_dat_4_psf_def(pvr_sect_ctl%psf_def_c) + pvr_sect_ctl%opacity_ctl%iflag = 0 + pvr_sect_ctl%zeroline_switch_ctl%iflag = 0 +! + pvr_sect_ctl%i_pvr_sect_ctl = 0 +! + end subroutine dealloc_pvr_section_ctl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine read_pvr_section_ctl & + & (id_control, hd_block, icou, pvr_sect_ctl, c_buf) +! + use ctl_file_section_def_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control, icou + character(len=kchara), intent(in) :: hd_block + type(pvr_section_ctl), intent(inout) :: pvr_sect_ctl + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(pvr_sect_ctl%i_pvr_sect_ctl .gt. 0) return + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + if(check_file_flag(c_buf, hd_surface_define) & + & .or. check_begin_flag(c_buf, hd_surface_define)) then + call write_multi_ctl_file_message & + & (hd_block, icou, c_buf%level) + call sel_read_ctl_pvr_section_def(id_control, & + & hd_surface_define, pvr_sect_ctl%fname_sect_ctl, & + & pvr_sect_ctl%psf_def_c, c_buf) + end if +! + call read_real_ctl_type & + & (c_buf, hd_pvr_opacity, pvr_sect_ctl%opacity_ctl) + call read_chara_ctl_type(c_buf, hd_pvr_sec_zeroline, & + & pvr_sect_ctl%zeroline_switch_ctl) + end do + pvr_sect_ctl%i_pvr_sect_ctl = 1 +! + end subroutine read_pvr_section_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_pvr_section_ctl & + & (id_control, hd_block, pvr_sect_ctl, level) +! + use ctl_file_section_def_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_section_ctl), intent(in) :: pvr_sect_ctl + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(pvr_sect_ctl%i_pvr_sect_ctl .le. 0) return + maxlen = len_trim(hd_pvr_opacity) + maxlen = max(maxlen,len_trim(hd_pvr_sec_zeroline)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call sel_write_ctl_pvr_section_def(id_control, hd_surface_define, & + & pvr_sect_ctl%fname_sect_ctl, pvr_sect_ctl%psf_def_c, level) +! + call write_real_ctl_type(id_control, level, maxlen, & + & pvr_sect_ctl%opacity_ctl) + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_sect_ctl%zeroline_switch_ctl) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_pvr_section_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_section_ctl_label(hd_block, pvr_sect_ctl) +! + use ctl_data_section_def_IO +! + character(len=kchara), intent(in) :: hd_block + type(pvr_section_ctl), intent(inout) :: pvr_sect_ctl +! + pvr_sect_ctl%block_name = hd_block + call init_psf_def_ctl_stract & + & (hd_surface_define, pvr_sect_ctl%psf_def_c) +! + call init_real_ctl_item_label & + & (hd_pvr_opacity, pvr_sect_ctl%opacity_ctl) + call init_chara_ctl_item_label(hd_pvr_sec_zeroline, & + & pvr_sect_ctl%zeroline_switch_ctl) +! + end subroutine init_pvr_section_ctl_label +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_pvr_section diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_tracer.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_tracer.f90 new file mode 100644 index 00000000..7d112d81 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_pvr_tracer.f90 @@ -0,0 +1,253 @@ +!>@file t_ctl_data_pvr_tracer.f90 +!!@brief module t_ctl_data_pvr_tracer +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief tracer control data for parallel volume rendering +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine init_pvr_tracer_ctl_label(hd_block, pvr_tracer_c) +!! subroutine read_pvr_tracer_ctl(id_control, hd_block, & +!! & pvr_tracer_c, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_tracer_ctl), intent(inout) :: pvr_tracer_c +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_pvr_tracer_ctl(id_control, hd_block, & +!! & pvr_tracer_c, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(pvr_tracer_ctl), intent(in) :: pvr_tracer_c +!! integer(kind = kint), intent(inout) :: level +!! +!! subroutine dup_pvr_tracer_ctl(org_pvr_iso_c, new_pvr_iso_c) +!! type(pvr_tracer_ctl), intent(in) :: org_pvr_iso_c +!! type(pvr_tracer_ctl), intent(inout) :: new_pvr_iso_c +!! subroutine reset_pvr_tracer_ctl(pvr_tracer_c) +!! type(pvr_tracer_ctl), intent(inout) :: pvr_tracer_c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! begin isosurface_ctl +!! tracer_file_prefix tracer_out +!! +!! tracer_increment 10 +!! rendering_radius 3.0e-3 +!! +!! color_mode_ctl 'single_color' or 'colormap' +!! RGB_color_ctl 0.7 0.2 0.3 +!! opacity_ctl 0.9 +!! end isosurface_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_pvr_tracer +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_array_character + use t_control_array_integer + use t_control_array_real + use t_control_array_real3 + use skip_comment_f +! + implicit none +! +! + type pvr_tracer_ctl +!> Control block name + character(len = kchara) :: block_name = 'tracer_ctl' +! +!> File prefix for output tracer data + type(read_character_item) :: tracer_file_prefix +! +!> Tracer increment of perticle rendering + type(read_integer_item) :: render_increment_ctl +!> Radius of renderingperticle + type(read_real_item) :: render_radius_ctl +! +!> Color mode for tracer rendering + type(read_character_item) :: color_mode_ctl +!> RGB value of tracer color + type(read_real3_item) :: rgb_color_ctl +!> Tracer opacity + type(read_real_item) :: opacity_ctl +! + integer(kind = kint) :: i_pvr_tracer_ctl = 0 + end type pvr_tracer_ctl +! +! 3rd level for isosurface +! + character(len=kchara), private & + & :: hd_tracer_prefix = 'tracer_file_prefix' + character(len=kchara), private & + & :: hd_tracer_increment = 'tracer_increment' + character(len=kchara), private & + & :: hd_render_radius = 'rendering_radius' + character(len=kchara), private & + & :: hd_color_mode = 'color_mode_ctl' + character(len=kchara), private & + & :: hd_tracer_RGB = 'RGB_color_ctl' + character(len=kchara), private & + & :: hd_tracer_opacity = 'opacity_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_pvr_tracer_ctl(id_control, hd_block, & + & pvr_tracer_c, c_buf) +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_tracer_ctl), intent(inout) :: pvr_tracer_c + type(buffer_for_control), intent(inout) :: c_buf +! +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_chara_ctl_type(c_buf, hd_tracer_prefix, & + & pvr_tracer_c%tracer_file_prefix) +! + call read_integer_ctl_type(c_buf, hd_tracer_increment, & + & pvr_tracer_c%render_increment_ctl) + call read_real_ctl_type(c_buf, hd_render_radius, & + & pvr_tracer_c%render_radius_ctl) +! + call read_chara_ctl_type(c_buf, hd_color_mode, & + & pvr_tracer_c%color_mode_ctl) + call read_real3_ctl_type(c_buf, hd_tracer_RGB, & + & pvr_tracer_c%rgb_color_ctl) + call read_real_ctl_type(c_buf, hd_tracer_opacity, & + & pvr_tracer_c%opacity_ctl) + end do + pvr_tracer_c%i_pvr_tracer_ctl = 1 +! + end subroutine read_pvr_tracer_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_pvr_tracer_ctl(id_control, hd_block, & + & pvr_tracer_c, level) +! + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(pvr_tracer_ctl), intent(in) :: pvr_tracer_c + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(pvr_tracer_c%i_pvr_tracer_ctl .le. 0) return +! + maxlen = len_trim(hd_tracer_prefix) + maxlen = max(maxlen, len_trim(hd_render_radius)) + maxlen = max(maxlen, len_trim(hd_tracer_increment)) + maxlen = max(maxlen, len_trim(hd_color_mode)) + maxlen = max(maxlen, len_trim(hd_tracer_RGB)) + maxlen = max(maxlen, len_trim(hd_tracer_opacity)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_tracer_c%tracer_file_prefix) +! + call write_integer_ctl_type(id_control, level, maxlen, & + & pvr_tracer_c%render_increment_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & pvr_tracer_c%render_radius_ctl) +! + call write_chara_ctl_type(id_control, level, maxlen, & + & pvr_tracer_c%color_mode_ctl) + call write_real3_ctl_type(id_control, level, maxlen, & + & pvr_tracer_c%rgb_color_ctl) + call write_real_ctl_type(id_control, level, maxlen, & + & pvr_tracer_c%opacity_ctl) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_pvr_tracer_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_pvr_tracer_ctl_label(hd_block, pvr_tracer_c) +! + character(len=kchara), intent(in) :: hd_block + type(pvr_tracer_ctl), intent(inout) :: pvr_tracer_c +! +! + pvr_tracer_c%block_name = hd_block + call init_chara_ctl_item_label(hd_tracer_prefix, & + & pvr_tracer_c%tracer_file_prefix) +! + call init_int_ctl_item_label(hd_tracer_increment, & + & pvr_tracer_c%render_increment_ctl) + call init_real_ctl_item_label(hd_render_radius, & + & pvr_tracer_c%render_radius_ctl) +! + call init_chara_ctl_item_label(hd_color_mode, & + & pvr_tracer_c%color_mode_ctl) + call init_real3_ctl_item_label(hd_tracer_RGB, & + & pvr_tracer_c%rgb_color_ctl) + call init_real_ctl_item_label(hd_tracer_opacity, & + & pvr_tracer_c%opacity_ctl) +! + end subroutine init_pvr_tracer_ctl_label +! +! --------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine dup_pvr_tracer_ctl(org_pvr_iso_c, new_pvr_iso_c) +! + type(pvr_tracer_ctl), intent(in) :: org_pvr_iso_c + type(pvr_tracer_ctl), intent(inout) :: new_pvr_iso_c +! +! + call copy_chara_ctl(org_pvr_iso_c%tracer_file_prefix, & + & new_pvr_iso_c%tracer_file_prefix) +! + call copy_integer_ctl(org_pvr_iso_c%render_increment_ctl, & + & new_pvr_iso_c%render_increment_ctl) + call copy_real_ctl(org_pvr_iso_c%render_radius_ctl, & + & new_pvr_iso_c%render_radius_ctl) +! + call copy_chara_ctl(org_pvr_iso_c%color_mode_ctl, & + & new_pvr_iso_c%color_mode_ctl) + call copy_real3_ctl(org_pvr_iso_c%rgb_color_ctl, & + & new_pvr_iso_c%rgb_color_ctl) + call copy_real_ctl(org_pvr_iso_c%opacity_ctl, & + & new_pvr_iso_c%opacity_ctl) +! + end subroutine dup_pvr_tracer_ctl +! +! --------------------------------------------------------------------- +! + subroutine reset_pvr_tracer_ctl(pvr_tracer_c) +! + type(pvr_tracer_ctl), intent(inout) :: pvr_tracer_c +! +! + pvr_tracer_c%tracer_file_prefix%iflag = 0 +! + pvr_tracer_c%render_increment_ctl%iflag = 0 + pvr_tracer_c%render_radius_ctl%iflag = 0 +! + pvr_tracer_c%color_mode_ctl%iflag = 0 + pvr_tracer_c%rgb_color_ctl%iflag = 0 + pvr_tracer_c%opacity_ctl%iflag = 0 +! + pvr_tracer_c%i_pvr_tracer_ctl = 0 +! + end subroutine reset_pvr_tracer_ctl +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_pvr_tracer diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_quilt_image.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_quilt_image.f90 new file mode 100644 index 00000000..4d0968b5 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_quilt_image.f90 @@ -0,0 +1,218 @@ +!>@file t_ctl_data_quilt_image.f90 +!!@brief module t_ctl_data_quilt_image +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!> @brief control data for PVR quilt_c from snapshot +!! +!!@verbatim +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! subroutine init_quilt_image_ctl_label(hd_block, quilt_c) +!! subroutine read_quilt_image_ctl & +!! & (id_control, hd_block, quilt_c, c_buf) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(quilt_image_ctl), intent(inout) :: quilt_c +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_quilt_image_ctl & +!! & (id_control, hd_block, quilt_c, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(quilt_image_ctl), intent(in) :: quilt_c +!! integer(kind = kint), intent(inout) :: level +!! subroutine dup_quilt_image_ctl(org_quilt, new_quilt) +!! type(quilt_image_ctl), intent(in) :: org_quilt +!! type(quilt_image_ctl), intent(inout) :: new_quilt +!! subroutine reset_quilt_image_ctl(quilt_c) +!! type(quilt_image_ctl), intent(inout) :: quilt_c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! begin quilt_image_ctl +!! +!! array view_transform_ctl +!! file view_transform_ctl control_view +!! +!! begin view_transform_ctl +!! .. +!! end +!! end array view_transform_ctl +!! end quilt_image_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_quilt_image +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_array_character + use t_control_array_integer + use t_control_array_integer2 + use t_control_array_real2 + use t_ctl_data_view_transfers + use skip_comment_f +! + implicit none +! +! +!> Structure of quilt image controls + type quilt_image_ctl +!> Control block name + character(len = kchara) :: block_name = 'quilt_image_ctl' +! +!> Structure of number of columns and row of image + type(read_int2_item) :: num_column_row_ctl +!> Structure of number of row and columns of image + type(read_int2_item) :: num_row_column_ctl +! +! Lists of multiple view parameters + type(multi_modelview_ctl) :: mul_qmats_c +! +! integer flag of used block + integer (kind=kint) :: i_quilt_image = 0 + end type quilt_image_ctl +! +! 3rd level for rotation +! + character(len=kchara), parameter, private & + & :: hd_column_row = 'num_column_row_ctl' + character(len=kchara), parameter, private & + & :: hd_row_column = 'num_row_column_ctl' + character(len=kchara), parameter, private & + & :: hd_qview_transform = 'view_transform_ctl' +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_quilt_image_ctl & + & (id_control, hd_block, quilt_c, c_buf) +! + use ctl_file_pvr_modelview_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(quilt_image_ctl), intent(inout) :: quilt_c + type(buffer_for_control), intent(inout) :: c_buf +! +! + if (quilt_c%i_quilt_image.gt.0) return + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! +! + call read_integer2_ctl_type(c_buf, hd_column_row, & + & quilt_c%num_column_row_ctl) + call read_integer2_ctl_type(c_buf, hd_row_column, & + & quilt_c%num_row_column_ctl) +! + call read_mul_view_transfer_ctl & + & (id_control, hd_qview_transform, quilt_c%mul_qmats_c, c_buf) + end do + quilt_c%i_quilt_image = 1 +! + end subroutine read_quilt_image_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_quilt_image_ctl & + & (id_control, hd_block, quilt_c, level) +! + use ctl_file_pvr_modelview_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(quilt_image_ctl), intent(in) :: quilt_c + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: maxlen = 0 +! +! + if(quilt_c%i_quilt_image .le. 0) return +! + maxlen = len_trim(hd_column_row) + maxlen = max(maxlen, len_trim(hd_row_column)) +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_integer2_ctl_type(id_control, level, maxlen, & + & quilt_c%num_column_row_ctl) + call write_integer2_ctl_type(id_control, level, maxlen, & + & quilt_c%num_row_column_ctl) +! + call write_mul_view_transfer_ctl & + & (id_control, hd_qview_transform, quilt_c%mul_qmats_c, level) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_quilt_image_ctl +! +! --------------------------------------------------------------------- +! + subroutine init_quilt_image_ctl_label(hd_block, quilt_c) +! + use ctl_file_pvr_modelview_IO +! + character(len=kchara), intent(in) :: hd_block + type(quilt_image_ctl), intent(inout) :: quilt_c +! +! + quilt_c%block_name = hd_block + call init_multi_modeview_ctl(hd_qview_transform, & + & quilt_c%mul_qmats_c) +! + call init_integer2_ctl_item_label(hd_column_row, & + & quilt_c%num_column_row_ctl) + call init_integer2_ctl_item_label(hd_row_column, & + & quilt_c%num_row_column_ctl) +! + end subroutine init_quilt_image_ctl_label +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dup_quilt_image_ctl(org_quilt, new_quilt) +! + type(quilt_image_ctl), intent(in) :: org_quilt + type(quilt_image_ctl), intent(inout) :: new_quilt +! +! + call dup_mul_view_trans_ctl(org_quilt%mul_qmats_c, & + & new_quilt%mul_qmats_c) +! + call copy_integer2_ctl(org_quilt%num_column_row_ctl, & + & new_quilt%num_column_row_ctl) + call copy_integer2_ctl(org_quilt%num_row_column_ctl, & + & new_quilt%num_row_column_ctl) +! + new_quilt%i_quilt_image = org_quilt%i_quilt_image + new_quilt%block_name = org_quilt%block_name +! + end subroutine dup_quilt_image_ctl +! +! --------------------------------------------------------------------- +! + subroutine reset_quilt_image_ctl(quilt_c) +! + type(quilt_image_ctl), intent(inout) :: quilt_c +! +! + call dealloc_multi_modeview_ctl(quilt_c%mul_qmats_c) +! + quilt_c%num_column_row_ctl%iflag = 0 + quilt_c%num_row_column_ctl%iflag = 0 +! + quilt_c%i_quilt_image = 0 +! + end subroutine reset_quilt_image_ctl +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_quilt_image diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_view_transfers.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_view_transfers.f90 new file mode 100644 index 00000000..ff2868c6 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_data_view_transfers.f90 @@ -0,0 +1,322 @@ +!>@file t_ctl_data_view_transfers.f90 +!!@brief module t_ctl_data_view_transfers +!! +!!@author H. Matsui +!!@date Programmed in 2006 +! +!>@brief Control inputs for multiple PVR view parameter +!! +!!@verbatim +!! subroutine alloc_multi_modeview_ctl(mul_mats_c) +!! subroutine dealloc_multi_modeview_ctl(mul_mats_c) +!! subroutine init_multi_modeview_ctl(hd_block, mul_mats_c) +!! +!! subroutine read_mul_view_transfer_ctl & +!! & (id_control, hd_block, mul_mats_c, c_buf) +!! type(multi_modelview_ctl), intent(inout) :: mul_mats_c +!! type(buffer_for_control), intent(inout) :: c_buf +!! subroutine write_mul_view_transfer_ctl & +!! & (id_control, hd_block, mul_mats_c, level) +!! integer(kind = kint), intent(in) :: id_control +!! character(len=kchara), intent(in) :: hd_block +!! type(multi_modelview_ctl), intent(in) :: mul_mats_c +!! integer(kind = kint), intent(inout) :: level +!! +!! subroutine append_mul_view_trans_ctl(idx_in, hd_block, & +!! & mul_mats_c) +!! subroutine delete_mul_view_trans_ctl(idx_in, mul_mats_c) +!! integer(kind = kint), intent(in) :: idx_in +!! character(len=kchara), intent(in) :: hd_block +!! type(multi_modelview_ctl), intent(inout) :: mul_mats_c +!! subroutine dup_mul_view_trans_ctl(org_mul_mats_c, & +!! & new_mul_mats_c) +!! type(multi_modelview_ctl), intent(in) :: org_mul_mats_c +!! type(multi_modelview_ctl), intent(inout) :: new_mul_mats_c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! array view_transform_ctl +!! file view_transform_ctl control_view +!! +!! begin view_transform_ctl +!! .. +!! end +!! end array view_transform_ctl +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!@endverbatim +! + module t_ctl_data_view_transfers +! + use m_precision +! + use m_machine_parameter + use t_read_control_elements + use t_control_array_character + use t_ctl_data_4_view_transfer + use skip_comment_f +! + implicit none +! +! +!> Structure of modelview parameters or file names to load + type multi_modelview_ctl +!> Control block name + character(len = kchara) :: block_name = 'isosurface_ctl' +! +!> Number of modelview parameter block + integer(kind = kint) :: num_modelviews_c = 0 +!> File name for external control file + character(len=kchara), allocatable :: fname_mat_ctl(:) +!> Lists of view parameters + type(modeview_ctl), allocatable :: matrices(:) + end type multi_modelview_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine dealloc_multi_modeview_ctl(mul_mats_c) +! + type(multi_modelview_ctl), intent(inout) :: mul_mats_c +! +! + if(allocated(mul_mats_c%matrices)) then + call dealloc_mul_view_trans_ctl & + & (mul_mats_c%num_modelviews_c, mul_mats_c%matrices) + deallocate(mul_mats_c%matrices, mul_mats_c%fname_mat_ctl) + end if +! + mul_mats_c%num_modelviews_c = 0 +! + end subroutine dealloc_multi_modeview_ctl +! +! ----------------------------------------------------------------------- +! + subroutine alloc_multi_modeview_ctl(mul_mats_c) +! + type(multi_modelview_ctl), intent(inout) :: mul_mats_c +! +! + allocate(mul_mats_c%matrices(mul_mats_c%num_modelviews_c)) + allocate(mul_mats_c%fname_mat_ctl(mul_mats_c%num_modelviews_c)) +! + end subroutine alloc_multi_modeview_ctl +! +! ----------------------------------------------------------------------- +! + subroutine init_multi_modeview_ctl(hd_block, mul_mats_c) +! + character(len=kchara), intent(in) :: hd_block + type(multi_modelview_ctl), intent(inout) :: mul_mats_c +! +! + mul_mats_c%block_name = hd_block + mul_mats_c%num_modelviews_c = 0 +! + end subroutine init_multi_modeview_ctl +! +! ----------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine read_mul_view_transfer_ctl & + & (id_control, hd_block, mul_mats_c, c_buf) +! + use ctl_file_pvr_modelview_IO + use ctl_data_view_transfer_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(multi_modelview_ctl), intent(inout) :: mul_mats_c + type(buffer_for_control), intent(inout) :: c_buf +! + integer(kind = kint) :: n_append +! +! + if(check_array_flag(c_buf, hd_block) .eqv. .FALSE.) return + if(allocated(mul_mats_c%matrices)) return + call alloc_multi_modeview_ctl(mul_mats_c) +! + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_array_flag(c_buf, hd_block)) exit +! + if(check_file_flag(c_buf, hd_block) & + & .or. check_begin_flag(c_buf, hd_block)) then + n_append = mul_mats_c%num_modelviews_c + call append_mul_view_trans_ctl(n_append, hd_block, & + & mul_mats_c) +! + call sel_read_ctl_modelview_file & + & (id_control, hd_block, mul_mats_c%num_modelviews_c, & + & mul_mats_c%fname_mat_ctl(mul_mats_c%num_modelviews_c), & + & mul_mats_c%matrices(mul_mats_c%num_modelviews_c), c_buf) + end if + end do +! + end subroutine read_mul_view_transfer_ctl +! +! --------------------------------------------------------------------- +! + subroutine write_mul_view_transfer_ctl & + & (id_control, hd_block, mul_mats_c, level) +! + use ctl_file_pvr_modelview_IO + use ctl_data_view_transfer_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(multi_modelview_ctl), intent(in) :: mul_mats_c + integer(kind = kint), intent(inout) :: level +! + integer(kind = kint) :: i +! + level = write_array_flag_for_ctl(id_control, level, hd_block) + do i = 1, mul_mats_c%num_modelviews_c + write(*,'(3a,i4)', ADVANCE='NO') '! ', trim(hd_block), & + & ' No. ', i +! + call sel_write_ctl_modelview_file(id_control, hd_block, & + & mul_mats_c%fname_mat_ctl(i), mul_mats_c%matrices(i), level) + end do + level = write_end_array_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_mul_view_transfer_ctl +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine append_mul_view_trans_ctl(idx_in, hd_block, & + & mul_mats_c) +! + use ctl_data_view_transfer_IO +! + integer(kind = kint), intent(in) :: idx_in + character(len=kchara), intent(in) :: hd_block + type(multi_modelview_ctl), intent(inout) :: mul_mats_c +! + type(multi_modelview_ctl) :: tmp_mul_qmats + integer(kind = kint) :: i +! +! + if(idx_in.lt.0 .or. idx_in.gt.mul_mats_c%num_modelviews_c) return +! + tmp_mul_qmats%num_modelviews_c = mul_mats_c%num_modelviews_c + call alloc_multi_modeview_ctl(tmp_mul_qmats) +! + do i = 1, tmp_mul_qmats%num_modelviews_c + call dup_view_transfer_ctl(mul_mats_c%matrices(i), & + & tmp_mul_qmats%matrices(i)) + tmp_mul_qmats%fname_mat_ctl(i) = mul_mats_c%fname_mat_ctl(i) + end do +! + call dealloc_multi_modeview_ctl(mul_mats_c) + mul_mats_c%num_modelviews_c = tmp_mul_qmats%num_modelviews_c + 1 + call alloc_multi_modeview_ctl(mul_mats_c) +! + do i = 1, idx_in + call dup_view_transfer_ctl(tmp_mul_qmats%matrices(i), & + & mul_mats_c%matrices(i)) + mul_mats_c%fname_mat_ctl(i) = tmp_mul_qmats%fname_mat_ctl(i) + end do +! + call init_view_transfer_ctl_label(hd_block, & + & mul_mats_c%matrices(idx_in+1)) + mul_mats_c%fname_mat_ctl(idx_in+1) = 'NO_FILE' +! + do i = idx_in+1, tmp_mul_qmats%num_modelviews_c + call dup_view_transfer_ctl(tmp_mul_qmats%matrices(i), & + & mul_mats_c%matrices(i+1)) + mul_mats_c%fname_mat_ctl(i+1) = tmp_mul_qmats%fname_mat_ctl(i) + end do +! + call dealloc_multi_modeview_ctl(tmp_mul_qmats) +! + end subroutine append_mul_view_trans_ctl +! +! ----------------------------------------------------------------------- +! + subroutine delete_mul_view_trans_ctl(idx_in, mul_mats_c) +! + integer(kind = kint), intent(in) :: idx_in + type(multi_modelview_ctl), intent(inout) :: mul_mats_c +! + type(multi_modelview_ctl) :: tmp_mul_qmats + integer(kind = kint) :: i +! +! + if(idx_in.le.0 .or. idx_in.gt.mul_mats_c%num_modelviews_c) return +! + tmp_mul_qmats%num_modelviews_c = mul_mats_c%num_modelviews_c + call alloc_multi_modeview_ctl(tmp_mul_qmats) +! + do i = 1, tmp_mul_qmats%num_modelviews_c + call dup_view_transfer_ctl(mul_mats_c%matrices(i), & + & tmp_mul_qmats%matrices(i)) + tmp_mul_qmats%fname_mat_ctl(i) = mul_mats_c%fname_mat_ctl(i) + end do +! + call dealloc_multi_modeview_ctl(mul_mats_c) + mul_mats_c%num_modelviews_c = tmp_mul_qmats%num_modelviews_c + 1 + call alloc_multi_modeview_ctl(mul_mats_c) +! + do i = 1, idx_in-1 + call dup_view_transfer_ctl(tmp_mul_qmats%matrices(i), & + & mul_mats_c%matrices(i)) + mul_mats_c%fname_mat_ctl(i) = tmp_mul_qmats%fname_mat_ctl(i) + end do + do i = idx_in, mul_mats_c%num_modelviews_c + call dup_view_transfer_ctl(tmp_mul_qmats%matrices(i+1), & + & mul_mats_c%matrices(i)) + mul_mats_c%fname_mat_ctl(i) = tmp_mul_qmats%fname_mat_ctl(i+1) + end do +! + call dealloc_multi_modeview_ctl(tmp_mul_qmats) +! + end subroutine delete_mul_view_trans_ctl +! +! ----------------------------------------------------------------------- +! + subroutine dup_mul_view_trans_ctl(org_mul_mats_c, & + & new_mul_mats_c) +! + type(multi_modelview_ctl), intent(in) :: org_mul_mats_c + type(multi_modelview_ctl), intent(inout) :: new_mul_mats_c +! + integer(kind = kint) :: i +! + new_mul_mats_c%block_name = org_mul_mats_c%block_name + new_mul_mats_c%num_modelviews_c & + & = org_mul_mats_c%num_modelviews_c + call alloc_multi_modeview_ctl(new_mul_mats_c) +! + do i = 1, new_mul_mats_c%num_modelviews_c + call dup_view_transfer_ctl(org_mul_mats_c%matrices(i), & + & new_mul_mats_c%matrices(i)) + new_mul_mats_c%fname_mat_ctl(i) & + & = org_mul_mats_c%fname_mat_ctl(i) + end do +! + end subroutine dup_mul_view_trans_ctl +! +! --------------------------------------------------------------------- +! + subroutine dealloc_mul_view_trans_ctl(num_mat, matrices) +! + integer(kind = kint), intent(in) :: num_mat + type(modeview_ctl), intent(inout) :: matrices(num_mat) +! + integer(kind = kint) :: i +! +! + do i = 1, num_mat + call dealloc_view_transfer_ctl(matrices(i)) + end do +! + end subroutine dealloc_mul_view_trans_ctl +! +! --------------------------------------------------------------------- +! + end module t_ctl_data_view_transfers diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_param_tracer_render.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_param_tracer_render.f90 new file mode 100644 index 00000000..98677633 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_ctl_param_tracer_render.f90 @@ -0,0 +1,204 @@ +!>@file t_ctl_param_tracer_render.f90 +!! module t_ctl_param_tracer_render +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structures for position in the projection coordinate +!! +!!@verbatim +!! subroutine set_control_pvr_tracer(num_tracer, tcr_prm, & +!! & num_pvr_tracer_ctl, pvr_trc_c, tracer_pvr_prm) +!! subroutine dealloc_pvr_tracer_param(tracer_pvr_prm) +!! integer(kind = kint), intent(in) :: num_pvr_tracer_ctl +!! type(pvr_tracer_ctl), intent(in) & +!! & :: pvr_trc_c(num_pvr_tracer_ctl) +!! integer(kind = kint), intent(in) :: num_tracer +!! type(fieldline_paramter), intent(in) :: tcr_prm(num_tracer) +!! type(tracer_render_param), intent(inout) :: tracer_pvr_prm +!!@endverbatim +! + module t_ctl_param_tracer_render +! + use m_precision + use m_constants +! + implicit none +! + character(len = kchara), parameter, private & + & :: hd_single_color = 'single_color' + character(len = kchara), parameter, private & + & :: hd_colored = 'colormap' +! + integer(kind = kint), parameter :: iflag_single_color = 0 + integer(kind = kint), parameter :: iflag_colored = 1 +! +!> Structure for tracer rendering + type tracer_render_param +!> Number of isosurfaces + integer(kind = kint) :: num_pvr_tracer +!> Number of isosurfaces + character(len = kchara), allocatable :: tracer_prefix(:) +!> Number of isosurfaces + integer(kind = kint), allocatable :: id_tracer_model(:) +! +!> Number of isosurfaces + integer(kind = kint), allocatable :: increment(:) +!> fiale value for isosurfaces + real(kind = kreal), allocatable :: rendering_radius(:) +! +!> Number of isosurfaces + integer(kind = kint), allocatable :: iflag_color_mode(:) +!> RGB value for isosurfaces + real(kind = kreal), allocatable :: tracer_RGB(:,:) +!> Opacity value for isosurfaces + real(kind = kreal), allocatable :: tracer_opacity(:) + end type tracer_render_param +! + private :: alloc_pvr_tracer_param +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine set_control_pvr_tracer(num_tracer, tcr_prm, & + & num_pvr_tracer_ctl, pvr_trc_c, tracer_pvr_prm) +! + use t_control_data_pvr_tracers + use t_control_params_4_fline +! + integer(kind = kint), intent(in) :: num_pvr_tracer_ctl + type(pvr_tracer_ctl), intent(in) & + & :: pvr_trc_c(num_pvr_tracer_ctl) +! + integer(kind = kint), intent(in) :: num_tracer + type(fieldline_paramter), intent(in) :: tcr_prm(num_tracer) +! + type(tracer_render_param), intent(inout) :: tracer_pvr_prm +! + integer(kind = kint) :: i, j, icou + character(len = kchara) :: fname_model, fname_ctl + character(len = kchara) :: tmpchara +! +! + icou = 0 + do i = 1, num_pvr_tracer_ctl + fname_ctl = pvr_trc_c(i)%tracer_file_prefix%charavalue + do j = 1, num_tracer + fname_model = tcr_prm(j)%fline_file_IO%file_prefix + if(fname_model .eq. fname_ctl) then + icou = icou + 1 + exit + end if + end do + end do +! + call alloc_pvr_tracer_param(icou, tracer_pvr_prm) + if(tracer_pvr_prm%num_pvr_tracer .le. 0) return +! + icou = 0 + do i = 1, num_pvr_tracer_ctl + fname_ctl = pvr_trc_c(i)%tracer_file_prefix%charavalue + do j = 1, num_tracer + fname_model = tcr_prm(j)%fline_file_IO%file_prefix + if(fname_model .eq. fname_ctl) then + icou = icou + 1 + tracer_pvr_prm%tracer_prefix(icou) = fname_model + tracer_pvr_prm%id_tracer_model(icou) = j + exit + end if + end do + end do +! + do i = 1, tracer_pvr_prm%num_pvr_tracer + tracer_pvr_prm%increment(i) = 1 + tracer_pvr_prm%rendering_radius(i) = 1.0d-3 + tracer_pvr_prm%tracer_RGB(1:3,i) = (/one, one, one/) + tracer_pvr_prm%tracer_opacity(i) = one + tracer_pvr_prm%iflag_color_mode(i) = iflag_colored + end do +! + do i = 1, tracer_pvr_prm%num_pvr_tracer + if(pvr_trc_c(i)%render_increment_ctl%iflag .gt. 0) then + tracer_pvr_prm%increment(i) & + & = pvr_trc_c(i)%render_increment_ctl%intvalue + end if +! + if(pvr_trc_c(i)%render_radius_ctl%iflag .gt. 0) then + tracer_pvr_prm%rendering_radius(i) & + & = pvr_trc_c(i)%render_radius_ctl%realvalue + end if +! + if(pvr_trc_c(i)%rgb_color_ctl%iflag .gt. 0) then + tracer_pvr_prm%tracer_RGB(1:3,i) & + & = pvr_trc_c(i)%rgb_color_ctl%realvalue(1:3) + end if +! + if(pvr_trc_c(i)%opacity_ctl%iflag .gt. 0) then + tracer_pvr_prm%tracer_opacity(i) & + & = pvr_trc_c(i)%opacity_ctl%realvalue + end if +! + if(pvr_trc_c(i)%color_mode_ctl%iflag .gt. 0) then + tmpchara = pvr_trc_c(i)%color_mode_ctl%charavalue + if(tmpchara .eq. hd_single_color) then + tracer_pvr_prm%iflag_color_mode(i) = iflag_single_color + end if + end if + end do +! + end subroutine set_control_pvr_tracer +! +! ----------------------------------------------------------------------- +! + subroutine dealloc_pvr_tracer_param(tracer_pvr_prm) +! + type(tracer_render_param), intent(inout) :: tracer_pvr_prm +! +! + deallocate(tracer_pvr_prm%tracer_prefix) + deallocate(tracer_pvr_prm%id_tracer_model) +! + deallocate(tracer_pvr_prm%increment) + deallocate(tracer_pvr_prm%rendering_radius) +! + deallocate(tracer_pvr_prm%iflag_color_mode) + deallocate(tracer_pvr_prm%tracer_RGB) + deallocate(tracer_pvr_prm%tracer_opacity) +! + end subroutine dealloc_pvr_tracer_param +! +! ----------------------------------------------------------------------- +! + subroutine alloc_pvr_tracer_param(num, tracer_pvr_prm) +! + integer(kind = kint), intent(in) :: num + type(tracer_render_param), intent(inout) :: tracer_pvr_prm +! +! + tracer_pvr_prm%num_pvr_tracer = num + allocate(tracer_pvr_prm%tracer_prefix(num)) + allocate(tracer_pvr_prm%id_tracer_model(num)) +! + allocate(tracer_pvr_prm%increment(num)) + allocate(tracer_pvr_prm%rendering_radius(num)) +! + allocate(tracer_pvr_prm%iflag_color_mode(num)) + allocate(tracer_pvr_prm%tracer_RGB(3,num)) + allocate(tracer_pvr_prm%tracer_opacity(num)) +! + if(num .le. 0) return + tracer_pvr_prm%id_tracer_model(:) = 0 + tracer_pvr_prm%increment(:) = 1 + tracer_pvr_prm%rendering_radius(:) = zero + tracer_pvr_prm%iflag_color_mode(:) = 0 + tracer_pvr_prm%tracer_RGB(:,:) = zero + tracer_pvr_prm%tracer_opacity(:) = zero +! + end subroutine alloc_pvr_tracer_param +! +! ----------------------------------------------------------------------- +! + end module t_ctl_param_tracer_render diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_elapsed_labels_4_VIZ.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_elapsed_labels_4_VIZ.f90 new file mode 100644 index 00000000..382d7961 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_elapsed_labels_4_VIZ.f90 @@ -0,0 +1,178 @@ +!>@file t_elapsed_labels_4_VIZ.f90 +!!@brief module t_elapsed_labels_4_VIZ +!! +!!@author H. Matsui +!!@date Programmed in April, 2013 +! +!>@brief Initialize elepsed time monitoring +!! +!!@verbatim +!! subroutine set_elpsed_label_4_VIZ(flag_detailed, elps_VIZ, elps) +!! subroutine reset_elapse_after_init_VIZ(elps_VIZ, elps) +!! logical, intent(in) :: flag_detailed +!! type(elapsed_labels_4_VIZ), intent(inout) :: elps_VIZ +!! type(elapsed_time_data), intent(inout) :: elps +!!@endverbatim +! + module t_elapsed_labels_4_VIZ +! + use m_precision + use m_work_time +! + implicit none +! + type elapsed_labels_4_VIZ + logical :: flag_elapsed_V = .FALSE. + integer(kind = kint) :: ist_elapsed_V = 0 + integer(kind = kint) :: ied_elapsed_V = 0 +! + type(elapsed_lables) :: elps_PSF + type(elapsed_lables) :: elps_ISO +! + type(elapsed_lables) :: elps_PVR + type(elapsed_lables) :: elps_LIC + type(elapsed_lables) :: elps_MAP +! + type(elapsed_lables) :: elps_FLINE + type(elapsed_lables) :: elps_TRACER + end type elapsed_labels_4_VIZ +! + private :: elpsed_label_4_VIZ_outline + private :: reset_elapse_after_init_VIZ_top +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine set_elpsed_label_4_VIZ(flag_detailed, elps_VIZ, elps) +! + use elapsed_labels_4_PVR + use elapsed_labels_4_FLINE + use elapsed_labels_4_PSF +! + logical, intent(in) :: flag_detailed + type(elapsed_labels_4_VIZ), intent(inout) :: elps_VIZ + type(elapsed_time_data), intent(inout) :: elps +! +! + call elpsed_label_4_VIZ_outline(elps_VIZ, elps) +! + if(flag_detailed) then + call elpsed_label_4_PVR(elps_VIZ%elps_PVR, elps) + call elpsed_label_4_LIC(elps_VIZ%elps_LIC, elps) +! + call elpsed_label_4_PSF(elps_VIZ%elps_PSF, elps) + call elpsed_label_4_ISO(elps_VIZ%elps_ISO, elps) + call elpsed_label_4_MAP(elps_VIZ%elps_MAP, elps) +! + call elpsed_label_4_FLINE(elps_VIZ%elps_FLINE, elps) + call elpsed_label_4_TRACER(elps_VIZ%elps_TRACER, elps) + else + elps_VIZ%elps_PSF%flag_elapsed = .FALSE. + elps_VIZ%elps_ISO%flag_elapsed = .FALSE. + elps_VIZ%elps_PVR%flag_elapsed = .FALSE. + elps_VIZ%elps_LIC%flag_elapsed = .FALSE. + elps_VIZ%elps_MAP%flag_elapsed = .FALSE. + elps_VIZ%elps_FLINE%flag_elapsed = .FALSE. + elps_VIZ%elps_TRACER%flag_elapsed = .FALSE. + end if +! + end subroutine set_elpsed_label_4_VIZ +! +! ---------------------------------------------------------------------- +! + subroutine reset_elapse_after_init_VIZ(elps_VIZ, elps) +! + use elapsed_labels_4_PVR + use elapsed_labels_4_PSF +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(elapsed_time_data), intent(inout) :: elps +! +! + call reset_elapse_after_init_VIZ_top(elps_VIZ, elps) +! call reset_elapse_after_init_PVR(elps_VIZ%elps_PVR, elps) + call reset_elapse_after_init_LIC(elps_VIZ%elps_LIC, elps) +! + call reset_elapse_after_init_PSF(elps_VIZ%elps_PSF, elps) + call reset_elapse_after_init_ISO(elps_VIZ%elps_ISO, elps) + call reset_elapse_after_init_MAP(elps_VIZ%elps_MAP, elps) +! + end subroutine reset_elapse_after_init_VIZ +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine elpsed_label_4_VIZ_outline(elps_VIZ, elps) +! + type(elapsed_labels_4_VIZ), intent(inout) :: elps_VIZ + type(elapsed_time_data), intent(inout) :: elps + integer(kind = kint), parameter :: num_append = 17 +! +! + call append_elapsed_timer(num_append, elps_VIZ%ist_elapsed_V, & + & elps_VIZ%ied_elapsed_V, elps) +! + elps%labels(elps_VIZ%ist_elapsed_V+ 1) & + & = 'Sectioning initialization. ' + elps%labels(elps_VIZ%ist_elapsed_V+ 2) = 'Sectioning. ' +! + elps%labels(elps_VIZ%ist_elapsed_V+ 3) & + & = 'Isosurfaceing initialization. ' + elps%labels(elps_VIZ%ist_elapsed_V+ 4) = 'Isosurfaceing. ' +! + elps%labels(elps_VIZ%ist_elapsed_V+ 5) & + & = 'Map projection initialization. ' + elps%labels(elps_VIZ%ist_elapsed_V+ 6) = 'Map projection. ' +! + elps%labels(elps_VIZ%ist_elapsed_V+ 7) & + & = 'Volume rendering initialization. ' + elps%labels(elps_VIZ%ist_elapsed_V+ 8) = 'Volume rendering. ' +! + elps%labels(elps_VIZ%ist_elapsed_V+ 9) & + & = 'LIC rendering initialization. ' + elps%labels(elps_VIZ%ist_elapsed_V+10) = 'LIC rendering. ' +! + elps%labels(elps_VIZ%ist_elapsed_V+11) & + & = 'Fieldline initialization. ' + elps%labels(elps_VIZ%ist_elapsed_V+12) = 'Fieldline. ' +! + elps%labels(elps_VIZ%ist_elapsed_V+13) & + & = 'Tracer initialization. ' + elps%labels(elps_VIZ%ist_elapsed_V+14) = 'Tracer. ' +! + elps%labels(elps_VIZ%ist_elapsed_V+15) & + & = 'VTK output in viz module' + elps%labels(elps_VIZ%ist_elapsed_V+16) & + & = 'ele. comm. table for LIC ' + elps%labels(elps_VIZ%ist_elapsed_V+17) & + & = 'edge comm. table for vizualization ' +! + elps_VIZ%flag_elapsed_V = .TRUE. +! + end subroutine elpsed_label_4_VIZ_outline +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + subroutine reset_elapse_after_init_VIZ_top(elps_VIZ, elps) +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(elapsed_time_data), intent(inout) :: elps +! + integer(kind = kint) :: i, i_viz +! + if(elps_VIZ%flag_elapsed_V .eqv. .FALSE.) return + + do i = 1, 7 + i_viz = 2*i + elps_VIZ%ist_elapsed_V + call reset_elapsed_timer(i_viz, i_viz, elps) + end do +! + end subroutine reset_elapse_after_init_VIZ_top +! +!----------------------------------------------------------------------- +! + end module t_elapsed_labels_4_VIZ diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_four_visualizers.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_four_visualizers.f90 new file mode 100644 index 00000000..eb3247d5 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_four_visualizers.f90 @@ -0,0 +1,201 @@ +!>@file t_four_visualizers.f90 +!!@brief module t_four_visualizers +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +! +!>@brief Main module to access surfaceing, isosurfaceing, +!! fieldline, and volume rendering modules +!! +!!@verbatim +!! subroutine init_four_visualize(elps_VIZ, viz_step, & +!! & geofem, nod_fld, VIZ_DAT, viz4_ctls, vizs, m_SR) +!! subroutine visualize_four(elps_VIZ, viz_step, time_d, geofem, & +!! & nod_fld, VIZ_DAT, vizs, m_SR) +!! type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ +!! type(VIZ_step_params), intent(in) :: viz_step +!! type(time_data), intent(in) :: time_d +!! type(mesh_data), intent(in) :: geofem +!! type(phys_data), intent(in) :: nod_fld +!! type(VIZ_mesh_field), intent(in) :: VIZ_DAT +!! type(vis4_controls), intent(inout) :: viz4_ctls +!! type(four_visualize_modules), intent(inout) :: vizs +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module t_four_visualizers +! + use m_precision +! + use m_machine_parameter + use m_work_time + use calypso_mpi +! + use t_elapsed_labels_4_VIZ + use t_VIZ_step_parameter + use t_time_data + use t_mesh_data + use t_comm_table + use t_phys_data + use t_next_node_ele_4_node + use t_VIZ_mesh_field + use t_mesh_SR +! + use t_control_data_viz4 + use t_cross_section + use t_isosurface + use t_map_projection + use t_volume_rendering + use t_fieldline + use t_particle_trace +! + implicit none +! + type four_visualize_modules + type(sectioning_module) :: psf + type(isosurface_module) :: iso + type(map_rendering_module) :: maps + type(volume_rendering_module) :: pvr + type(fieldline_module) :: fline + end type four_visualize_modules +! + type(tracer_module), save, private :: dummy_tracer +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine init_four_visualize(elps_VIZ, viz_step, & + & geofem, nod_fld, VIZ_DAT, viz4_ctls, vizs, m_SR) +! + use volume_rendering + use map_projection +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(VIZ_step_params), intent(in) :: viz_step + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(VIZ_mesh_field), intent(in) :: VIZ_DAT +! + type(vis4_controls), intent(inout) :: viz4_ctls + type(four_visualize_modules), intent(inout) :: vizs + type(mesh_SR), intent(inout) :: m_SR +! +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+1) + call SECTIONING_initialize & + & (viz_step%PSF_t%increment, elps_VIZ%elps_PSF, & + & geofem, VIZ_DAT%edge_comm, nod_fld, viz4_ctls%psf_ctls, & + & vizs%psf, m_SR%SR_sig, m_SR%SR_il) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+1) +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+3) + call ISOSURF_initialize & + & (viz_step%ISO_t%increment, geofem, nod_fld, & + & viz4_ctls%iso_ctls, vizs%iso) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+3) +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+5) + call MAP_PROJECTION_initialize(viz_step%MAP_t%increment, & + & elps_VIZ%elps_PSF, elps_VIZ%elps_MAP, & + & geofem, VIZ_DAT%edge_comm, nod_fld, & + & viz4_ctls%map_ctls, vizs%maps, m_SR%SR_sig, m_SR%SR_il) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+5) +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+11) + call FLINE_initialize(viz_step%FLINE_t%increment, geofem, & + & nod_fld, dummy_tracer, viz4_ctls%fline_ctls, vizs%fline) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+11) +! + dummy_tracer%num_trace = 0 +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+7) + call PVR_initialize & + & (viz_step%PVR_t%increment, elps_VIZ%elps_PVR, geofem, nod_fld, & + & dummy_tracer, vizs%fline, viz4_ctls%pvr_ctls, vizs%pvr, m_SR) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+7) +! +! + call calypso_mpi_barrier + call dealloc_viz4_controls(viz4_ctls) +! + end subroutine init_four_visualize +! +! --------------------------------------------------------------------- +! + subroutine visualize_four(elps_VIZ, viz_step, time_d, geofem, & + & nod_fld, VIZ_DAT, vizs, m_SR) +! + use volume_rendering + use map_projection +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(time_data), intent(in) :: time_d + type(VIZ_step_params), intent(in) :: viz_step + type(mesh_data), intent(in) :: geofem + type(VIZ_mesh_field), intent(in) :: VIZ_DAT + type(phys_data), intent(in) :: nod_fld +! + type(four_visualize_modules), intent(inout) :: vizs + type(mesh_SR), intent(inout) :: m_SR +! +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+2) + call SECTIONING_visualize(viz_step%istep_psf, elps_VIZ%elps_PSF, & + & time_d, geofem, nod_fld, vizs%psf) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+2) +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+4) + call ISOSURF_visualize(viz_step%istep_iso, elps_VIZ%elps_ISO, & + & time_d, geofem, VIZ_DAT%edge_comm, nod_fld, vizs%iso, & + & m_SR%SR_sig, m_SR%SR_il) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+4) +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+6) + call MAP_PROJECTION_visualize & + & (viz_step%istep_map, elps_VIZ%elps_PSF, elps_VIZ%elps_MAP, & + & time_d, geofem, nod_fld, vizs%maps, m_SR%SR_sig) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+6) +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+12) + call FLINE_visualize & + & (viz_step%istep_fline, elps_VIZ%elps_FLINE, time_d, geofem, & + & VIZ_DAT%para_surf, nod_fld, dummy_tracer, vizs%fline, m_SR) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+12) +! + if(elps_VIZ%flag_elapsed_V) & + & call start_elapsed_time(elps_VIZ%ist_elapsed_V+8) + call PVR_visualize & + & (viz_step%istep_pvr, time_d%time, elps_VIZ%elps_PVR, & + & geofem, VIZ_DAT%jacobians, nod_fld, dummy_tracer, & + & vizs%fline, vizs%pvr, m_SR) + if(elps_VIZ%flag_elapsed_V) & + & call end_elapsed_time(elps_VIZ%ist_elapsed_V+8) +! + call calypso_mpi_barrier +! + end subroutine visualize_four +! +! --------------------------------------------------------------------- +! + end module t_four_visualizers diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_geometries_in_pvr_screen.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_geometries_in_pvr_screen.f90 new file mode 100644 index 00000000..c082d20a --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_geometries_in_pvr_screen.f90 @@ -0,0 +1,283 @@ +!>@file t_geometries_in_pvr_screen.f90 +!! module t_geometries_in_pvr_screen +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structures for position in the projection coordinate +!! +!!@verbatim +!! subroutine alloc_iflag_pvr_used_ele(ele, draw_param) +!! subroutine dealloc_iflag_pvr_used_ele(draw_param) +!! type(element_data), intent(in) :: ele +!! type(rendering_parameter), intent(inout) :: draw_param +!! subroutine alloc_iflag_pvr_boundaries(surf_grp, draw_param) +!! subroutine dealloc_iflag_pvr_boundaries(draw_param) +!! type(surface_group_data), intent(in) :: surf_grp +!! type(rendering_parameter), intent(inout) :: draw_param +!! +!! subroutine alloc_pvr_sections(draw_param) +!! subroutine alloc_pvr_isosurfaces(draw_param) +!! type(rendering_parameter), intent(inout) :: draw_param +!! +!! subroutine alloc_pixel_position_pvr(n_pvr_pixel, pixel_xy) +!! type(pvr_pixel_position_type), intent(inout) :: pixel_xy +!! subroutine dealloc_data_4_pvr(draw_param) +!! type(rendering_parameter), intent(inout) :: draw_param +!! +!! subroutine deallocate_projected_data_pvr & +!! & (num_pvr, proj, draw_param) +!! subroutine dealloc_pixel_position_pvr(pixel_xy) +!! subroutine set_pixel_on_pvr_screen(view_param, pixel_xy) +!! type(pvr_view_parameter), intent(in) :: view_param +!! type(pvr_pixel_position_type), intent(inout) :: pixel_xy +!!@endverbatim +! + module t_geometries_in_pvr_screen +! + use m_precision + use m_constants + use t_ctl_param_tracer_render +! + implicit none +! +!> Structure for start points of ray tracing + type pvr_projected_position +!> viewpoint + real(kind = kreal) :: viewpoint_vec(3) +!> modelview matrix + real(kind = kreal) :: modelview_mat(4,4) +!> perspective projection matrix + real(kind = kreal) :: projection_mat(4,4) +! +!> Direction of three axis in screen coordinate + real(kind = kreal) :: axis_view(3,4) +!> Order of three axis in screen coordinate + integer(kind = kint) :: axis_order(3) + end type pvr_projected_position +! +! +!> Structure for field data on projected coordinate + type rendering_parameter +!> flag for rendering element + integer(kind = kint), allocatable :: iflag_used_ele(:) +! +!> Number of surface to be enhansed + integer(kind = kint) :: num_enhanse +!> integer flag for surface boundaries + integer(kind = kint), allocatable :: iflag_enhanse(:) +!> Opacity value for surface boundaries + real(kind = kreal), allocatable :: enhansed_opacity(:) +! +!> Structure for tracer rendering + type(tracer_render_param) :: tracer_pvr_prm +!> Structure for fiel line rendering + type(tracer_render_param) :: fline_pvr_prm +! +!> Number of sections + integer(kind = kint) :: num_sections +!> Number of sections + integer(kind = kint), allocatable :: iflag_psf_zeoline(:) +!> fiale value for isosurfaces + real(kind = kreal), allocatable :: coefs(:,:) +!> Opacity value for isosurfaces + real(kind = kreal), allocatable :: sect_opacity(:) +! +!> Number of isosurfaces + integer(kind = kint) :: num_isosurf +!> Number of isosurfaces + integer(kind = kint), allocatable :: itype_isosurf(:) +!> fiale value for isosurfaces + real(kind = kreal), allocatable :: iso_value(:) +!> Opacity value for isosurfaces + real(kind = kreal), allocatable :: iso_opacity(:) + end type rendering_parameter +! +!> Structure for pixel position + type pvr_pixel_position_type +!> Number of horizontal pixels + integer(kind = kint) :: num_pixel_x +!> Number of vertical pixels + integer(kind = kint) :: num_pixel_y +!> Position of horizontal pixels + real(kind = kreal), allocatable :: pixel_point_x(:) +!> Position of vertical pixels + real(kind = kreal), allocatable :: pixel_point_y(:) + end type pvr_pixel_position_type +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine alloc_iflag_pvr_used_ele(ele, draw_param) +! + use t_geometry_data +! + type(element_data), intent(in) :: ele + type(rendering_parameter), intent(inout) :: draw_param +! +! + allocate(draw_param%iflag_used_ele(ele%numele)) + if(ele%numele .gt. 0) draw_param%iflag_used_ele = 0 +! + end subroutine alloc_iflag_pvr_used_ele +! +! ----------------------------------------------------------------------- +! + subroutine dealloc_iflag_pvr_used_ele(draw_param) +! + type(rendering_parameter), intent(inout) :: draw_param +! +! + deallocate(draw_param%iflag_used_ele) +! + end subroutine dealloc_iflag_pvr_used_ele +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine alloc_iflag_pvr_boundaries(surf_grp, draw_param) +! + use t_group_data +! + type(surface_group_data), intent(in) :: surf_grp + type(rendering_parameter), intent(inout) :: draw_param +! +! + draw_param%num_enhanse = surf_grp%num_grp + allocate(draw_param%iflag_enhanse(surf_grp%num_grp)) + allocate(draw_param%enhansed_opacity(surf_grp%num_grp)) +! + if(surf_grp%num_grp .gt. 0) draw_param%iflag_enhanse = 0 + if(surf_grp%num_grp .gt. 0) draw_param%enhansed_opacity = 0.0d0 +! + end subroutine alloc_iflag_pvr_boundaries +! +! ----------------------------------------------------------------------- +! + subroutine dealloc_iflag_pvr_boundaries(draw_param) +! + type(rendering_parameter), intent(inout) :: draw_param +! +! + deallocate(draw_param%iflag_enhanse, draw_param%enhansed_opacity) +! + end subroutine dealloc_iflag_pvr_boundaries +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine alloc_pvr_sections(draw_param) +! + type(rendering_parameter), intent(inout) :: draw_param +! +! + allocate(draw_param%coefs(10,draw_param%num_sections)) + allocate(draw_param%sect_opacity(draw_param%num_sections)) + allocate(draw_param%iflag_psf_zeoline(draw_param%num_sections)) +! + if(draw_param%num_sections .le. 0) return +! + draw_param%coefs(1:10,1:draw_param%num_sections) = zero + draw_param%sect_opacity(1:draw_param%num_sections) = zero + draw_param%iflag_psf_zeoline(1:draw_param%num_sections) = izero +! + end subroutine alloc_pvr_sections +! +! ----------------------------------------------------------------------- +! + subroutine alloc_pvr_isosurfaces(draw_param) +! + type(rendering_parameter), intent(inout) :: draw_param +! +! + allocate(draw_param%itype_isosurf(draw_param%num_isosurf)) + allocate(draw_param%iso_value(draw_param%num_isosurf)) + allocate(draw_param%iso_opacity(draw_param%num_isosurf)) +! + if(draw_param%num_isosurf .gt. 0) draw_param%itype_isosurf = 0 + if(draw_param%num_isosurf .gt. 0) draw_param%iso_value = zero + if(draw_param%num_isosurf .gt. 0) draw_param%iso_opacity = zero +! + end subroutine alloc_pvr_isosurfaces +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine dealloc_pvr_sections(draw_param) +! + type(rendering_parameter), intent(inout) :: draw_param +! +! + deallocate(draw_param%coefs, draw_param%sect_opacity) + deallocate(draw_param%iflag_psf_zeoline) +! + end subroutine dealloc_pvr_sections +! +! ----------------------------------------------------------------------- +! + subroutine dealloc_pvr_isosurfaces(draw_param) +! + type(rendering_parameter), intent(inout) :: draw_param +! +! + deallocate(draw_param%itype_isosurf) + deallocate(draw_param%iso_value, draw_param%iso_opacity) +! + end subroutine dealloc_pvr_isosurfaces +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine alloc_pixel_position_pvr(n_pvr_pixel, pixel_xy) +! + integer(kind = kint), intent(in) :: n_pvr_pixel(2) + type(pvr_pixel_position_type), intent(inout) :: pixel_xy +! +! + pixel_xy%num_pixel_x = n_pvr_pixel(1) + pixel_xy%num_pixel_y = n_pvr_pixel(2) + allocate(pixel_xy%pixel_point_x(pixel_xy%num_pixel_x)) + allocate(pixel_xy%pixel_point_y(pixel_xy%num_pixel_y)) +! + pixel_xy%pixel_point_x = 0.0d0 + pixel_xy%pixel_point_y = 0.0d0 +! + end subroutine alloc_pixel_position_pvr +! +! ----------------------------------------------------------------------- +! + subroutine dealloc_pixel_position_pvr(pixel_xy) +! + type(pvr_pixel_position_type), intent(inout) :: pixel_xy +! +! + deallocate(pixel_xy%pixel_point_x, pixel_xy%pixel_point_y) +! + end subroutine dealloc_pixel_position_pvr +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine set_pixel_on_pvr_screen(view_param, pixel_xy) +! + use t_control_params_4_pvr + use set_projection_matrix +! + type(pvr_view_parameter), intent(in) :: view_param + type(pvr_pixel_position_type), intent(inout) :: pixel_xy +! +! + call alloc_pixel_position_pvr(view_param%n_pvr_pixel, pixel_xy) +! + call set_pixel_points_on_project & + & (view_param%n_pvr_pixel(1), view_param%n_pvr_pixel(2), & + pixel_xy%pixel_point_x, pixel_xy%pixel_point_y) +! + end subroutine set_pixel_on_pvr_screen +! +! --------------------------------------------------------------------- +! + end module t_geometries_in_pvr_screen diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_colormap_parameter.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_colormap_parameter.f90 new file mode 100644 index 00000000..d5f8deb2 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_colormap_parameter.f90 @@ -0,0 +1,154 @@ +!>@file t_pvr_colormap_parameter.f90 +!! module t_pvr_colormap_parameter +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!> @brief Structures for parameteres for volume rendering +!! +!!@verbatim +!! subroutine alloc_pvr_color_parameteres(color) +!! subroutine alloc_pvr_opacity_list(color) +!! subroutine alloc_light_posi_in_view(color) +!! subroutine dealloc_pvr_color_parameteres(color) +!! type(pvr_colormap_parameter), intent(inout) :: color +!!@endverbatim +! + module t_pvr_colormap_parameter +! + use m_precision + use m_constants +! + implicit none +! +! +!> Structure for PVR colormap parameters + type pvr_colormap_parameter +!> Colormap IDs +!!@n pvr_colormap(:) = id_pvr_color(1) +!!@n pvr_data_mapping(:) = id_pvr_color(2) +!!@n opacity_style(:) = find_dis_minmax(3) + integer(kind = kint) :: id_pvr_color(3) = (/0,0,0/) +! +!> Number of data points to define color + integer(kind = kint) :: num_pvr_datamap_pnt = 0 +!> Data and corresponding color value +!!@n Field data: pvr_datamap_param(1,:) +!!@n Color data: pvr_datamap_param(2,:) + real(kind = kreal), allocatable :: pvr_datamap_param(:,:) +! +!> Number of data points to define color + integer(kind = kint) :: num_opacity_pnt = 0 +!> Maximum opacity for colorbar + real(kind = kreal) :: pvr_max_opacity = zero +!> Opacity data table +!!@n pvr_opacity_dat_low(:) = pvr_opacity_param(1,:) +!!@n pvr_opacity_dat_high(:) = pvr_opacity_param(2,:) +!!@n pvr_opacity_opacity(:) = pvr_opacity_param(3,:) +!!@n ambient_opacity: pvr_opacity_param(3,(num_opacity_pnt(:)+1)) + real(kind = kreal), allocatable :: pvr_opacity_param(:,:) +! +!> Defined flag for lights + integer(kind = kint) :: iflag_pvr_lights = 0 +!> Number of lights + integer(kind = kint) :: num_pvr_lights = 0 +!!@n ambient_coef(:) = pvr_lighting_real(1,:) +!!@n diffuse_coef(:) = pvr_lighting_real(2,:) +!!@n specular_coef(:) = pvr_lighting_real(3,:) + real(kind = kreal) :: pvr_lighting_real(3) = (/zero,zero,zero/) +!> Position of lights + real(kind = kreal), allocatable :: xyz_pvr_lights(:,:) +! +!> Background color + real(kind = kreal) :: bg_rgba_real(4) = (/0.0,0.0,0.0,0.0/) + end type pvr_colormap_parameter +! +!> Structure for PVR colorbar parameters + type pvr_colorbar_parameter +!> Draw flag for color bar + logical :: flag_pvr_colorbar = .FALSE. +!> Bottom colorbar flag + logical :: flag_pvr_cbar_bottom = .FALSE. +!> Draw flag for color bar numbers + integer(kind = kint) :: iflag_pvr_cbar_nums = 0 +!> Draw flag for zero line in color bar + integer(kind = kint) :: iflag_pvr_zero_mark = 0 +!> Flag of colorbar with opacity + integer(kind = kint) :: iflag_opacity = 1 +!> Scaling for number font + integer(kind = kint) :: iscale_font = 1 +!> Thicknsess of colorbar + integer(kind = kint) :: ntick_pvr_colorbar = 3 +!> Range of colorbar + real(kind = kreal) :: cbar_range(2) = (/zero,one/) +! +!> Draw flag for axis label + logical :: flag_pvr_axis = .FALSE. +!> Draw flag for time label + logical :: flag_draw_time = .FALSE. +! +!> Draw flag for map grid + logical :: flag_draw_mapgrid = .FALSE. + end type pvr_colorbar_parameter +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_color_parameteres(color) +! + type(pvr_colormap_parameter), intent(inout) :: color +! +! + allocate(color%pvr_datamap_param(2,color%num_pvr_datamap_pnt) ) + if(color%num_pvr_datamap_pnt .gt. 0) then + color%pvr_datamap_param = 0.0d0 + end if +! + end subroutine alloc_pvr_color_parameteres +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_opacity_list(color) +! + type(pvr_colormap_parameter), intent(inout) :: color +! +! + allocate(color%pvr_opacity_param(3,color%num_opacity_pnt+1) ) + if(color%num_opacity_pnt .gt. 0) then + color%pvr_opacity_param = 0.0d0 + end if +! + end subroutine alloc_pvr_opacity_list +! +! --------------------------------------------------------------------- +! + subroutine alloc_light_posi_in_view(color) +! + type(pvr_colormap_parameter), intent(inout) :: color +! +! + allocate(color%xyz_pvr_lights(3,color%num_pvr_lights) ) + if (color%num_pvr_lights .le. 0) return + color%xyz_pvr_lights = 0.0d0 +! + end subroutine alloc_light_posi_in_view +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_color_parameteres(color) +! + type(pvr_colormap_parameter), intent(inout) :: color +! +! + deallocate(color%pvr_datamap_param) + deallocate(color%pvr_opacity_param) + deallocate(color%xyz_pvr_lights) +! + end subroutine dealloc_pvr_color_parameteres +! +! --------------------------------------------------------------------- +! + end module t_pvr_colormap_parameter diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_field_data.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_field_data.f90 new file mode 100644 index 00000000..ce57a5ad --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_field_data.f90 @@ -0,0 +1,118 @@ +!>@file t_pvr_field_data.f90 +!! module t_pvr_field_data +!! +!!@author H. Matsui +!!@date Programmed in May. 2006 +! +!> @brief Field data for volume rendering +!! +!!@verbatim +!! subroutine alloc_nod_data_4_pvr(nnod, nele, field_pvr) +!! subroutine dealloc_nod_data_4_pvr(field_pvr) +!! integer(kind = kint), intent(in) :: nnod, nele +!! type(rendering_parameter), intent(inout) :: field_pvr +!! subroutine cal_field_4_each_pvr(node, ele, g_FEM, jac_3d, & +!! & nod_fld, fld_params, field_pvr) +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(FEM_gauss_int_coefs), intent(in) :: g_FEM +!! type(jacobians_3d), intent(in) :: jac_3d +!! type(pvr_field_parameter), intent(in) :: fld_params +!! type(phys_data), intent(in) :: nod_fld +!! type(pvr_field_data), intent(inout) :: field_pvr +!!@endverbatim +! + module t_pvr_field_data +! + use m_precision + use m_constants +! + implicit none +! +!> Structure for field data for PVR + type pvr_field_data +!> Data for rendering + real(kind = kreal), allocatable :: d_pvr(:) +!> Gradient for rendering + real(kind = kreal), allocatable :: grad_ele(:,:) + end type pvr_field_data +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine alloc_nod_data_4_pvr(nnod, nele, field_pvr) +! + integer(kind = kint), intent(in) :: nnod, nele + type(pvr_field_data), intent(inout) :: field_pvr +! +! + allocate(field_pvr%d_pvr(nnod)) + allocate(field_pvr%grad_ele(nele,3)) +! + if(nnod .gt. 0) field_pvr%d_pvr = 0.0d0 + if(nele .gt. 0) field_pvr%grad_ele = 0.0d0 +! + end subroutine alloc_nod_data_4_pvr +! +! ----------------------------------------------------------------------- +! + subroutine dealloc_nod_data_4_pvr(field_pvr) +! + type(pvr_field_data), intent(inout) :: field_pvr +! +! + deallocate(field_pvr%d_pvr, field_pvr%grad_ele) +! + end subroutine dealloc_nod_data_4_pvr +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine cal_field_4_each_pvr(node, ele, g_FEM, jac_3d, & + & nod_fld, fld_params, field_pvr) +! + use t_geometry_data + use t_phys_data + use t_fem_gauss_int_coefs + use t_jacobian_3d + use t_geometries_in_pvr_screen + use t_control_params_4_pvr + use cal_gradient_on_element + use convert_components_4_viz +! + type(node_data), intent(in) :: node + type(element_data), intent(in) :: ele + type(FEM_gauss_int_coefs), intent(in) :: g_FEM + type(jacobians_3d), intent(in) :: jac_3d + type(pvr_field_parameter), intent(in) :: fld_params + type(phys_data), intent(in) :: nod_fld +! + type(pvr_field_data), intent(inout) :: field_pvr +! +! + integer(kind = kint) :: i_field, ist_fld, num_comp +! +! + i_field = fld_params%id_field + ist_fld = nod_fld%istack_component(i_field-1) + num_comp = nod_fld%istack_component(i_field) - ist_fld + call convert_comps_4_viz & + & (node%numnod, node%istack_nod_smp, node%xx, node%rr, & + & node%a_r, node%ss, node%a_s, ione, num_comp, & + & fld_params%id_component, nod_fld%d_fld(1,ist_fld+1), & + & field_pvr%d_pvr) +! + call fem_gradient_on_element(ele%istack_ele_smp, node%numnod, & + & ele%numele, ele%nnod_4_ele, ele%ie, ele%a_vol_ele, & + & g_FEM%max_int_point, g_FEM%maxtot_int_3d, g_FEM%int_start3, & + & g_FEM%owe3d, jac_3d%ntot_int, ione, jac_3d%dnx, jac_3d%xjac, & + & field_pvr%grad_ele, field_pvr%d_pvr) +! + end subroutine cal_field_4_each_pvr +! +! --------------------------------------------------------------------- +! + end module t_pvr_field_data diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_image_array.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_image_array.f90 new file mode 100644 index 00000000..355434b7 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_image_array.f90 @@ -0,0 +1,223 @@ +!>@file t_pvr_image_array.f90 +!! module t_pvr_image_array +!! +!!@author H. Matsui +!!@date Programmed in May, 2015 +! +!> @brief Structures for PVR Image data +!! +!!@verbatim +!! subroutine alloc_pvr_image_array(n_pvr_pixel, pvr_rgb) +!! subroutine alloc_pvr_left_eye_image(pvr_rgb) +!! subroutine dealloc_pvr_image_array(pvr_rgb) +!! subroutine dealloc_pvr_left_eye_image(pvr_rgb) +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!! +!! subroutine store_left_eye_image(pvr_rgb) +!! subroutine add_left_eye_image(pvr_rgb) +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!! +!! subroutine copy_pvr_image_file_param(org_pvr_rgb, rot_pvr_rgb) +!! subroutine copy_pvr_image_data(org_pvr_rgb, new_pvr_rgb) +!! type(pvr_image_type), intent(in) :: org_pvr_rgb +!! type(pvr_image_type), intent(inout) :: rot_pvr_rgb +!!@endverbatim +! + module t_pvr_image_array +! + use m_precision +! + use calypso_mpi + use m_constants +! + implicit none +! +!> Structure for PVR images + type pvr_image_type +!> File prefix for image file + character(len = kchara) :: pvr_prefix +! +!> Transparent image flag + integer(kind = kint) :: id_pvr_transparent = 0 +!> File format for image file + integer(kind = kint) :: id_pvr_file_type = 0 +!> Monitoring mode flag + integer(kind = kint) :: iflag_monitoring = 0 +! +!> MPI rank to putput each PVR image + integer(kind = kint) :: irank_image_file = 0 +!> MPI rank for each PVR composttion arnge + integer(kind = kint) :: irank_end_composit = 0 +!> Number of MPI rank to composit image + integer(kind = kint) :: npe_img_composit = 0 +! +!> Number of pixels in each direction + integer(kind = kint) :: num_pixels(2) +!> Number of pixels (same value in all processes) + integer(kind = kint) :: num_pixel_xy +!> Number of pixels in each process + integer(kind = kint) :: num_pixel_actual +! +!> Global real image data + real(kind = kreal), allocatable :: rgba_real_gl(:,:) +! +!> RGB byte image data + character(len = 1), allocatable :: rgb_chara_gl(:,:) +!> RGBA byte image data + character(len = 1), allocatable :: rgba_chara_gl(:,:) +! +!> Global real image data for left eye + real(kind = kreal), allocatable :: rgba_left_gl(:,:) + end type pvr_image_type +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_image_array(n_pvr_pixel, pvr_rgb) +! + use t_control_params_4_pvr +! + integer(kind = kint), intent(in) :: n_pvr_pixel(2) + type(pvr_image_type), intent(inout) :: pvr_rgb +! +! + pvr_rgb%num_pixels(1:2) = n_pvr_pixel(1:2) + pvr_rgb%num_pixel_xy = n_pvr_pixel(1) * n_pvr_pixel(2) +! +! + if(my_rank .eq. pvr_rgb%irank_image_file) then + pvr_rgb%num_pixel_actual = pvr_rgb%num_pixel_xy + else + pvr_rgb%num_pixel_actual = 1 + end if +! + allocate(pvr_rgb%rgb_chara_gl(3,pvr_rgb%num_pixel_actual)) + allocate(pvr_rgb%rgba_chara_gl(4,pvr_rgb%num_pixel_actual)) +! + allocate(pvr_rgb%rgba_real_gl(4,pvr_rgb%num_pixel_actual)) +! +!$omp parallel workshare + pvr_rgb%rgba_real_gl(1:4,1:pvr_rgb%num_pixel_actual) = 0.0d0 +!$omp end parallel workshare +! + end subroutine alloc_pvr_image_array +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_left_eye_image(pvr_rgb) +! + type(pvr_image_type), intent(inout) :: pvr_rgb +! +! + allocate(pvr_rgb%rgba_left_gl(4,pvr_rgb%num_pixel_actual)) +!$omp parallel workshare + pvr_rgb%rgba_left_gl(1:4,1:pvr_rgb%num_pixel_actual) = 0.0d0 +!$omp end parallel workshare +! + end subroutine alloc_pvr_left_eye_image +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_image_array(pvr_rgb) +! + type(pvr_image_type), intent(inout) :: pvr_rgb +! +! + deallocate(pvr_rgb%rgb_chara_gl, pvr_rgb%rgba_chara_gl) + deallocate(pvr_rgb%rgba_real_gl) +! + end subroutine dealloc_pvr_image_array +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_left_eye_image(pvr_rgb) +! + type(pvr_image_type), intent(inout) :: pvr_rgb +! + deallocate(pvr_rgb%rgba_left_gl) +! + end subroutine dealloc_pvr_left_eye_image +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine store_left_eye_image(pvr_rgb) +! + type(pvr_image_type), intent(inout) :: pvr_rgb +! +! + if(my_rank .ne. pvr_rgb%irank_image_file) return +!$omp parallel workshare + pvr_rgb%rgba_left_gl(1,1:pvr_rgb%num_pixel_actual) & + & = pvr_rgb%rgba_real_gl(1,1:pvr_rgb%num_pixel_actual) +! pvr_rgb%rgba_left_gl(2,1:pvr_rgb%num_pixel_actual) & +! & = pvr_rgb%rgba_real_gl(2,1:pvr_rgb%num_pixel_actual) +! pvr_rgb%rgba_left_gl(3,1:pvr_rgb%num_pixel_actual) & +! & = pvr_rgb%rgba_real_gl(3,1:pvr_rgb%num_pixel_actual) + pvr_rgb%rgba_left_gl(4,1:pvr_rgb%num_pixel_actual) & + & = pvr_rgb%rgba_real_gl(4,1:pvr_rgb%num_pixel_actual) +!$omp end parallel workshare +! + end subroutine store_left_eye_image +! +! --------------------------------------------------------------------- +! + subroutine add_left_eye_image(pvr_rgb) +! + type(pvr_image_type), intent(inout) :: pvr_rgb +! +! + if(my_rank .ne. pvr_rgb%irank_image_file) return +!$omp parallel workshare + pvr_rgb%rgba_real_gl(1,1:pvr_rgb%num_pixel_actual) & + & = pvr_rgb%rgba_left_gl(1,1:pvr_rgb%num_pixel_actual) +! pvr_rgb%rgba_real_gl(2,1:pvr_rgb%num_pixel_actual) & +! & = pvr_rgb%rgba_left_gl(2,1:pvr_rgb%num_pixel_actual) +! pvr_rgb%rgba_real_gl(3,1:pvr_rgb%num_pixel_actual) & +! & = pvr_rgb%rgba_left_gl(3,1:pvr_rgb%num_pixel_actual) + pvr_rgb%rgba_real_gl(4,1:pvr_rgb%num_pixel_actual) & + & = pvr_rgb%rgba_real_gl(4,1:pvr_rgb%num_pixel_actual) & + & + pvr_rgb%rgba_left_gl(4,1:pvr_rgb%num_pixel_actual) +!$omp end parallel workshare +! + end subroutine add_left_eye_image +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine copy_pvr_image_file_param(org_pvr_rgb, rot_pvr_rgb) +! + type(pvr_image_type), intent(in) :: org_pvr_rgb + type(pvr_image_type), intent(inout) :: rot_pvr_rgb +! +! + rot_pvr_rgb%iflag_monitoring = org_pvr_rgb%iflag_monitoring + rot_pvr_rgb%id_pvr_file_type = org_pvr_rgb%id_pvr_file_type + rot_pvr_rgb%id_pvr_transparent = org_pvr_rgb%id_pvr_transparent + rot_pvr_rgb%pvr_prefix = org_pvr_rgb%pvr_prefix +! + end subroutine copy_pvr_image_file_param +! +! --------------------------------------------------------------------- +! + subroutine copy_pvr_image_data(org_pvr_rgb, new_pvr_rgb) +! + type(pvr_image_type), intent(in) :: org_pvr_rgb + type(pvr_image_type), intent(inout) :: new_pvr_rgb +! +! + if(my_rank .ne. org_pvr_rgb%irank_image_file) return +!$omp parallel workshare + new_pvr_rgb%rgba_real_gl(1:4,1:new_pvr_rgb%num_pixel_actual) & + & = org_pvr_rgb%rgba_real_gl(1:4,1:new_pvr_rgb%num_pixel_actual) +!$omp end parallel workshare +! + end subroutine copy_pvr_image_data +! +! --------------------------------------------------------------------- +! + end module t_pvr_image_array diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_image_stack_table.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_image_stack_table.f90 new file mode 100644 index 00000000..5aaf7b6a --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_image_stack_table.f90 @@ -0,0 +1,242 @@ +!>@file t_pvr_image_stack_table.f90 +!!@brief module t_pvr_image_stack_table +!! +!!@author H. Matsui +!!@date Programmed on Oct., 2016 +! +!>@brief Work structure to make stencil buffer +!! +!!@verbatim +!! subroutine alloc_pvr_image_stack_table(img_stack) +!! subroutine alloc_depth_pixel_composit & +!! & (num_pvr_ray, ntot_recv_composit, img_stack) +!! subroutine alloc_pvr_ipixel_4_composit(num_pixel_xy, img_stack) +!! type(pvr_image_stack_table), intent(inout) :: img_stack +!! +!! subroutine dealloc_pvr_image_stack_table(img_stack) +!! subroutine dealloc_depth_pixel_composit(img_stack) +!! subroutine dealloc_pvr_ipixel_4_composit(img_stack) +!! type(pvr_image_stack_table), intent(inout) :: img_stack +!! +!! subroutine composit_rendering_image & +!! & (img_stack, npixel_recved, rgba_subdomain, & +!! & npixel_stacked, rgba_composit) +!! subroutine check_rendering_image(id_file, i_ref, & +!! & img_stack, npixel_recved, rgba_subdomain, & +!! & npixel_stacked, rgba_composit) +!! type(pvr_image_stack_table), intent(in) :: img_stack +!! +!! subroutine set_global_pixel_4_composit & +!! & (stencil_wk, npixel_4_composit, num_pixel_xy, & +!! & ipixel_4_composit, item_4_composit) +!!@endverbatim +!! + module t_pvr_image_stack_table +! + use m_precision + use m_constants + use calypso_mpi +! + use t_calypso_comm_table + use t_stencil_buffer_work +! + implicit none +! + type pvr_image_stack_table + integer(kind = kint) :: npixel_4_composit + integer(kind = kint), allocatable :: istack_composition(:) +! + integer(kind = kint), allocatable :: ipix_4_composit(:) + real(kind = kreal), allocatable :: depth_pixel_composit(:) + real(kind = kreal), allocatable :: depth_pvr_ray_start(:) +! + integer(kind = kint), allocatable :: ipixel_4_composit(:) + integer(kind = kint), allocatable :: item_4_composit(:) + end type pvr_image_stack_table +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_image_stack_table(img_stack) +! + type(pvr_image_stack_table), intent(inout) :: img_stack +! + integer(kind = kint) :: n_image +! + n_image = img_stack%npixel_4_composit + allocate(img_stack%istack_composition(0:n_image)) +! + img_stack%istack_composition(0:n_image) = 0 +! + end subroutine alloc_pvr_image_stack_table +! +! --------------------------------------------------------------------- +! + subroutine alloc_depth_pixel_composit & + & (num_pvr_ray, ntot_recv_composit, img_stack) +! + integer(kind = kint), intent(in) :: ntot_recv_composit + integer(kind = kint), intent(in) :: num_pvr_ray + type(pvr_image_stack_table), intent(inout) :: img_stack +! +! + allocate(img_stack%ipix_4_composit(ntot_recv_composit)) + allocate(img_stack%depth_pixel_composit(ntot_recv_composit)) + allocate(img_stack%depth_pvr_ray_start(num_pvr_ray)) +! + if(ntot_recv_composit .gt. 0) then +!$omp parallel workshare + img_stack%ipix_4_composit(1:ntot_recv_composit) = 0 + img_stack%depth_pixel_composit(1:ntot_recv_composit) = 0.0d0 +!$omp end parallel workshare + end if +! + if(num_pvr_ray .gt. 0) then +!$omp parallel workshare + img_stack%depth_pvr_ray_start(1:num_pvr_ray) = 0.0d0 +!$omp end parallel workshare + end if +! + end subroutine alloc_depth_pixel_composit +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_ipixel_4_composit(num_pixel_xy, img_stack) +! + integer(kind = kint), intent(in) :: num_pixel_xy + type(pvr_image_stack_table), intent(inout) :: img_stack +! + integer(kind = kint) :: n_composit +! + n_composit = img_stack%npixel_4_composit + allocate(img_stack%ipixel_4_composit(n_composit)) + allocate(img_stack%item_4_composit(num_pixel_xy)) +! + if(n_composit .gt. 0) then +!$omp parallel workshare + img_stack%ipixel_4_composit(1:n_composit) = 0 +!$omp end parallel workshare + end if +! + end subroutine alloc_pvr_ipixel_4_composit +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_image_stack_table(img_stack) +! + type(pvr_image_stack_table), intent(inout) :: img_stack +! +! + deallocate(img_stack%istack_composition) +! + end subroutine dealloc_pvr_image_stack_table +! +! --------------------------------------------------------------------- +! + subroutine dealloc_depth_pixel_composit(img_stack) +! + type(pvr_image_stack_table), intent(inout) :: img_stack +! +! + deallocate(img_stack%ipix_4_composit) + deallocate(img_stack%depth_pixel_composit) + deallocate(img_stack%depth_pvr_ray_start) +! + end subroutine dealloc_depth_pixel_composit +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_ipixel_4_composit(img_stack) +! + type(pvr_image_stack_table), intent(inout) :: img_stack +! + deallocate(img_stack%ipixel_4_composit) + deallocate(img_stack%item_4_composit) +! + end subroutine dealloc_pvr_ipixel_4_composit +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine composit_rendering_image & + & (img_stack, npixel_recved, rgba_subdomain, & + & npixel_stacked, rgba_composit) +! + use set_rgba_4_each_pixel +! + type(pvr_image_stack_table), intent(in) :: img_stack + integer(kind = kint), intent(in) :: npixel_recved, npixel_stacked + real(kind = kreal), intent(in) :: rgba_subdomain(4,npixel_recved) +! + real(kind = kreal), intent(inout) & + & :: rgba_composit(4,npixel_stacked) +! + integer(kind = kint) :: inum, ipix, ist, ied +! +! +!$omp parallel do private(ipix,ist,ied,inum) + do ipix = 1, img_stack%npixel_4_composit + ist = img_stack%istack_composition(ipix-1) + ied = img_stack%istack_composition(ipix) + do inum = ist+1, ied + call composite_alpha_blending(rgba_subdomain(1,inum), & + & rgba_composit(1,ipix)) + end do + end do +!$omp end parallel do +! + end subroutine composit_rendering_image +! +! --------------------------------------------------------------------- +! + subroutine check_rendering_image(id_file, i_ref, & + & img_stack, npixel_recved, rgba_subdomain, & + & npixel_stacked, rgba_composit) +! + use set_rgba_4_each_pixel +! + integer(kind = kint), intent(in) :: id_file, i_ref + type(pvr_image_stack_table), intent(in) :: img_stack + integer(kind = kint), intent(in) :: npixel_recved, npixel_stacked + real(kind = kreal), intent(in) :: rgba_subdomain(4,npixel_recved) +! + real(kind = kreal), intent(in) :: rgba_composit(4,npixel_stacked) +! + integer(kind = kint) :: inum, ipix, ist, ied + real(kind = kreal) :: rgb_test(4) + integer :: i +! + rgb_test(1:4) = 0.0d0 +! + do ipix = 1, img_stack%npixel_4_composit + ist = img_stack%istack_composition(ipix-1) + ied = img_stack%istack_composition(ipix) + do inum = ist+1, ied + if(img_stack%ipixel_4_composit(ipix) .eq. i_ref) then + write(id_file,*) 'rgba_subdomain', i_ref, inum, & + & rgba_subdomain(1:4,inum), & + & img_stack%depth_pixel_composit(inum) +! + call composite_alpha_blending(rgba_subdomain(1,inum), & + & rgb_test(1)) + end if + end do + end do +! + do i = 1, npixel_stacked + if(img_stack%ipixel_4_composit(i) .eq. i_ref) then + write(id_file,*) 'rgb_test', i_ref, i, rgb_test(1:4) + write(id_file,*) & + & 'rgba_composit', i_ref, i, rgba_composit(1:4,i) + end if + end do +! + end subroutine check_rendering_image +! +! --------------------------------------------------------------------- +! + end module t_pvr_image_stack_table diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_ray_startpoints.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_ray_startpoints.f90 new file mode 100644 index 00000000..4a7c2940 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_ray_startpoints.f90 @@ -0,0 +1,272 @@ +!>@file t_pvr_ray_startpoints.f90 +!! module t_pvr_ray_startpoints +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structures for start points for ray tracing +!! +!!@verbatim +!! subroutine allocate_num_pvr_ray_start(num_pvr_surf, pvr_start) +!! subroutine allocate_item_pvr_ray_start(num_ray, pvr_start) +!! subroutine allocate_item_pvr_ray_pixels(pvr_start) +!! subroutine deallocate_pvr_ray_start(pvr_start) +!! subroutine deallocate_num_pvr_ray_start(pvr_start) +!! subroutine deallocate_item_pvr_ray_start(pvr_start) +!! +!! subroutine copy_item_pvr_ray_start(org_pvr_st, new_pvr_st) +!! +!! subroutine check_pvr_ray_startpoints(id_rank, pvr_start) +!!@endverbatim +! + module t_pvr_ray_startpoints +! + use m_precision + use m_constants +! + implicit none +! +!> Structure for start points of ray tracing + type pvr_ray_start_type + +!> Total number of ray tracing + integer(kind = kint) :: ntot_pvr_ray = 0 +! +!> Number of ray tracing + integer(kind = kint) :: ntot_tmp_pvr_ray +!> temporal number of pixels to start ray tracing + integer(kind = kint), allocatable :: istack_tmp_pvr_ray_st(:) +!> temporal number of pixels to start ray tracing + integer(kind = kint), allocatable :: ipix_start_tmp(:,:) +!> temporal number of pixels to start ray tracing + integer(kind = kint), allocatable :: iflag_start_tmp(:) +!> start point of ray traing in surface coordinate + real(kind = kreal), allocatable :: xi_start_tmp(:,:) +! +! +!> Number of ray tracing + integer(kind = kint) :: num_pvr_ray +!> stack of number of pixels to start ray tracing + integer(kind = kint), allocatable :: istack_pvr_ray_sf(:) +! +!> pixel ID for ray tracing + integer(kind= kint), allocatable :: id_pixel_start(:) +!> Start surface ID for ray tracing + integer(kind= kint), allocatable :: isf_pvr_ray_start(:,:) +!> start point of ray traing in surface coordinate + real(kind = kreal), allocatable :: xi_pvr_start(:,:) +!> start point of ray traing + real(kind = kreal), allocatable :: xx4_pvr_ray_start(:,:) +!> start point for each trace + real(kind = kreal), allocatable :: xx4_pvr_start(:,:) +!> Direction og ray tracing +! real(kind = kreal), allocatable :: pvr_ray_dir(:,:) +!> Color data for tracing + real(kind = kreal), allocatable :: rgba_ray(:,:) +! +!> pixel check flag for ray tracing + integer(kind= kint), allocatable :: id_pixel_check(:) + end type pvr_ray_start_type +! +!> Direction of Ray in screen coordinate + real(kind = kreal), parameter & + & :: ray_vec4(4) = (/zero, zero, -one, zero/) +! +! private :: deallocate_num_pvr_ray_start +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine allocate_num_pvr_ray_start(num_pvr_surf, pvr_start) +! + integer(kind = kint), intent(in) :: num_pvr_surf + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + allocate(pvr_start%istack_pvr_ray_sf(0:num_pvr_surf)) + allocate(pvr_start%istack_tmp_pvr_ray_st(0:num_pvr_surf)) +! + pvr_start%istack_pvr_ray_sf = 0 + pvr_start%istack_tmp_pvr_ray_st = 0 +! + end subroutine allocate_num_pvr_ray_start +! +! --------------------------------------------------------------------- +! + subroutine allocate_item_pvr_ray_start(num_ray, pvr_start) +! + integer(kind = kint), intent(in) :: num_ray + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + pvr_start%num_pvr_ray = num_ray + allocate(pvr_start%id_pixel_start(pvr_start%num_pvr_ray) ) + allocate(pvr_start%isf_pvr_ray_start(3,pvr_start%num_pvr_ray)) + allocate(pvr_start%xi_pvr_start(2,pvr_start%num_pvr_ray) ) + allocate(pvr_start%xx4_pvr_ray_start(4,pvr_start%num_pvr_ray)) + allocate(pvr_start%xx4_pvr_start(4,pvr_start%num_pvr_ray) ) +! allocate(pvr_start%pvr_ray_dir(3,pvr_start%num_pvr_ray) ) + allocate(pvr_start%id_pixel_check(pvr_start%num_pvr_ray) ) +! + if(pvr_start%num_pvr_ray .gt. 0) then + pvr_start%id_pixel_start(1:pvr_start%num_pvr_ray) = 0 + pvr_start%isf_pvr_ray_start(1:3,1:pvr_start%num_pvr_ray) = 0 + pvr_start%xi_pvr_start(1:2,1:pvr_start%num_pvr_ray) = 0.0d0 + pvr_start%xx4_pvr_ray_start(1:4,1:pvr_start%num_pvr_ray) & + & = 0.0d0 + pvr_start%xx4_pvr_start(1:4,1:pvr_start%num_pvr_ray) = 0.0d0 + pvr_start%id_pixel_check(1:pvr_start%num_pvr_ray) = 0 + end if +! + end subroutine allocate_item_pvr_ray_start +! +! --------------------------------------------------------------------- +! + subroutine allocate_item_pvr_ray_pixels(pvr_start) +! + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + allocate(pvr_start%rgba_ray(4,pvr_start%num_pvr_ray)) +! + if(pvr_start%num_pvr_ray .gt. 0) then +!$omp parallel workshare + pvr_start%rgba_ray(1:4,1:pvr_start%num_pvr_ray) = 0.0d0 +!$omp end parallel workshare + end if +! + end subroutine allocate_item_pvr_ray_pixels +! +! --------------------------------------------------------------------- +! + subroutine allocate_tmp_pvr_ray_start(pvr_start) +! + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + allocate(pvr_start%ipix_start_tmp(2,pvr_start%ntot_tmp_pvr_ray)) + allocate(pvr_start%iflag_start_tmp(pvr_start%ntot_tmp_pvr_ray)) + allocate(pvr_start%xi_start_tmp(2,pvr_start%ntot_tmp_pvr_ray)) +! + if(pvr_start%ntot_tmp_pvr_ray .gt. 0) then + pvr_start%ipix_start_tmp = 0 + pvr_start%iflag_start_tmp = 0 + pvr_start%xi_start_tmp = 0.0d0 + end if +! + end subroutine allocate_tmp_pvr_ray_start +! +! --------------------------------------------------------------------- +! + subroutine deallocate_pvr_ray_start(pvr_start) +! + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + call deallocate_item_pvr_ray_pixels(pvr_start) + call deallocate_item_pvr_ray_start(pvr_start) + call deallocate_tmp_pvr_ray_start(pvr_start) + call deallocate_num_pvr_ray_start(pvr_start) +! + end subroutine deallocate_pvr_ray_start +! +! --------------------------------------------------------------------- +! + subroutine deallocate_tmp_pvr_ray_start(pvr_start) +! + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + deallocate(pvr_start%ipix_start_tmp) + deallocate(pvr_start%iflag_start_tmp, pvr_start%xi_start_tmp) +! + end subroutine deallocate_tmp_pvr_ray_start +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine deallocate_num_pvr_ray_start(pvr_start) +! + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + deallocate(pvr_start%istack_pvr_ray_sf) + deallocate(pvr_start%istack_tmp_pvr_ray_st) +! + end subroutine deallocate_num_pvr_ray_start +! +! --------------------------------------------------------------------- +! + subroutine deallocate_item_pvr_ray_start(pvr_start) +! + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + deallocate(pvr_start%id_pixel_start) + deallocate(pvr_start%isf_pvr_ray_start) + deallocate(pvr_start%xx4_pvr_ray_start) + deallocate(pvr_start%xx4_pvr_start, pvr_start%xi_pvr_start) + deallocate(pvr_start%id_pixel_check) +! + end subroutine deallocate_item_pvr_ray_start +! +! --------------------------------------------------------------------- +! + subroutine deallocate_item_pvr_ray_pixels(pvr_start) +! + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + deallocate(pvr_start%rgba_ray) +! + end subroutine deallocate_item_pvr_ray_pixels +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine copy_item_pvr_ray_start(org_pvr_st, new_pvr_st) +! + type(pvr_ray_start_type), intent(in) :: org_pvr_st + type(pvr_ray_start_type), intent(inout) :: new_pvr_st +! +! +!$omp parallel workshare + new_pvr_st%id_pixel_start(:) = org_pvr_st%id_pixel_start(:) +! + new_pvr_st%isf_pvr_ray_start(:,:) & + & = org_pvr_st%isf_pvr_ray_start(:,:) + new_pvr_st%xi_pvr_start(:,:) = org_pvr_st%xi_pvr_start(:,:) + new_pvr_st%xx4_pvr_ray_start(:,:) & + & = org_pvr_st%xx4_pvr_ray_start(:,:) + new_pvr_st%xx4_pvr_start(:,:) = org_pvr_st%xx4_pvr_start(:,:) +!$omp end parallel workshare +! + end subroutine copy_item_pvr_ray_start +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine check_pvr_ray_startpoints(id_rank, pvr_start) +! + integer, intent(in) :: id_rank + type(pvr_ray_start_type), intent(inout) :: pvr_start +! +! + integer(kind = kint) :: inum +! +! + write(50+id_rank,*) 'num_pvr_ray', pvr_start%num_pvr_ray + do inum = 1, pvr_start%num_pvr_ray + write(50+id_rank,*) inum, pvr_start%id_pixel_start(inum), & + & pvr_start%isf_pvr_ray_start(1:3,inum), & + & pvr_start%xx4_pvr_ray_start(1:3,inum) + end do +! + end subroutine check_pvr_ray_startpoints +! +! --------------------------------------------------------------------- +! + end module t_pvr_ray_startpoints diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_stencil_buffer.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_stencil_buffer.f90 new file mode 100644 index 00000000..fcc8e674 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_pvr_stencil_buffer.f90 @@ -0,0 +1,205 @@ +!>@file t_pvr_stencil_buffer.f90 +!!@brief module t_pvr_stencil_buffer +!! +!!@author H. Matsui +!!@date Programmed on Oct., 2016 +! +!>@brief Work structure to make stencil buffer +!! +!!@verbatim +!! subroutine const_pvr_stencil_buffer(elps_PVR, pvr_rgb, & +!! & pvr_start, pvr_stencil, SR_sig, SR_r, SR_i) +!! subroutine collect_rendering_image(pvr_start, num_pixel_actual, & +!! & rgba_real_gl, pvr_stencil, SR_sig, SR_r) +!! subroutine dealloc_pvr_stencil_buffer(pvr_stencil) +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(pvr_ray_start_type), intent(in) :: pvr_start +!! type(pvr_image_type), intent(in) :: pvr_rgb +!! type(pvr_stencil_buffer), intent(inout) :: pvr_stencil +!! type(send_recv_status), intent(inout) :: SR_sig +!! type(send_recv_real_buffer), intent(inout) :: SR_r +!! type(send_recv_int_buffer), intent(inout) :: SR_i +!!@endverbatim +!! + module t_pvr_stencil_buffer +! + use m_precision + use m_constants + use m_machine_parameter + use calypso_mpi +! + use t_calypso_comm_table + use t_pvr_ray_startpoints + use t_pvr_image_stack_table + use t_stencil_buffer_work + use t_pvr_image_array +! + implicit none +! + type pvr_stencil_buffer + type(pvr_image_stack_table) :: img_stack + type(calypso_comm_table) :: img_output_tbl + type(calypso_comm_table) :: img_composit_tbl +! + integer(kind = kint) :: num_pixel_recv + integer(kind = kint) :: npixel_recved + real(kind = kreal), allocatable :: rgba_subdomain(:,:) + integer(kind = kint) :: npixel_stacked + real(kind = kreal), allocatable :: rgba_composit(:,:) + end type pvr_stencil_buffer +! + private :: alloc_pvr_stencil_buffer, reset_color_data +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine const_pvr_stencil_buffer(elps_PVR, pvr_rgb, & + & pvr_start, pvr_stencil, SR_sig, SR_r, SR_i) +! + use m_work_time + use set_pvr_stencil_buffer +! + type(elapsed_lables), intent(in) :: elps_PVR + type(pvr_image_type), intent(in) :: pvr_rgb + type(pvr_ray_start_type), intent(in) :: pvr_start +! + type(pvr_stencil_buffer), intent(inout) :: pvr_stencil + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r + type(send_recv_int_buffer), intent(inout) :: SR_i +! + type(stencil_buffer_work) :: stencil_wk +! +! + call const_stencil_buffer_work & + & (pvr_rgb%irank_image_file, pvr_rgb%npe_img_composit, & + & pvr_rgb%num_pixel_xy, pvr_start, stencil_wk) +! + call s_set_pvr_stencil_buffer & + & (pvr_rgb%irank_image_file, pvr_rgb%irank_end_composit, & + & pvr_rgb%num_pixel_xy, elps_PVR, pvr_start, stencil_wk, & + & pvr_stencil%num_pixel_recv, pvr_stencil%img_output_tbl, & + & pvr_stencil%img_composit_tbl, pvr_stencil%img_stack, & + & SR_sig, SR_r, SR_i) +! + if(i_debug .eq. 0) then + call dealloc_pvr_ipixel_4_composit(pvr_stencil%img_stack) + call dealloc_depth_pixel_composit(pvr_stencil%img_stack) + end if + call dealloc_stencil_buffer_work(stencil_wk) +! + call alloc_pvr_stencil_buffer(pvr_stencil) +! + end subroutine const_pvr_stencil_buffer +! +! --------------------------------------------------------------------- +! + subroutine collect_rendering_image(pvr_start, num_pixel_actual, & + & rgba_real_gl, pvr_stencil, SR_sig, SR_r) +! + use t_solver_SR + use calypso_SR_type + use select_copy_from_recv +! + type(pvr_ray_start_type), intent(in) :: pvr_start + integer(kind = kint), intent(in) :: num_pixel_actual +! + type(pvr_stencil_buffer), intent(inout) :: pvr_stencil + real(kind = kreal), intent(inout) & + & :: rgba_real_gl(4,num_pixel_actual) + type(send_recv_status), intent(inout) :: SR_sig + type(send_recv_real_buffer), intent(inout) :: SR_r +! +! + call reset_color_data & + & (pvr_stencil%npixel_recved, pvr_stencil%rgba_subdomain) + call calypso_SR_type_N & + & (iflag_import_mod, ifour, pvr_stencil%img_composit_tbl, & + & pvr_start%num_pvr_ray, pvr_stencil%npixel_recved, & + & pvr_start%rgba_ray(1,1), pvr_stencil%rgba_subdomain(1,1), & + & SR_sig, SR_r) +! + call reset_color_data & + & (pvr_stencil%npixel_stacked, pvr_stencil%rgba_composit) + call composit_rendering_image(pvr_stencil%img_stack, & + & pvr_stencil%npixel_recved, pvr_stencil%rgba_subdomain, & + & pvr_stencil%npixel_stacked, pvr_stencil%rgba_composit) +! +! + call reset_color_data(num_pixel_actual, rgba_real_gl) + call calypso_SR_type_N & + & (iflag_import_mod, ifour, pvr_stencil%img_output_tbl, & + & pvr_stencil%npixel_stacked, num_pixel_actual, & + & pvr_stencil%rgba_composit(1,1), rgba_real_gl(1,1), & + & SR_sig, SR_r) +! + end subroutine collect_rendering_image +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_stencil_buffer(pvr_stencil) +! + type(pvr_stencil_buffer), intent(inout) :: pvr_stencil +! +! + deallocate(pvr_stencil%rgba_subdomain) + deallocate(pvr_stencil%rgba_composit) +! + if(i_debug .gt. 0) then + call dealloc_pvr_ipixel_4_composit(pvr_stencil%img_stack) + call dealloc_depth_pixel_composit(pvr_stencil%img_stack) + end if +! + call dealloc_pvr_image_stack_table(pvr_stencil%img_stack) +! + call dealloc_calypso_comm_table(pvr_stencil%img_output_tbl) + call dealloc_calypso_comm_table(pvr_stencil%img_composit_tbl) +! + end subroutine dealloc_pvr_stencil_buffer +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_stencil_buffer(pvr_stencil) +! + type(pvr_stencil_buffer), intent(inout) :: pvr_stencil +! +! + pvr_stencil%npixel_recved & + & = pvr_stencil%img_composit_tbl%ntot_import + allocate(pvr_stencil%rgba_subdomain(4,pvr_stencil%npixel_recved)) +! + pvr_stencil%npixel_stacked & + & = pvr_stencil%img_stack%npixel_4_composit + allocate(pvr_stencil%rgba_composit(4,pvr_stencil%npixel_stacked)) +! + end subroutine alloc_pvr_stencil_buffer +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine reset_color_data(num, rgba) +! + integer(kind = kint), intent(in) :: num + real(kind = kreal), intent(inout) :: rgba(4*num) +! + integer(kind = kint) :: i +! +! +!$omp parallel do + do i = 1, num + rgba(4*i-3) = 0.0d0 + rgba(4*i-2) = 0.0d0 + rgba(4*i-1) = 0.0d0 + rgba(4*i ) = 0.0d0 + end do +!$omp end parallel do +! + end subroutine reset_color_data +! +! --------------------------------------------------------------------- +! + end module t_pvr_stencil_buffer diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_rendering_vr_image.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_rendering_vr_image.f90 new file mode 100644 index 00000000..183d940d --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_rendering_vr_image.f90 @@ -0,0 +1,132 @@ +!>@file t_rendering_vr_image.f90 +!! module t_rendering_vr_image +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structures for position in the projection coordinate +!! +!!@verbatim +!! subroutine alloc_multi_view_parameters(num_views, pvr_param) +!! subroutine dealloc_multi_view_parameters(num_views, pvr_param) +!! integer(kind = kint), intent(in) :: num_views +!! type(PVR_control_params), intent(inout) :: pvr_param +!! subroutine flush_rendering_4_fixed_view(pvr_proj) +!! type(PVR_projection_data), intent(inout) :: pvr_proj +!!@endverbatim +! + module t_rendering_vr_image +! + use m_precision + use m_machine_parameter + use m_constants + use m_work_time +! + use calypso_mpi +! + use t_mesh_data + use t_geometry_data + use t_surface_data + use t_group_data + use t_surf_grp_list_each_surf + use t_control_params_4_pvr + use t_pvr_colormap_parameter + use t_geometries_in_pvr_screen + use t_pvr_ray_startpoints + use t_pvr_image_array + use t_pvr_stencil_buffer + use t_pvr_field_data + use t_control_params_stereo_pvr + use t_mesh_SR + use generate_vr_image +! + implicit none +! +!> Structure of PVR control parameters + type PVR_control_params +!> Structure for rendering area by element group + type(viz_area_parameter) :: area_def +!> Structure for field parameter for PVR + type(pvr_field_parameter) :: field_def +! +!> Parameters for image pixels + type(pvr_pixel_position_type) :: pixel +!> Structure for rough serch of subdomains + type(pvr_domain_outline) :: outline +!> Field data for volume rendering + type(rendering_parameter) :: draw_param +!> Structure for PVR colormap + type(pvr_colorbar_parameter):: colorbar +! +!> Color paramter for volume rendering + type(pvr_colormap_parameter) :: color +!> Movie parameters + type(pvr_movie_parameter) :: movie_def +!> Stereo view parameters + type(pvr_stereo_parameter) :: stereo_def +! +!> Logical flag to use multi view paramter from movie block + logical :: flag_mulview_movie = .FALSE. +!> Number of mulitple view parameters + integer(kind = kint) :: num_multi_views = 0 +!> Multiple viewer coordinate information + type(pvr_view_parameter), allocatable :: multi_view(:) + end type PVR_control_params +! +! +!> Structure for projection data + type PVR_projection_data +!> Data on screen coordinate + type(pvr_projected_position) :: screen +!> Parallel stencil buffer + type(pvr_stencil_buffer) :: stencil +!> Start point structure for volume rendering with fixed view + type(pvr_ray_start_type) :: start_fix +! +!> Start point structure for volume rendering with fixed view + type(pvr_ray_start_type) :: start_save + end type PVR_projection_data +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_multi_view_parameters(num_views, pvr_param) +! + integer(kind = kint), intent(in) :: num_views + type(PVR_control_params), intent(inout) :: pvr_param +! + pvr_param%num_multi_views = num_views + allocate(pvr_param%multi_view(pvr_param%num_multi_views)) +! + end subroutine alloc_multi_view_parameters +! +! --------------------------------------------------------------------- +! + subroutine dealloc_multi_view_parameters(pvr_param) +! + type(PVR_control_params), intent(inout) :: pvr_param +! + if(allocated(pvr_param%multi_view) .eqv. .FALSE.) return + deallocate(pvr_param%multi_view) + pvr_param%num_multi_views = 0 +! + end subroutine dealloc_multi_view_parameters +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine flush_rendering_4_fixed_view(pvr_proj) +! + type(PVR_projection_data), intent(inout) :: pvr_proj +! +! + call dealloc_pvr_stencil_buffer(pvr_proj%stencil) +! + end subroutine flush_rendering_4_fixed_view +! +! --------------------------------------------------------------------- +! + end module t_rendering_vr_image diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_rotation_pvr_images.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_rotation_pvr_images.f90 new file mode 100644 index 00000000..0381c371 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_rotation_pvr_images.f90 @@ -0,0 +1,151 @@ +!>@file t_rotation_pvr_images.f90 +!!@brief module t_rotation_pvr_images +!! +!!@date Programmed by H.Matsui in May, 2021 +! +!>@brief Structure to output rotation images +!! +!!@verbatim +!! subroutine init_rot_pvr_image_arrays & +!! & (movie_def, pvr_rgb, rot_imgs) +!! subroutine dealloc_rot_pvr_image_arrays(movie_def, rot_imgs) +!! type(pvr_movie_parameter), intent(in) :: movie_def +!! type(pvr_image_type), intent(in) :: pvr_rgb(2) +!! type(rotation_pvr_images), intent(inout) :: rot_imgs +!!@endverbatim +! + module t_rotation_pvr_images +! + use m_precision +! + use calypso_mpi + use m_constants + use m_machine_parameter + use t_pvr_image_array + use t_control_params_4_pvr +! + implicit none +! +! +!> Structure of PVR images for rotation + type rotation_pvr_images +!> Structure of each PVR image in rotation + type(pvr_image_type), allocatable :: rot_pvr_rgb(:) + end type rotation_pvr_images +! + private :: alloc_rot_pvr_image_arrays + private :: set_rank_to_write_rot_images +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine init_rot_pvr_image_arrays & + & (movie_def, pvr_rgb, rot_imgs) +! + type(pvr_movie_parameter), intent(in) :: movie_def +! + type(pvr_image_type), intent(in) :: pvr_rgb + type(rotation_pvr_images), intent(inout) :: rot_imgs +! + integer(kind = kint) :: i_rot +! +! + call alloc_rot_pvr_image_arrays(movie_def%num_frame, rot_imgs) +! + call set_rank_to_write_rot_images(pvr_rgb, & + & movie_def%num_frame, rot_imgs%rot_pvr_rgb) + do i_rot = 1, movie_def%num_frame + call alloc_pvr_image_array & + & (pvr_rgb%num_pixels, rot_imgs%rot_pvr_rgb(i_rot)) + end do +! + if(iflag_debug .eq. 0) return + do i_rot = 1, movie_def%num_frame + write(*,*) i_rot, 'rot_pvr_rgb%irank_image_file', & + & rot_imgs%rot_pvr_rgb(i_rot)%irank_image_file, & + & rot_imgs%rot_pvr_rgb(i_rot)%irank_end_composit, & + & rot_imgs%rot_pvr_rgb(i_rot)%npe_img_composit + end do +! + end subroutine init_rot_pvr_image_arrays +! +! --------------------------------------------------------------------- +! + subroutine dealloc_rot_pvr_image_arrays(movie_def, rot_imgs) +! + type(pvr_movie_parameter), intent(in) :: movie_def + type(rotation_pvr_images), intent(inout) :: rot_imgs +! + integer(kind = kint) :: i_rot +! +! + do i_rot = 1, movie_def%num_frame + call dealloc_pvr_image_array(rot_imgs%rot_pvr_rgb(i_rot)) + end do + deallocate(rot_imgs%rot_pvr_rgb) +! + end subroutine dealloc_rot_pvr_image_arrays +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine alloc_rot_pvr_image_arrays(num_frame, rot_imgs) +! + integer(kind = kint), intent(in) :: num_frame + type(rotation_pvr_images), intent(inout) :: rot_imgs +! +! + allocate(rot_imgs%rot_pvr_rgb(num_frame)) +! + end subroutine alloc_rot_pvr_image_arrays +! +! --------------------------------------------------------------------- +! + subroutine set_rank_to_write_rot_images & + & (org_pvr_rgb, num_frame, rot_pvr_rgb) +! + integer(kind = kint), intent(in) :: num_frame + type(pvr_image_type), intent(in) :: org_pvr_rgb + type(pvr_image_type), intent(inout) & + & :: rot_pvr_rgb(num_frame) +! + integer(kind = kint) :: i_rot +! +! +!$omp parallel do + do i_rot = 1, num_frame + call copy_pvr_image_file_param(org_pvr_rgb, rot_pvr_rgb(i_rot)) +! + rot_pvr_rgb(i_rot)%irank_image_file & + & = int(dble(nprocs) * dble(i_rot-1) / dble(num_frame)) + end do +!$omp end parallel do +!$omp parallel do + do i_rot = 1, num_frame - 1 + if(rot_pvr_rgb(i_rot+1)%irank_image_file & + & .eq. rot_pvr_rgb(i_rot)%irank_image_file) then + rot_pvr_rgb(i_rot)%irank_end_composit & + & = rot_pvr_rgb(i_rot)%irank_image_file + rot_pvr_rgb(i_rot)%npe_img_composit = 1 + else + rot_pvr_rgb(i_rot)%irank_end_composit & + & = rot_pvr_rgb(i_rot+1)%irank_image_file - 1 + rot_pvr_rgb(i_rot)%npe_img_composit & + & = rot_pvr_rgb(i_rot+1)%irank_image_file & + & - rot_pvr_rgb(i_rot)%irank_image_file + end if + end do +!$omp end parallel do +! + rot_pvr_rgb(num_frame)%irank_end_composit = nprocs - 1 + rot_pvr_rgb(num_frame)%npe_img_composit & + & = nprocs - rot_pvr_rgb(num_frame)%irank_image_file +! + end subroutine set_rank_to_write_rot_images +! +! --------------------------------------------------------------------- +! + end module t_rotation_pvr_images diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_sort_PVRs_by_type.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_sort_PVRs_by_type.f90 new file mode 100644 index 00000000..e7f4b206 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_sort_PVRs_by_type.f90 @@ -0,0 +1,243 @@ +!>@file t_sort_PVRs_by_type.f90 +!!@brief module t_sort_PVRs_by_type +!! +!!@date Programmed by H.Matsui in May. 2006 +! +!>@brief Set PVR parameters from control files +!! +!!@verbatim +!! subroutine alloc_sort_PVRs_by_type(num_pvr, PVR_sort) +!! subroutine dealloc_sort_PVRs_list(PVR_sort) +!! subroutine dealloc_sort_PVRs_by_type(PVR_sort) +!! subroutine s_sort_PVRs_by_type(num_pvr, pvr_ctl, PVR_sort) +!! integer(kind = kint), intent(in) :: num_pvr +!! type(pvr_parameter_ctl), intent(in) :: pvr_ctl(num_pvr) +!! type(sort_PVRs_by_type), intent(inout) :: PVR_sort +!!@endverbatim + module t_sort_PVRs_by_type +! + use m_precision + use m_constants +! + use t_control_data_4_pvr +! + implicit none +! + type sort_PVRs_by_type + integer(kind = kint), allocatable :: istack_PVR_modes(:) +!> Number of image files for volume rendering + integer(kind = kint), allocatable :: istack_pvr_images(:) +! + integer(kind = kint), allocatable :: ipvr_sorted(:) +! + integer(kind = kint), pointer :: nPVR_modes(:) + integer(kind = kint), pointer :: nPVR_base + integer(kind = kint), pointer :: nPVR_quilt + integer(kind = kint), pointer :: nPVR_movie + integer(kind = kint), pointer :: nPVR_movie_quilt + integer(kind = kint), pointer :: nPVR_anaglyph + integer(kind = kint), pointer :: nPVR_mov_anaglyph + end type sort_PVRs_by_type +! + private :: count_anaglyph_PVRs_by_type, count_quilt_PVRs_by_type + private :: find_anaglyph_PVRs_by_type, find_quilt_PVRs_by_type +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine alloc_sort_PVRs_by_type(num_pvr, PVR_sort) +! + integer(kind = kint), intent(in) :: num_pvr +! + type(sort_PVRs_by_type), intent(inout) :: PVR_sort +! +! + allocate(PVR_sort%istack_pvr_images(0:num_pvr)) +!$omp parallel workshare + PVR_sort%istack_pvr_images(0:num_pvr) = 0 +!$omp end parallel workshare +! + allocate(PVR_sort%ipvr_sorted(num_pvr)) +!$omp parallel workshare + PVR_sort%ipvr_sorted(1:num_pvr) = 0 +!$omp end parallel workshare +! + allocate(PVR_sort%nPVR_modes(6)) + allocate(PVR_sort%istack_PVR_modes(0:6)) + PVR_sort%nPVR_modes(1:6) = 0 + PVR_sort%istack_PVR_modes(0:6) = 0 +! + PVR_sort%nPVR_base => PVR_sort%nPVR_modes(1) + PVR_sort%nPVR_quilt => PVR_sort%nPVR_modes(2) + PVR_sort%nPVR_movie => PVR_sort%nPVR_modes(3) + PVR_sort%nPVR_movie_quilt => PVR_sort%nPVR_modes(4) + PVR_sort%nPVR_anaglyph => PVR_sort%nPVR_modes(5) + PVR_sort%nPVR_mov_anaglyph => PVR_sort%nPVR_modes(6) +! + end subroutine alloc_sort_PVRs_by_type +! +! --------------------------------------------------------------------- +! + subroutine dealloc_sort_PVRs_list(PVR_sort) +! + type(sort_PVRs_by_type), intent(inout) :: PVR_sort +! +! + if(allocated(PVR_sort%ipvr_sorted) .eqv. .FALSE.) return + deallocate(PVR_sort%ipvr_sorted) +! + end subroutine dealloc_sort_PVRs_list +! +! --------------------------------------------------------------------- +! + subroutine dealloc_sort_PVRs_by_type(PVR_sort) +! + type(sort_PVRs_by_type), intent(inout) :: PVR_sort +! +! + if(allocated(PVR_sort%istack_PVR_modes) .eqv. .FALSE.) return + deallocate(PVR_sort%nPVR_modes, PVR_sort%istack_PVR_modes) + deallocate(PVR_sort%istack_pvr_images) +! + end subroutine dealloc_sort_PVRs_by_type +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine s_sort_PVRs_by_type(num_pvr, pvr_ctl, PVR_sort) +! + use cal_minmax_and_stacks +! + integer(kind = kint), intent(in) :: num_pvr + type(pvr_parameter_ctl), intent(in) :: pvr_ctl(num_pvr) +! + type(sort_PVRs_by_type), intent(inout) :: PVR_sort +! + integer(kind = kint) :: i_pvr, i, ntot +! +! + do i_pvr = 1, num_pvr + call count_anaglyph_PVRs_by_type(pvr_ctl(i_pvr), & + & PVR_sort%nPVR_modes(1:6)) + end do +! + call s_cal_total_and_stacks(isix, PVR_sort%nPVR_modes, izero, & + & PVR_sort%istack_PVR_modes, ntot) +! + PVR_sort%nPVR_modes(1:6) = 0 + do i_pvr = 1, num_pvr + call find_anaglyph_PVRs_by_type & + & (pvr_ctl(i_pvr), PVR_sort%istack_PVR_modes(0:6), & + & PVR_sort%nPVR_modes(1:6), PVR_sort%ipvr_sorted(i_pvr)) + end do +! + end subroutine s_sort_PVRs_by_type +! +! --------------------------------------------------------------------- +! + subroutine count_anaglyph_PVRs_by_type(pvr_ctl, icou_mode) +! + type(pvr_parameter_ctl), intent(in) :: pvr_ctl + integer(kind = kint), intent(inout) :: icou_mode(6) +! +! + if(yes_flag(pvr_ctl%anaglyph_ctl%charavalue)) then + if(pvr_ctl%movie%movie_mode_ctl%iflag .gt. 0) then + icou_mode(6) = icou_mode(6) + 1 + else + icou_mode(5) = icou_mode(5) + 1 + end if + else + if(pvr_ctl%movie%movie_mode_ctl%iflag .gt. 0) then + call count_quilt_PVRs_by_type & + & (pvr_ctl, icou_mode(3) , icou_mode(4)) + else + call count_quilt_PVRs_by_type & + & (pvr_ctl, icou_mode(1) , icou_mode(2)) + end if + end if +! + end subroutine count_anaglyph_PVRs_by_type +! +! --------------------------------------------------------------------- +! + subroutine count_quilt_PVRs_by_type(pvr_ctl, & + & icou_base, icou_quilt) +! + type(pvr_parameter_ctl), intent(in) :: pvr_ctl +! + integer(kind = kint), intent(inout) :: icou_base, icou_quilt +! +! + if(yes_flag(pvr_ctl%quilt_ctl%charavalue)) then + icou_quilt = icou_quilt + 1 + else + icou_base = icou_base + 1 + end if +! + end subroutine count_quilt_PVRs_by_type +! +! --------------------------------------------------------------------- +! + subroutine find_anaglyph_PVRs_by_type(pvr_ctl, istack_mode, & + & icou_mode, ipvr_sorted) +! + type(pvr_parameter_ctl), intent(in) :: pvr_ctl +! + integer(kind = kint), intent(in) :: istack_mode(0:5) +! + integer(kind = kint), intent(inout) :: icou_mode(6) + integer(kind = kint), intent(inout) :: ipvr_sorted +! +! + if(yes_flag(pvr_ctl%anaglyph_ctl%charavalue)) then + if(pvr_ctl%movie%movie_mode_ctl%iflag .gt. 0) then + icou_mode(6) = icou_mode(6) + 1 + ipvr_sorted = istack_mode(5) + icou_mode(6) + else + icou_mode(5) = icou_mode(5) + 1 + ipvr_sorted = istack_mode(4) + icou_mode(5) + end if + else + if(pvr_ctl%movie%movie_mode_ctl%iflag .gt. 0) then + call find_quilt_PVRs_by_type & + & (pvr_ctl, istack_mode(2), istack_mode(3), & + & icou_mode(3) , icou_mode(4), ipvr_sorted) + else + call find_quilt_PVRs_by_type & + & (pvr_ctl, istack_mode(0), istack_mode(1), & + & icou_mode(1) , icou_mode(2), ipvr_sorted) + end if + end if +! + end subroutine find_anaglyph_PVRs_by_type +! +! --------------------------------------------------------------------- +! + subroutine find_quilt_PVRs_by_type(pvr_ctl, ist_base, ist_quilt, & + & icou_base, icou_quilt, ipvr_sorted) +! + type(pvr_parameter_ctl), intent(in) :: pvr_ctl +! + integer(kind = kint), intent(in) :: ist_base, ist_quilt + integer(kind = kint), intent(inout) :: icou_base, icou_quilt + integer(kind = kint), intent(inout) :: ipvr_sorted +! +! +! + if(yes_flag(pvr_ctl%quilt_ctl%charavalue)) then + icou_quilt = icou_quilt + 1 + ipvr_sorted = ist_quilt + icou_quilt + else + icou_base = icou_base + 1 + ipvr_sorted = ist_base + icou_base + end if +! + end subroutine find_quilt_PVRs_by_type +! +! --------------------------------------------------------------------- +! + end module t_sort_PVRs_by_type diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_stencil_buffer_work.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_stencil_buffer_work.f90 new file mode 100644 index 00000000..53ea9f64 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_stencil_buffer_work.f90 @@ -0,0 +1,259 @@ +!>@file t_stencil_buffer_work.f90 +!!@brief module t_stencil_buffer_work +!! +!!@author H. Matsui +!!@date Programmed on Oct., 2016 +! +!>@brief Work structure to make stencil buffer +!! +!!@verbatim +!! subroutine const_stencil_buffer_work & +!! & (irank_image_file, npe_img_composit, & +!! & num_pixel_xy, pvr_start, stencil_wk) +!! subroutine dealloc_stencil_buffer_work(stencil_wk) +!! type(pvr_ray_start_type), intent(in) :: pvr_start +!! type(stencil_buffer_work), intent(inout) :: stencil_wk +!!@endverbatim +!! +! + module t_stencil_buffer_work +! + use m_precision + use m_constants + use m_machine_parameter + use calypso_mpi +! + implicit none +! + type stencil_buffer_work + integer(kind = kint) :: ntot_recv_image + integer(kind = kint), allocatable :: istack_recv_image(:) + integer(kind = kint), allocatable :: irank_4_composit(:) + integer(kind = kint), allocatable :: item_recv_image(:) + integer(kind = kint), allocatable :: irev_recv_image(:) + end type stencil_buffer_work +! + private :: alloc_stencil_buffer_work + private :: count_local_ray_4_each_pixel + private :: set_global_stencil_buffer +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine const_stencil_buffer_work & + & (irank_image_file, npe_img_composit, & + & num_pixel_xy, pvr_start, stencil_wk) +! + use calypso_mpi_int8 + use t_pvr_ray_startpoints + use transfer_to_long_integers +! + integer(kind = kint), intent(in) :: irank_image_file + integer(kind = kint), intent(in) :: npe_img_composit + integer(kind = kint), intent(in) :: num_pixel_xy + type(pvr_ray_start_type), intent(in) :: pvr_start +! + type(stencil_buffer_work), intent(inout) :: stencil_wk +! + integer(kind = kint_gl) :: num_pvr_ray_gl + integer(kind = kint_gl) :: max_ray_start_lc, max_ray_start_gl + integer(kind = kint_gl), allocatable :: num_ray_start_lc(:) + integer(kind = kint_gl), allocatable :: num_ray_start_gl(:) +! +! + allocate(num_ray_start_lc(num_pixel_xy)) + if(my_rank .eq. int(irank_image_file)) then + allocate(num_ray_start_gl(num_pixel_xy)) + end if +! + call calypso_mpi_reduce_one_int8 & + & (cast_long(pvr_start%num_pvr_ray), num_pvr_ray_gl, & + & MPI_SUM, int(irank_image_file)) +! + call count_local_ray_4_each_pixel(num_pixel_xy, & + & pvr_start%num_pvr_ray, pvr_start%id_pixel_start, & + & num_ray_start_lc, max_ray_start_lc) +! + call calypso_mpi_reduce_int8(num_ray_start_lc, num_ray_start_gl, & + & cast_long(num_pixel_xy), MPI_SUM, int(irank_image_file)) + call calypso_mpi_reduce_one_int8 & + & (max_ray_start_lc, max_ray_start_gl, & + & MPI_SUM, int(irank_image_file)) +! + call alloc_stencil_buffer_work(num_pixel_xy, stencil_wk) + call set_global_stencil_buffer & + & (irank_image_file, npe_img_composit, & + & num_pixel_xy, num_pvr_ray_gl, num_ray_start_gl, stencil_wk) +! + if(i_debug.gt.0 .and. my_rank .eq. irank_image_file) then + write(*,*) 'Stencil buffer size, num. of segmented image: ', & + & stencil_wk%ntot_recv_image, max_ray_start_gl + write(*,*) 'Number of total ray trace: ', num_pvr_ray_gl + end if +! + deallocate(num_ray_start_lc) + if(my_rank .eq. irank_image_file) deallocate(num_ray_start_gl) +! + end subroutine const_stencil_buffer_work +! +! --------------------------------------------------------------------- +! + subroutine dealloc_stencil_buffer_work(stencil_wk) +! + type(stencil_buffer_work), intent(inout) :: stencil_wk +! +! + deallocate(stencil_wk%irev_recv_image) + deallocate(stencil_wk%istack_recv_image) + deallocate(stencil_wk%irank_4_composit) + deallocate(stencil_wk%item_recv_image) +! + end subroutine dealloc_stencil_buffer_work +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine alloc_stencil_buffer_work(num_pixel_xy, stencil_wk) +! + integer(kind = kint), intent(in) :: num_pixel_xy + type(stencil_buffer_work), intent(inout) :: stencil_wk +! +! + allocate(stencil_wk%istack_recv_image(0:nprocs)) +! + stencil_wk%istack_recv_image(0:nprocs) = 0 +! + allocate(stencil_wk%irank_4_composit(num_pixel_xy)) + allocate(stencil_wk%irev_recv_image(num_pixel_xy)) + allocate(stencil_wk%item_recv_image(num_pixel_xy)) +! + if(num_pixel_xy .gt. 0) then +!$omp parallel workshare + stencil_wk%irank_4_composit(1:num_pixel_xy) = -1 + stencil_wk%irev_recv_image(1:num_pixel_xy) = 0 + stencil_wk%item_recv_image(1:num_pixel_xy) = 0 +!$omp end parallel workshare + end if +! + end subroutine alloc_stencil_buffer_work +! +! --------------------------------------------------------------------- +! + subroutine count_local_ray_4_each_pixel & + & (num_pixel_xy, num_pvr_ray, id_pixel_start, & + & num_ray_start_lc, max_ray_start_lc) +! + integer(kind = kint), intent(in) :: num_pixel_xy + integer(kind = kint), intent(in) :: num_pvr_ray + integer(kind = kint), intent(in) :: id_pixel_start(num_pvr_ray) +! + integer(kind = kint_gl), intent(inout) & + & :: num_ray_start_lc(num_pixel_xy) + integer(kind = kint_gl), intent(inout) :: max_ray_start_lc +! + integer(kind = kint) :: inum, ipix +! +! +!$omp parallel workshare + num_ray_start_lc(1:num_pixel_xy) = 0 +!$omp end parallel workshare +! + do inum = 1, num_pvr_ray + ipix = id_pixel_start(inum) + num_ray_start_lc(ipix) = num_ray_start_lc(ipix) + 1 + end do + max_ray_start_lc = MAXVAL(num_ray_start_lc) +! + end subroutine count_local_ray_4_each_pixel +! +! --------------------------------------------------------------------- +! + subroutine set_global_stencil_buffer & + & (irank_image_file, npe_img_composit, & + & num_pixel_xy, num_pvr_ray_gl, num_ray_start_gl, & + & stencil_wk) +! + use calypso_mpi_int + use transfer_to_long_integers +! + integer(kind = kint), intent(in) :: irank_image_file + integer(kind = kint), intent(in) :: npe_img_composit + integer(kind = kint), intent(in) :: num_pixel_xy + integer(kind = kint_gl), intent(in) :: num_pvr_ray_gl + integer(kind = kint_gl), intent(in) & + & :: num_ray_start_gl(num_pixel_xy) +! + type(stencil_buffer_work), intent(inout) :: stencil_wk +! + integer(kind = kint_gl), allocatable :: istack_ray_start_gl(:) +! + integer(kind = kint) :: icou, ipix, ip, i_rank +! +! + if(my_rank .eq. irank_image_file) then + allocate(istack_ray_start_gl(0:num_pixel_xy)) +! +!$omp parallel workshare + stencil_wk%irank_4_composit(1:num_pixel_xy) = -1 +!$omp end parallel workshare + +!$omp parallel workshare + stencil_wk%istack_recv_image(0:nprocs) = 0 +!$omp end parallel workshare + istack_ray_start_gl(0) = 0 + icou = 0 + do ipix = 1, num_pixel_xy + istack_ray_start_gl(ipix) = istack_ray_start_gl(ipix-1) & + & + num_ray_start_gl(ipix) +! + if(num_ray_start_gl(ipix) .gt. 0) then + icou = icou + 1 + ip = int((istack_ray_start_gl(ipix) - 1) & + & * npe_img_composit / num_pvr_ray_gl + 1) + i_rank = int(mod(irank_image_file+npe_img_composit-ip, & + & nprocs)) + stencil_wk%irank_4_composit(ipix) = i_rank + stencil_wk%istack_recv_image(ip) = icou + stencil_wk%irev_recv_image(ipix) = icou + stencil_wk%item_recv_image(icou) = ipix + end if + end do + do ip = npe_img_composit+1, nprocs + stencil_wk%istack_recv_image(ip) & + & = stencil_wk%istack_recv_image(ip-1) + end do + stencil_wk%ntot_recv_image & + & = stencil_wk%istack_recv_image(nprocs) +! +! write(50+my_rank,*) 'ipix, stencil_wk%irank_4_composit' +! do ipix = 1, num_pixel_xy +! write(50+my_rank,*) ipix, stencil_wk%irank_4_composit(ipix) +! end do +! + deallocate(istack_ray_start_gl) + end if +! + call calypso_mpi_bcast_int & + & (stencil_wk%istack_recv_image, cast_long(nprocs+1), & + & irank_image_file) +! + call calypso_mpi_bcast_int & + & (stencil_wk%irank_4_composit, cast_long(num_pixel_xy), & + & irank_image_file) + call calypso_mpi_bcast_int & + & (stencil_wk%irev_recv_image, cast_long(num_pixel_xy), & + & irank_image_file) +! + call calypso_mpi_bcast_one_int(stencil_wk%ntot_recv_image, & + & irank_image_file) + call calypso_mpi_bcast_int(stencil_wk%item_recv_image(1), & + & cast_long(stencil_wk%ntot_recv_image), irank_image_file) +! + end subroutine set_global_stencil_buffer +! +! --------------------------------------------------------------------- +! + end module t_stencil_buffer_work diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_surf_grp_4_pvr_domain.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_surf_grp_4_pvr_domain.f90 new file mode 100644 index 00000000..3af965e9 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_surf_grp_4_pvr_domain.f90 @@ -0,0 +1,238 @@ +!>@file t_surf_grp_4_pvr_domain.f90 +!! module t_surf_grp_4_pvr_domain +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structures for surface group data for volume rendering +!! +!!@verbatim +!! subroutine alloc_pvr_surf_domain_item(num_surf_in, pvr_bound) +!! subroutine dealloc_pvr_surf_domain_item(pvr_bound) +!! subroutine copy_pvr_surf_domain_item(pvr_bd_org, pvr_bound) +!!@endverbatim +! + module t_surf_grp_4_pvr_domain +! + use m_precision + use m_constants +! + implicit none +! +! + type pvr_domain_outline +!> Center of domain + real(kind = kreal) :: center_g(3) = (/zero,zero,zero/) +!> Maximum distance from center of domain + real(kind = kreal) :: rmax_g = zero +! +!> MAximum and mimimum position of domain +!!@n minimum value: xx_minmax(1,ndir) +!!@n maximum value: xx_minmax(2,ndir) + real(kind = kreal) :: xx_minmax_g(2,3) +!! Range of field data + real(kind = kreal) :: d_minmax_pvr(2) + end type pvr_domain_outline +! + type pvr_bounds_surf_ctl +!> Number of Surface address for surface group + integer(kind = kint) :: num_pvr_surf +!> Surface address for surface group + integer(kind = kint), allocatable :: item_pvr_surf(:,:) +! +!> Average position in screen coordinate + real(kind = kreal), allocatable :: screen_posi(:,:) +!> Average normal vector in screen coordinate + real(kind = kreal), allocatable :: screen_norm(:,:) +!> Average w in screen coordinate + real(kind = kreal), allocatable :: screen_w(:) +! +!> Start and end position in horizontal screen + real(kind = kreal), allocatable :: screen_xrng(:,:) +!> Start and end position in horizontal screen + real(kind = kreal), allocatable :: screen_yrng(:,:) +!> Start and end depth in horizontal screen + real(kind = kreal), allocatable :: screen_zrng(:,:) +!> Start and end pixel in horizontal screen + integer(kind = kint), allocatable :: isurf_xrng(:,:) +!> Start and end pixel in vetical screen + integer(kind = kint), allocatable :: jsurf_yrng(:,:) + end type pvr_bounds_surf_ctl +! +! +! ----------------------------------------------------------------------- +! + contains +! +! ----------------------------------------------------------------------- +! + subroutine alloc_pvr_surf_domain_item(num_surf_in, pvr_bound) +! + integer(kind = kint), intent(in) :: num_surf_in + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +! +! + pvr_bound%num_pvr_surf = num_surf_in +! + allocate(pvr_bound%item_pvr_surf(2,pvr_bound%num_pvr_surf)) + allocate(pvr_bound%screen_norm(3,pvr_bound%num_pvr_surf)) + allocate(pvr_bound%screen_posi(3,pvr_bound%num_pvr_surf)) + allocate(pvr_bound%screen_w(pvr_bound%num_pvr_surf)) +! + allocate(pvr_bound%screen_xrng(2,pvr_bound%num_pvr_surf)) + allocate(pvr_bound%screen_yrng(2,pvr_bound%num_pvr_surf)) + allocate(pvr_bound%screen_zrng(2,pvr_bound%num_pvr_surf)) + allocate(pvr_bound%isurf_xrng(2,pvr_bound%num_pvr_surf)) + allocate(pvr_bound%jsurf_yrng(2,pvr_bound%num_pvr_surf)) +! + if(pvr_bound%num_pvr_surf .le. 0) return + pvr_bound%item_pvr_surf = 0 + pvr_bound%screen_norm = 0.0d0 + pvr_bound%screen_posi = 0.0d0 + pvr_bound%screen_w = 0.0d0 +! + pvr_bound%screen_xrng = 0.0d0 + pvr_bound%screen_yrng = 0.0d0 + pvr_bound%screen_zrng = 0.0d0 + pvr_bound%isurf_xrng = 0 + pvr_bound%jsurf_yrng = 0 +! + end subroutine alloc_pvr_surf_domain_item +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine dealloc_pvr_surf_domain_item(pvr_bound) +! + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +! +! + deallocate(pvr_bound%item_pvr_surf, pvr_bound%screen_w) + deallocate(pvr_bound%screen_posi, pvr_bound%screen_norm) + deallocate(pvr_bound%screen_xrng, pvr_bound%screen_yrng) + deallocate(pvr_bound%screen_zrng) + deallocate(pvr_bound%isurf_xrng, pvr_bound%jsurf_yrng) +! + end subroutine dealloc_pvr_surf_domain_item +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine copy_pvr_surf_domain_item(pvr_bd_org, pvr_bound) +! + type(pvr_bounds_surf_ctl), intent(in) :: pvr_bd_org + type(pvr_bounds_surf_ctl), intent(inout) :: pvr_bound +! +! +!$omp parallel workshare + pvr_bound%item_pvr_surf(:,:) = pvr_bd_org%item_pvr_surf(:,:) + pvr_bound%screen_norm(:,:) = pvr_bd_org%screen_norm(:,:) + pvr_bound%screen_posi(:,:) = pvr_bd_org%screen_posi(:,:) + pvr_bound%screen_w(:) = pvr_bd_org%screen_w(:) +! + pvr_bound%screen_xrng(:,:) = pvr_bd_org%screen_xrng(:,:) + pvr_bound%screen_yrng(:,:) = pvr_bd_org%screen_yrng(:,:) + pvr_bound%screen_zrng(:,:) = pvr_bd_org%screen_zrng(:,:) + pvr_bound%isurf_xrng(:,:) = pvr_bd_org%isurf_xrng(:,:) + pvr_bound%jsurf_yrng(:,:) = pvr_bd_org%jsurf_yrng(:,:) +!$omp end parallel workshare +! + end subroutine copy_pvr_surf_domain_item +! +! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- +! + subroutine check_sf_grp_4_pvr_domain(id_rank, num_pvr, pvr_bound) +! + integer, intent(in) :: id_rank + integer(kind = kint), intent(in) :: num_pvr + type(pvr_bounds_surf_ctl), intent(in) :: pvr_bound(num_pvr) +! + integer(kind = kint) :: i_pvr, num +! +! + do i_pvr = 1, num_pvr + num = pvr_bound(i_pvr)%num_pvr_surf + write(50+id_rank,*) 'num_pvr_surf', & + & i_pvr, pvr_bound(i_pvr)%num_pvr_surf + write(50+id_rank,'(8i16)') & + & pvr_bound(i_pvr)%item_pvr_surf(1,1:num) + write(50+id_rank,'(8i16)') & + & pvr_bound(i_pvr)%item_pvr_surf(2,1:num) + end do +! + end subroutine check_sf_grp_4_pvr_domain +! +! ----------------------------------------------------------------------- +! + subroutine check_sf_posi_pvr_domain(id_rank, num_pvr, pvr_bound) +! + integer, intent(in) :: id_rank + integer(kind = kint), intent(in) :: num_pvr + type(pvr_bounds_surf_ctl), intent(in) :: pvr_bound(num_pvr) +! + integer(kind = kint) :: i_pvr, inum +! +! + do i_pvr = 1, num_pvr + write(50+id_rank,*) 'screen_posi', & + & i_pvr, pvr_bound(i_pvr)%num_pvr_surf + do inum = 1, pvr_bound(i_pvr)%num_pvr_surf + write(50+id_rank,*) inum, & + & pvr_bound(i_pvr)%screen_posi(1:3,inum), & + & pvr_bound(i_pvr)%screen_w(inum) + end do + end do +! + end subroutine check_sf_posi_pvr_domain +! +! ----------------------------------------------------------------------- +! + subroutine check_sf_norm_pvr_domain(id_rank, num_pvr, pvr_bound) +! + integer, intent(in) :: id_rank + integer(kind = kint), intent(in) :: num_pvr + type(pvr_bounds_surf_ctl), intent(in) :: pvr_bound(num_pvr) +! + integer(kind = kint) :: i_pvr, inum +! +! + do i_pvr = 1, num_pvr + write(50+id_rank,*) 'screen_norm', & + & i_pvr, pvr_bound(i_pvr)%num_pvr_surf + do inum = 1, pvr_bound(i_pvr)%num_pvr_surf + write(50+id_rank,*) inum, & + & pvr_bound(i_pvr)%screen_norm(1:3,inum) + end do + end do +! + end subroutine check_sf_norm_pvr_domain +! +! ----------------------------------------------------------------------- +! + subroutine check_surf_rng_pvr_domain(id_rank, num_pvr, pvr_bound) +! + integer, intent(in) :: id_rank + integer(kind = kint), intent(in) :: num_pvr + type(pvr_bounds_surf_ctl), intent(in) :: pvr_bound(num_pvr) +! + integer(kind = kint) :: i_pvr, inum +! +! + do i_pvr = 1, num_pvr + write(50+id_rank,*) 'isurf_xrng', & + & i_pvr, pvr_bound(i_pvr)%num_pvr_surf + do inum = 1, pvr_bound(i_pvr)%num_pvr_surf + write(50+id_rank,'(i16,4i5,1p4e16.7)') & + & inum, pvr_bound(i_pvr)%isurf_xrng(1:2,inum), & + & pvr_bound(i_pvr)%jsurf_yrng(1:2,inum), & + & pvr_bound(i_pvr)%screen_xrng(1:2,inum), & + & pvr_bound(i_pvr)%screen_yrng(1:2,inum) + end do + end do +! + end subroutine check_surf_rng_pvr_domain +! +! ----------------------------------------------------------------------- +! + end module t_surf_grp_4_pvr_domain diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/t_volume_rendering.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/t_volume_rendering.f90 new file mode 100644 index 00000000..bde07c8d --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/t_volume_rendering.f90 @@ -0,0 +1,328 @@ +!>@file t_volume_rendering.f90 +!!@brief module t_volume_rendering +!! +!!@date Programmed by H.Matsui in May. 2006 +! +!>@brief Main routines for volume renderings +!! +!!@verbatim +!! subroutine set_from_PVR_control(geofem, nod_fld, tracer, fline, & +!! & pvr_ctls, pvr) +!! type(mesh_data), intent(in) :: geofem +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(volume_rendering_controls), intent(inout) :: pvr_ctls +!! type(volume_rendering_module), intent(inout) :: pvr +!! subroutine check_PVR_update & +!! & (id_control, pvr_ctls, pvr, iflag_redraw) +!! subroutine read_ctl_pvr_files_4_update(id_control, & +!! & pvr_ctls, iflag_failed) +!! subroutine alloc_pvr_data(pvr) +!! +!! subroutine dealloc_pvr_data(pvr) +!! subroutine alloc_pvr_images(pvr) +!! subroutine dealloc_pvr_and_lic_data(pvr) +!! type(mesh_data), intent(in) :: geofem +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(phys_data), intent(in) :: nod_fld +!! type(jacobians_type), intent(in) :: jacs +!! type(volume_rendering_controls), intent(inout) :: pvr_ctls +!! type(volume_rendering_module), intent(inout) :: pvr +!!@endverbatim +! + module t_volume_rendering +! + use m_precision + use calypso_mpi +! + use m_constants + use m_machine_parameter + use m_geometry_constants + use m_work_time +! + use t_mesh_data + use t_phys_data + use t_jacobians +! + use t_surf_grp_list_each_surf + use t_rendering_vr_image + use t_control_params_4_pvr + use t_surf_grp_4_pvr_domain + use t_pvr_ray_startpoints + use t_pvr_image_array + use t_pvr_field_data + use t_geometries_in_pvr_screen + use t_control_data_pvrs + use t_sort_PVRs_by_type +! + use each_volume_rendering +! + implicit none +! +! + integer(kind = kint), parameter :: IFLAG_THROUGH = 1 + integer(kind = kint), parameter :: IFLAG_DRAW = 0 + integer(kind = kint), parameter :: IFLAG_TERMINATE = -1 +! +! + type volume_rendering_module +!> Character flag to update volume rendering + character(len=kchara) :: cflag_update +! +!> Structure of surface group list for each surface + type(sf_grp_list_each_surf) :: sf_grp_4_sf +! +!> Number of volume rendering + integer(kind = kint) :: num_pvr = 0 +!> Structure of PVR control parameters + type(PVR_control_params), allocatable :: pvr_param(:) +!> Structure of field for PVRs + type(pvr_field_data), allocatable :: field_pvr(:) +!> Domain boundary information + type(pvr_bounds_surf_ctl), allocatable :: pvr_bound(:) +! +!> Number of image files for volume rendering + integer(kind = kint) :: num_pvr_images = 0 +!> Structure for projection data + type(PVR_projection_data), allocatable :: pvr_proj(:) +!> Structure for PVR images + type(pvr_image_type), allocatable :: pvr_rgb(:) +! +!> Structure for PVR images + type(sort_PVRs_by_type) :: PVR_sort + end type volume_rendering_module +! + character(len=kchara), parameter & + & :: hd_pvr_ctl = 'volume_rendering' + private :: hd_pvr_ctl +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine set_from_PVR_control(geofem, nod_fld, tracer, fline, & + & pvr_ctls, pvr) +! + use t_particle_trace + use t_fieldline + use t_control_data_pvr_sections + use set_pvr_control + use rendering_and_image_nums +! + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(volume_rendering_controls), intent(inout) :: pvr_ctls + type(volume_rendering_module), intent(inout) :: pvr +! + integer(kind = kint) :: i_ctl, i_pvr +! +! + call alloc_pvr_data(pvr) + call s_sort_PVRs_by_type(pvr%num_pvr, pvr_ctls%pvr_ctl_type, & + & pvr%PVR_sort) +! + if(iflag_debug .gt. 0) then + do i_pvr = 0, 6 + write(*,*) i_pvr, 'pvr%istack_PVR_modes', & + & pvr%PVR_sort%istack_PVR_modes(i_pvr) + end do + do i_pvr = 1, pvr%num_pvr + write(*,*) i_pvr, trim(pvr_ctls%fname_pvr_ctl(i_pvr)), ' ', & + & yes_flag(pvr_ctls%pvr_ctl_type(i_pvr)%anaglyph_ctl%charavalue),& + & ' ', pvr_ctls%pvr_ctl_type(i_pvr)%movie%movie_mode_ctl%iflag, & + & yes_flag(pvr_ctls%pvr_ctl_type(i_pvr)%quilt_ctl%charavalue), & + & ' ', pvr%PVR_sort%ipvr_sorted(i_pvr) + end do + end if +! + do i_pvr = 1, pvr%num_pvr + call alloc_nod_data_4_pvr & + & (geofem%mesh%node%numnod, geofem%mesh%ele%numele, & + & pvr%field_pvr(i_pvr)) + call alloc_iflag_pvr_boundaries(geofem%group%surf_grp, & + & pvr%pvr_param(i_pvr)%draw_param) + end do +! + do i_ctl = 1, pvr%num_pvr + i_pvr = pvr%PVR_sort%ipvr_sorted(i_ctl) + call s_set_pvr_controls(geofem%group, nod_fld, tracer, fline, & + & pvr_ctls%pvr_ctl_type(i_ctl), pvr%pvr_param(i_pvr)) + end do +! + call count_num_rendering_and_images(pvr%num_pvr, pvr%pvr_param, & + & pvr%num_pvr_images, pvr%PVR_sort%istack_pvr_images) + call alloc_pvr_images(pvr) +! + call set_rendering_and_image_pes & + & (nprocs, pvr%num_pvr, pvr_ctls%pvr_ctl_type, pvr%PVR_sort, & + & pvr%num_pvr_images, pvr%pvr_rgb) + call dealloc_sort_PVRs_list(pvr%PVR_sort) +! + end subroutine set_from_PVR_control +! +! --------------------------------------------------------------------- +! + subroutine check_PVR_update & + & (id_control, pvr_ctls, pvr, iflag_redraw) +! + use calypso_mpi_int + use bcast_control_data_4_pvr + use ctl_file_each_pvr_IO + use skip_comment_f +! + integer(kind = kint), intent(in) :: id_control + type(volume_rendering_controls), intent(inout) :: pvr_ctls + type(volume_rendering_module), intent(inout) :: pvr + integer(kind = kint), intent(inout) :: iflag_redraw +! + character(len = kchara) :: tmpchara +! +! + if(my_rank .eq. izero) then + call read_control_pvr_update & + & (id_control, pvr_ctls%fname_pvr_ctl(1), & + & hd_pvr_ctl, pvr_ctls%pvr_ctl_type(1)) +! + iflag_redraw = IFLAG_THROUGH + if(pvr_ctls%pvr_ctl_type(1)%updated_ctl%iflag .gt. 0) then + tmpchara = pvr_ctls%pvr_ctl_type(1)%updated_ctl%charavalue + if(cmp_no_case(tmpchara, 'end')) then + iflag_redraw = IFLAG_TERMINATE + else if(pvr%cflag_update .ne. tmpchara) then + iflag_redraw = IFLAG_DRAW + pvr%cflag_update = tmpchara + end if + end if + call reset_pvr_update_flags(pvr_ctls%pvr_ctl_type(1)) + end if +! + call bcast_pvr_update_flag(pvr_ctls%pvr_ctl_type(1)) + if(pvr_ctls%pvr_ctl_type(1)%i_pvr_ctl .lt. 0) then + call calypso_MPI_abort(pvr_ctls%pvr_ctl_type(1)%i_pvr_ctl, & + & 'control file is broken') + end if +! + call calypso_mpi_bcast_one_int(iflag_redraw, 0) + call calypso_mpi_barrier +! + end subroutine check_PVR_update +! +! --------------------------------------------------------------------- +! + subroutine read_ctl_pvr_files_4_update(id_control, & + & pvr_ctls, iflag_failed) +! + use t_read_control_elements + use skip_comment_f + use ctl_file_each_pvr_IO +! + integer(kind = kint), intent(in) :: id_control + type(volume_rendering_controls), intent(inout) :: pvr_ctls + integer(kind = kint), intent(inout) :: iflag_failed +! + integer(kind = kint) :: i_pvr + type(buffer_for_control) :: c_buf1 +! +! + iflag_failed = 0 + if(my_rank .ne. 0) return + c_buf1%level = 0 + do i_pvr = 1, pvr_ctls%num_pvr_ctl + if(.not. no_file_flag(pvr_ctls%fname_pvr_ctl(i_pvr))) then + call read_control_pvr_file & + & (id_control, pvr_ctls%fname_pvr_ctl(i_pvr), hd_pvr_ctl, & + & pvr_ctls%pvr_ctl_type(i_pvr), c_buf1) + iflag_failed = pvr_ctls%pvr_ctl_type(i_pvr)%i_pvr_ctl + end if + end do +! + end subroutine read_ctl_pvr_files_4_update +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_data(pvr) +! + type(volume_rendering_module), intent(inout) :: pvr +! +! + allocate(pvr%pvr_param(pvr%num_pvr)) + allocate(pvr%field_pvr(pvr%num_pvr)) + allocate(pvr%pvr_bound(pvr%num_pvr)) +! + call alloc_sort_PVRs_by_type(pvr%num_pvr, pvr%PVR_sort) +! + end subroutine alloc_pvr_data +! +! --------------------------------------------------------------------- +! + subroutine alloc_pvr_images(pvr) +! + type(volume_rendering_module), intent(inout) :: pvr +! +! + allocate(pvr%pvr_proj(pvr%num_pvr_images)) + allocate(pvr%pvr_rgb(pvr%num_pvr_images)) +! + end subroutine alloc_pvr_images +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_data(pvr) +! + type(volume_rendering_module), intent(inout) :: pvr + integer(kind = kint) :: i_pvr +! +! + if(pvr%num_pvr.le.0) return + do i_pvr = 1, pvr%num_pvr + call dealloc_nod_data_4_pvr(pvr%field_pvr(i_pvr)) + end do + call dealloc_pvr_and_lic_data(pvr) +! + end subroutine dealloc_pvr_data +! +! --------------------------------------------------------------------- +! + subroutine dealloc_pvr_and_lic_data(pvr) +! + use set_pvr_control +! + type(volume_rendering_module), intent(inout) :: pvr + integer(kind = kint) :: i_pvr +! +! + call dealloc_sort_PVRs_list(pvr%PVR_sort) +! + do i_pvr = 1, pvr%num_pvr + call dealloc_iflag_pvr_boundaries & + & (pvr%pvr_param(i_pvr)%draw_param) + call dealloc_iflag_pvr_boundaries & + & (pvr%pvr_param(i_pvr)%draw_param) + call dealloc_iflag_pvr_used_ele & + & (pvr%pvr_param(i_pvr)%draw_param) + call dealloc_pvr_surf_domain_item(pvr%pvr_bound(i_pvr)) + end do + deallocate(pvr%pvr_bound, pvr%pvr_param) +! + call dealloc_num_sf_grp_each_surf(pvr%sf_grp_4_sf) +! +! + do i_pvr = 1, pvr%num_pvr_images + call dealloc_pvr_image_array(pvr%pvr_rgb(i_pvr)) + call flush_rendering_4_fixed_view(pvr%pvr_proj(i_pvr)) + end do + deallocate(pvr%pvr_rgb, pvr%pvr_proj) +! + end subroutine dealloc_pvr_and_lic_data +! +! --------------------------------------------------------------------- +! + end module t_volume_rendering diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/viz4_step_ctls_to_time_ctl.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/viz4_step_ctls_to_time_ctl.f90 new file mode 100644 index 00000000..db612d29 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/viz4_step_ctls_to_time_ctl.f90 @@ -0,0 +1,97 @@ +!>@file viz4_step_ctls_to_time_ctl.f90 +!!@brief module viz4_step_ctls_to_time_ctl +!! +!!@author H. Matsui +!!@date Programmed in July, 2020 +! +!> @brief Copy time stepin visualization control to time step control +!! +!!@verbatim +!! subroutine s_viz4_step_ctls_to_time_ctl(viz_ctls, tctl) +!! type(vis4_controls), intent(in) :: viz_ctls +!! type(time_data_control), intent(inout) :: tctl +!!@endverbatim +! + module viz4_step_ctls_to_time_ctl +! + use m_precision + use m_constants +! + use t_control_data_viz4 + use t_ctl_data_4_time_steps +! + implicit none +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_viz4_step_ctls_to_time_ctl(viz_ctls, tctl) +! + use t_control_array_real + use t_control_array_character + use t_control_array_integer +! + type(vis4_controls), intent(in) :: viz_ctls + type(time_data_control), intent(inout) :: tctl +! +! + if(viz_ctls%i_step_psf_v_ctl%iflag .gt. 0) then + call copy_integer_ctl & + & (viz_ctls%i_step_psf_v_ctl, tctl%i_step_psf_ctl) + end if + if(viz_ctls%i_step_iso_v_ctl%iflag .gt. 0) then + call copy_integer_ctl & + & (viz_ctls%i_step_iso_v_ctl, tctl%i_step_iso_ctl) + end if + if(viz_ctls%i_step_map_v_ctl%iflag .gt. 0) then + call copy_integer_ctl & + & (viz_ctls%i_step_map_v_ctl, tctl%i_step_map_ctl) + end if +! + if(viz_ctls%i_step_pvr_v_ctl%iflag .gt. 0) then + call copy_integer_ctl & + & (viz_ctls%i_step_pvr_v_ctl, tctl%i_step_pvr_ctl) + end if + if(viz_ctls%i_step_fline_v_ctl%iflag .gt. 0) then + call copy_integer_ctl & + & (viz_ctls%i_step_fline_v_ctl, tctl%i_step_fline_ctl) + end if + if(viz_ctls%i_step_ucd_v_ctl%iflag .gt. 0) then + call copy_integer_ctl & + & (viz_ctls%i_step_ucd_v_ctl, tctl%i_step_ucd_ctl) + end if +! + if(viz_ctls%delta_t_psf_v_ctl%iflag .gt. 0) then + call copy_real_ctl & + & (viz_ctls%delta_t_psf_v_ctl, tctl%delta_t_psf_ctl) + end if + if(viz_ctls%delta_t_iso_v_ctl%iflag .gt. 0) then + call copy_real_ctl & + & (viz_ctls%delta_t_iso_v_ctl, tctl%delta_t_iso_ctl) + end if + if(viz_ctls%delta_t_map_v_ctl%iflag .gt. 0) then + call copy_real_ctl & + & (viz_ctls%delta_t_map_v_ctl, tctl%delta_t_map_ctl) + end if +! + if(viz_ctls%delta_t_pvr_v_ctl%iflag .gt. 0) then + call copy_real_ctl & + & (viz_ctls%delta_t_pvr_v_ctl, tctl%delta_t_pvr_ctl) + end if + if(viz_ctls%delta_t_fline_v_ctl%iflag .gt. 0) then + call copy_real_ctl & + & (viz_ctls%delta_t_fline_v_ctl, tctl%delta_t_fline_ctl) + end if + if(viz_ctls%delta_t_ucd_v_ctl%iflag .gt. 0) then + call copy_real_ctl & + & (viz_ctls%delta_t_ucd_v_ctl, tctl%delta_t_field_ctl) + end if +! + end subroutine s_viz4_step_ctls_to_time_ctl +! +! --------------------------------------------------------------------- +! + end module viz4_step_ctls_to_time_ctl diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/volume_rendering.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/volume_rendering.f90 new file mode 100644 index 00000000..0118b6f6 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/volume_rendering.f90 @@ -0,0 +1,221 @@ +!>@file volume_rendering.f90 +!!@brief module volume_rendering +!! +!!@date Programmed by H.Matsui in May. 2006 +!! Modified by H.Matsui in May, 2021 +! +!>@brief Main routines for volume renderings +!! +!!@verbatim +!! subroutine PVR_initialize(increment_pvr, elps_PVR, & +!! & geofem, nod_fld, tracer, fline, pvr_ctls, pvr, m_SR) +!! subroutine PVR_visualize(istep_pvr, time, elps_PVR, & +!! & geofem, jacs, nod_fld, tracer, fline, pvr, m_SR) +!! type(elapsed_lables), intent(in) :: elps_PVR +!! type(mesh_data), intent(in) :: geofem +!! type(node_data), intent(in) :: node +!! type(element_data), intent(in) :: ele +!! type(surface_data), intent(in) :: surf +!! type(phys_data), intent(in) :: nod_fld +!! type(tracer_module), intent(in) :: tracer +!! type(fieldline_module), intent(in) :: fline +!! type(jacobians_type), intent(in) :: jacs +!! type(volume_rendering_controls), intent(inout) :: pvr_ctls +!! type(volume_rendering_module), intent(inout) :: pvr +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module volume_rendering +! + use m_precision + use calypso_mpi +! + use m_constants + use m_machine_parameter + use m_geometry_constants + use m_work_time +! + use t_mesh_data + use t_phys_data + use t_jacobians +! + use t_volume_rendering + use t_surf_grp_list_each_surf + use t_rendering_vr_image + use t_control_params_4_pvr + use t_surf_grp_4_pvr_domain + use t_pvr_ray_startpoints + use t_pvr_image_array + use t_pvr_field_data + use t_geometries_in_pvr_screen + use t_control_data_pvrs + use t_particle_trace + use t_fieldline + use t_mesh_SR +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine PVR_initialize(increment_pvr, elps_PVR, & + & geofem, nod_fld, tracer, fline, pvr_ctls, pvr, m_SR) +! + use m_work_time + use t_control_data_pvr_sections + use set_pvr_control + use multi_volume_renderings + use anaglyph_volume_renderings +! + integer(kind = kint), intent(in) :: increment_pvr + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline +! + type(volume_rendering_controls), intent(inout) :: pvr_ctls + type(volume_rendering_module), intent(inout) :: pvr + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: i_pvr, ist_img, num_img +! +! + pvr%num_pvr = pvr_ctls%num_pvr_ctl + if(increment_pvr .le. 0) pvr%num_pvr = 0 +! + if(pvr%num_pvr .le. 0) then + pvr%num_pvr = 0 + return + end if +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+5) + call bcast_pvr_controls(pvr%num_pvr, & + & pvr_ctls%pvr_ctl_type, pvr%cflag_update) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+5) +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+6) + call set_from_PVR_control(geofem, nod_fld, tracer, fline, & + & pvr_ctls, pvr) +! + call dealloc_pvr_ctl_struct(pvr_ctls) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+6) +! do i_pvr = 1, pvr_ctls%num_pvr_ctl +! if((no_file_flag(pvr_ctls%fname_pvr_ctl(i_pvr)) .eqv. .FALSE.) & +! & .or. my_rank .ne. 0) then +! call deallocate_cont_dat_pvr(pvr_ctls%pvr_ctl_type(i_pvr)) +! end if +! end do +! +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+7) + call init_sf_grp_list_each_surf & + & (geofem%mesh%surf, geofem%group%surf_grp, pvr%sf_grp_4_sf) + do i_pvr = 1, pvr%num_pvr + ist_img = pvr%PVR_sort%istack_pvr_images(i_pvr-1) + num_img = pvr%PVR_sort%istack_pvr_images(i_pvr ) - ist_img + call init_each_PVR_image(num_img, pvr%pvr_param(i_pvr), & + & pvr%pvr_rgb(ist_img+1)) + call each_PVR_initialize(geofem%mesh, geofem%group, & + & pvr%pvr_param(i_pvr), pvr%pvr_bound(i_pvr)) + end do +! +! + call set_PVR_view_and_images(pvr%num_pvr, pvr%num_pvr_images, & + & elps_PVR, geofem%mesh, pvr%PVR_sort, pvr%pvr_rgb, & + & pvr%pvr_param, pvr%pvr_bound, pvr%pvr_proj, m_SR) + call PVR_anaglyph_view_and_images & + & (pvr%num_pvr, pvr%num_pvr_images, elps_PVR, geofem%mesh, & + & pvr%PVR_sort, pvr%pvr_rgb, pvr%pvr_param, & + & pvr%pvr_bound, pvr%pvr_proj, m_SR) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+7) +! +! call check_surf_rng_pvr_domain(my_rank) +! call check_surf_norm_pvr_domain(my_rank) +! + end subroutine PVR_initialize +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine PVR_visualize(istep_pvr, time, elps_PVR, & + & geofem, jacs, nod_fld, tracer, fline, pvr, m_SR) +! + use cal_pvr_modelview_mat + use multi_volume_renderings + use anaglyph_volume_renderings + use write_multi_PVR_image +! + integer(kind = kint), intent(in) :: istep_pvr + real(kind = kreal), intent(in) :: time + type(elapsed_lables), intent(in) :: elps_PVR + type(mesh_data), intent(in) :: geofem + type(phys_data), intent(in) :: nod_fld + type(tracer_module), intent(in) :: tracer + type(fieldline_module), intent(in) :: fline + type(jacobians_type), intent(in) :: jacs +! + type(volume_rendering_module), intent(inout) :: pvr + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: ist_pvr, ied_pvr +! +! + if(pvr%num_pvr.le.0 .or. istep_pvr.le.0) return +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+1) + call PVR_fixview_rendering(istep_pvr, time, elps_PVR, & + & geofem, jacs, nod_fld, tracer, fline, pvr, m_SR) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+1) +! + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+2) + ist_pvr = pvr%PVR_sort%istack_PVR_modes(0) + 1 + ied_pvr = pvr%PVR_sort%istack_PVR_modes(1) + call output_PVR_images(istep_pvr, pvr%num_pvr, ist_pvr, ied_pvr, & + & pvr%num_pvr_images, pvr%PVR_sort%istack_pvr_images, & + & pvr%pvr_rgb) +! + ist_pvr = pvr%PVR_sort%istack_PVR_modes(1) + 1 + ied_pvr = pvr%PVR_sort%istack_PVR_modes(2) + call output_quilt_PVR_images & + & (istep_pvr, pvr%num_pvr, ist_pvr, ied_pvr, & + & pvr%num_pvr_images, pvr%PVR_sort%istack_pvr_images, & + & pvr%pvr_param, pvr%pvr_rgb) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+2) +! +! generate snapshot movie images + if(elps_PVR%flag_elapsed) & + & call start_elapsed_time(elps_PVR%ist_elapsed+1) + call PVR_movie_visualize(istep_pvr, time, elps_PVR, geofem, & + & jacs, nod_fld, tracer, fline, pvr, m_SR) +! +! generate snapshot quilt movie images + call PVR_quilt_movie_visualize(istep_pvr, time, elps_PVR, & + & geofem, jacs, nod_fld, tracer, fline, pvr, m_SR) +! + call PVR_anaglyph_rendering(istep_pvr, time, elps_PVR, & + & geofem, jacs, nod_fld, tracer, fline, pvr, m_SR) + call PVR_movie_anaglyph_visualize(istep_pvr, time, elps_PVR, & + & geofem, jacs, nod_fld, & + & tracer, fline, pvr, m_SR) + if(elps_PVR%flag_elapsed) & + & call end_elapsed_time(elps_PVR%ist_elapsed+1) +! + end subroutine PVR_visualize +! +! --------------------------------------------------------------------- +! + end module volume_rendering diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/write_PVR_image.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/write_PVR_image.f90 new file mode 100644 index 00000000..ceb6bb92 --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/write_PVR_image.f90 @@ -0,0 +1,219 @@ +!>@file write_PVR_image.f90 +!! module write_PVR_image +!! +!!@author H. Matsui +!!@date Programmed in Aug., 2011 +! +!> @brief Structures for position in the projection coordinate +!! +!!@verbatim +!! subroutine sel_write_pvr_image_file(istep_pvr, i_rot, pvr_rgb) +!! subroutine sel_write_pvr_local_img(index, istep_pvr, pvr_rgb) +!! type(pvr_image_type), intent(inout) :: pvr_rgb +!! +!! subroutine set_output_rot_sequence_image(istep_pvr, i_rot, & +!! & iflag_img_fmt, file_prefix, num_img, n_column_row, & +!! & rot_rgb) +!! integer(kind = kint), intent(in) :: istep_pvr, i_rot +!! integer(kind = kint), intent(in) :: num_img +!! integer(kind = kint), intent(in) :: n_column_row(2) +!! integer(kind = kint), intent(in) :: iflag_img_fmt +!! character(len=kchara), intent(in) :: file_prefix +!! type(pvr_image_type), intent(in) :: rot_rgb(num_img) +!!@endverbatim +! + module write_PVR_image +! + use m_precision + use m_work_time +! + use calypso_mpi + use m_constants + use m_machine_parameter +! + use t_MPI_quilt_bitmap_IO +! + implicit none +! + type(MPI_quilt_bitmap_IO), private, save :: quilt_d +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine sel_write_pvr_image_file(istep_pvr, i_rot, pvr_rgb) +! + use t_pvr_image_array + use t_control_params_4_pvr + use output_image_sel_4_png + use set_parallel_file_name + use convert_real_rgb_2_bite +! + integer(kind = kint), intent(in) :: istep_pvr, i_rot + type(pvr_image_type), intent(inout) :: pvr_rgb +! + character(len=kchara) :: file_prefix_w_index, fname_tmp +! +! + if(my_rank .ne. pvr_rgb%irank_image_file) return +! + call cvt_double_rgba_to_char_rgb(pvr_rgb%num_pixel_xy, & + & pvr_rgb%rgba_real_gl, pvr_rgb%rgb_chara_gl) +! + fname_tmp = add_int_suffix(istep_pvr, pvr_rgb%pvr_prefix) + if(i_rot .ge. 0) then + file_prefix_w_index = add_int_suffix(i_rot, fname_tmp) + else + file_prefix_w_index = fname_tmp + end if +! + write(*,*) trim(file_prefix_w_index), & + & ' is written from process ', my_rank + call sel_output_image_file & + & (pvr_rgb%id_pvr_file_type, file_prefix_w_index, & + & pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & pvr_rgb%rgb_chara_gl) + if(pvr_rgb%iflag_monitoring .gt. 0) then + call sel_output_image_file & + & (pvr_rgb%id_pvr_file_type, pvr_rgb%pvr_prefix, & + & pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & pvr_rgb%rgb_chara_gl) + end if +! + end subroutine sel_write_pvr_image_file +! +! --------------------------------------------------------------------- +! + subroutine sel_write_pvr_local_img(index, istep_pvr, pvr_rgb) +! + use t_pvr_image_array + use t_control_params_4_pvr + use output_image_sel_4_png + use set_parallel_file_name + use convert_real_rgb_2_bite +! + integer(kind = kint), intent(in) :: index, istep_pvr + type(pvr_image_type), intent(inout) :: pvr_rgb +! +!> Local real image data + real(kind = kreal), allocatable :: rgba_real_lc(:,:) +!> RGB byte image data + character(len = 1), allocatable :: rgb_chara_lc(:,:) +! + character(len=kchara) :: tmpchara, img_head +! +! + if(istep_pvr .ge. 0) then + tmpchara = add_int_suffix(istep_pvr, pvr_rgb%pvr_prefix) + else + tmpchara = pvr_rgb%pvr_prefix + end if + img_head = add_int_suffix(index, tmpchara) +! + allocate(rgb_chara_lc(3,pvr_rgb%num_pixel_xy)) + allocate(rgba_real_lc(4,pvr_rgb%num_pixel_xy)) +! +!$omp parallel workshare + rgba_real_lc = 0.0d0 +!$omp end parallel workshare +! + call cvt_double_rgba_to_char_rgb(pvr_rgb%num_pixel_xy, & + & rgba_real_lc, rgb_chara_lc) +! + call sel_output_image_file(pvr_rgb%id_pvr_file_type, & + & img_head, pvr_rgb%num_pixels(1), pvr_rgb%num_pixels(2), & + & rgb_chara_lc) + deallocate(rgba_real_lc, rgb_chara_lc) +! + end subroutine sel_write_pvr_local_img +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine set_output_rot_sequence_image(istep_pvr, i_rot, & + & iflag_img_fmt, file_prefix, num_img, n_column_row, & + & rot_rgb) +! + use t_control_params_4_pvr + use t_pvr_image_array + use t_MPI_quilt_bitmap_IO + use convert_real_rgb_2_bite + use set_parallel_file_name + use output_image_sel_4_png + use mpi_write_quilt_BMP_file +! + integer(kind = kint), intent(in) :: istep_pvr, i_rot + integer(kind = kint), intent(in) :: num_img + integer(kind = kint), intent(in) :: n_column_row(2) + integer(kind = kint), intent(in) :: iflag_img_fmt + character(len=kchara), intent(in) :: file_prefix + type(pvr_image_type), intent(in) :: rot_rgb(num_img) +! + integer(kind = kint) :: i_img, icou + character(len=kchara) :: file_tmp, file_tmp2 +! +! + quilt_d%n_image = num_img + quilt_d%n_column_row(1:2) = n_column_row(1:2) +! + icou = 0 + do i_img = 1, num_img + if(my_rank .eq. rot_rgb(i_img)%irank_image_file) icou = icou+1 + end do + quilt_d%num_image_lc = icou +! + if(iflag_img_fmt .eq. iflag_QUILT_BMP & + & .or. iflag_img_fmt .eq. iflag_QUILT_BMP_GZ) then + write(file_tmp2,'(2a)') trim(file_prefix), '_qs' + file_tmp = append_index(quilt_d%n_column_row(1), file_tmp2) + write(file_tmp2,'(a,a1)') trim(file_tmp), 'x' + file_tmp = append_index(quilt_d%n_column_row(2), file_tmp2) + else + file_tmp = file_prefix + end if +! + if(istep_pvr .ge. 0) then + file_tmp2 = add_int_suffix(istep_pvr, file_tmp) + else + file_tmp2 = file_tmp + end if + if(i_rot .ge. 0) then + quilt_d%image_seq_prefix = add_int_suffix(i_rot, file_tmp2) + else + quilt_d%image_seq_prefix = file_tmp2 + end if +! + quilt_d%image_seq_format = iflag_img_fmt + quilt_d%npixel_xy(1:2) = rot_rgb(1)%num_pixels(1:2) + call alloc_quilt_rgb_images(quilt_d) +! + do icou = 1, quilt_d%num_image_lc + quilt_d%images(icou)%image_format = quilt_d%image_seq_format + call alloc_each_rgb_image & + & (quilt_d%npixel_xy, quilt_d%images(icou)) + end do +! +! + icou = 0 + do i_img = 1, num_img + if(my_rank .eq. rot_rgb(i_img)%irank_image_file) then + icou = icou + 1 + quilt_d%icou_each_pe(icou) = i_img + quilt_d%images(icou)%each_prefix & + & = add_int_suffix(i_img, quilt_d%image_seq_prefix) + call cvt_double_rgba_to_char_rgb & + & (rot_rgb(i_img)%num_pixel_xy, rot_rgb(i_img)%rgba_real_gl, & + & quilt_d%images(icou)%rgb(1,1,1)) + end if + end do +! + call sel_write_pvr_image_files(quilt_d) + call dealloc_quilt_rgb_images(quilt_d) +! + end subroutine set_output_rot_sequence_image +! +! --------------------------------------------------------------------- +! + end module write_PVR_image diff --git a/src/Fortran_libraries/VIZ_src/volume_rendering/write_multi_PVR_image.f90 b/src/Fortran_libraries/VIZ_src/volume_rendering/write_multi_PVR_image.f90 new file mode 100644 index 00000000..aa72d33e --- /dev/null +++ b/src/Fortran_libraries/VIZ_src/volume_rendering/write_multi_PVR_image.f90 @@ -0,0 +1,129 @@ +!>@file write_multi_PVR_image.f90 +!!@brief module write_multi_PVR_image +!! +!!@date Programmed by H.Matsui in May. 2006 +!! Modified by H.Matsui in May, 2021 +! +!>@brief Main routines for volume renderings +!! +!!@verbatim +!! subroutine output_quilt_PVR_images & +!! & (istep_pvr, num_pvr, ist_pvr, ied_pvr, & +!! & num_pvr_images, istack_pvr_images, pvr_param, pvr_rgb) +!! subroutine output_PVR_images & +!! & (istep_pvr, num_pvr, ist_pvr, ied_pvr, & +!! & num_pvr_images, istack_pvr_images, pvr_rgb) +!! subroutine output_rotation_PVR_images(istep_pvr, & +!! & num_frame, pvr_rgb) +!! integer(kind = kint), intent(in) :: istep_pvr +!! integer(kind = kint), intent(in) :: num_pvr, num_pvr_images +!! integer(kind = kint), intent(in) :: ist_pvr, ied_pvr +!! integer(kind = kint), intent(in) & +!! & :: istack_pvr_images(0:num_pvr) +!! type(PVR_control_params), intent(in) :: pvr_param(num_pvr) +!! type(pvr_image_type), intent(inout) :: pvr_rgb(num_pvr_images) +!!@endverbatim +! + module write_multi_PVR_image +! + use m_precision + use calypso_mpi +! + use m_constants + use m_machine_parameter + use m_geometry_constants +! + use t_pvr_image_array + use t_rendering_vr_image +! + implicit none +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine output_quilt_PVR_images & + & (istep_pvr, num_pvr, ist_pvr, ied_pvr, & + & num_pvr_images, istack_pvr_images, pvr_param, pvr_rgb) +! + use write_PVR_image +! + integer(kind = kint), intent(in) :: istep_pvr + integer(kind = kint), intent(in) :: num_pvr, num_pvr_images + integer(kind = kint), intent(in) :: ist_pvr, ied_pvr + integer(kind = kint), intent(in) & + & :: istack_pvr_images(0:num_pvr) +! + type(PVR_control_params), intent(in) :: pvr_param(num_pvr) + type(pvr_image_type), intent(inout) :: pvr_rgb(num_pvr_images) +! + integer(kind = kint) :: i_pvr, ist_img, num_img +! +! + do i_pvr = ist_pvr, ied_pvr + ist_img = istack_pvr_images(i_pvr-1) + num_img = istack_pvr_images(i_pvr ) - ist_img + call set_output_rot_sequence_image(istep_pvr, -1, & + & pvr_rgb(ist_img+1)%id_pvr_file_type, & + & pvr_rgb(ist_img+1)%pvr_prefix, num_img, & + & pvr_param(i_pvr)%stereo_def%n_column_row_view, & + & pvr_rgb(ist_img+1)) + end do +! + end subroutine output_quilt_PVR_images +! +! --------------------------------------------------------------------- +! --------------------------------------------------------------------- +! + subroutine output_PVR_images & + & (istep_pvr, num_pvr, ist_pvr, ied_pvr, & + & num_pvr_images, istack_pvr_images, pvr_rgb) +! + use write_PVR_image +! + integer(kind = kint), intent(in) :: istep_pvr + integer(kind = kint), intent(in) :: num_pvr, num_pvr_images + integer(kind = kint), intent(in) :: ist_pvr, ied_pvr + integer(kind = kint), intent(in) & + & :: istack_pvr_images(0:num_pvr) +! + type(pvr_image_type), intent(inout) :: pvr_rgb(num_pvr_images) +! + integer(kind = kint) :: i_pvr, i_img, ist_img, num_img +! +! + do i_pvr = ist_pvr, ied_pvr + ist_img = istack_pvr_images(i_pvr-1) + num_img = istack_pvr_images(i_pvr ) - ist_img + do i_img = 1, num_img + call sel_write_pvr_image_file(istep_pvr, -1, & + & pvr_rgb(i_img+ist_img)) + end do + end do +! + end subroutine output_PVR_images +! +! --------------------------------------------------------------------- +! + subroutine output_rotation_PVR_images(istep_pvr, & + & num_frame, pvr_rgb) +! + use write_PVR_image +! + integer(kind = kint), intent(in) :: istep_pvr, num_frame + type(pvr_image_type), intent(inout) :: pvr_rgb(num_frame) +! + integer(kind = kint) :: i_rot +! +! + do i_rot = 1, num_frame + call sel_write_pvr_image_file(istep_pvr, i_rot, pvr_rgb(i_rot)) + end do +! + end subroutine output_rotation_PVR_images +! +! --------------------------------------------------------------------- +! + end module write_multi_PVR_image diff --git a/src/Makefile b/src/Makefile index cbff2374..291fb3bc 100644 --- a/src/Makefile +++ b/src/Makefile @@ -40,6 +40,11 @@ C_INCLUDE = -I. CPP_FLAGS = +ifdef PNG_LIBS + CPP_FLAGS += -DPNG_OUTPUT + C_INCLUDE+= $$(PNG_CFLAGS) + F90LIBS+= $$(PNG_LIBS) +endif ifdef ZLIB_LIBS CPP_FLAGS += -DZLIB_IO C_INCLUDE+= $$(ZLIB_CFLAGS) @@ -161,6 +166,11 @@ makemake: @echo 'ZLIB_CFLAGS = $(ZLIB_CFLAGS)' >> $(MAKENAME) @echo 'ZLIB_LIBS = $(ZLIB_LIBS)' >> $(MAKENAME) @echo '#' >> $(MAKENAME) + @echo '# libpng settings' >> $(MAKENAME) + @echo '#' >> $(MAKENAME) + @echo 'PNG_CFLAGS = $(PNG_CFLAGS)' >> $(MAKENAME) + @echo 'PNG_LIBS = $(PNG_LIBS)' >> $(MAKENAME) + @echo '#' >> $(MAKENAME) @echo '# BLAS settings' >> $(MAKENAME) @echo '#' >> $(MAKENAME) @echo 'BLAS_LIBS = $(BLAS_LIBS)' >> $(MAKENAME) diff --git a/src/programs/SPH_MHD/Makefile b/src/programs/SPH_MHD/Makefile index ad741a5f..9777508c 100644 --- a/src/programs/SPH_MHD/Makefile +++ b/src/programs/SPH_MHD/Makefile @@ -4,10 +4,16 @@ SPH_MHD_MAINDIR = $$(PROG_DIR)/SPH_MHD -TARGET_SPH_MHD = sph_mhd +TARGET_SPH_MHD = sph_mhd +TARGET_SPH_MHD_PSF = sph_mhd_w_psf SOURCES = $(shell ls *.f90) +MOD_SPH_MHD_VIZS = \ +main_sph_MHD_w_vizs.o \ +analyzer_sph_MHD_w_vizs.o \ +SPH_analyzer_MHD.o + MOD_SPH_MHD_MAIN = \ main_sph_MHD_w_psf.o \ analyzer_sph_MHD_w_psf.o \ @@ -21,17 +27,24 @@ dir_list: @echo 'SPH_MHD_MAINDIR = $(SPH_MHD_MAINDIR)' >> $(MAKENAME) target_list: - @echo 'TARGET_SPH_MHD = $$(BUILDDIR)/$(TARGET_SPH_MHD)' >> $(MAKENAME) + @echo 'TARGET_SPH_MHD_PSF = $$(BUILDDIR)/$(TARGET_SPH_MHD_PSF)' >> $(MAKENAME) + @echo 'TARGET_SPH_MHD = $$(BUILDDIR)/$(TARGET_SPH_MHD)' >> $(MAKENAME) @echo >> $(MAKENAME) target_task: @echo sph_mhd: \ '$$(TARGET_SPH_MHD)' >> $(MAKENAME) @echo '' >> $(MAKENAME) - @echo '$$(TARGET_SPH_MHD): $$(MOD_SPH_MHD_MAIN) $$(LIB_FILES_SPH_MHD)' \ + @echo '$$(TARGET_SPH_MHD_PSF): $$(MOD_SPH_MHD_MAIN) $$(LIB_FILES_SPH_MHD)' \ + >> $(MAKENAME) + @echo ' ''$$(F90)' '$$(F90OPTFLAGS)' '$$(F90CPPFLAGS)' \ + -o '$$(TARGET_SPH_MHD_PSF)' '$$(MOD_SPH_MHD_MAIN)' \ + '-L. $$(LIBS_SPH_MHD) $$(F90LIBS)' >> $(MAKENAME) + @echo '' >> $(MAKENAME) + @echo '$$(TARGET_SPH_MHD): $$(MOD_SPH_MHD_VIZS) $$(LIB_FILES_SPH_MHD)' \ >> $(MAKENAME) @echo ' ''$$(F90)' '$$(F90OPTFLAGS)' '$$(F90CPPFLAGS)' \ - -o '$$(TARGET_SPH_MHD)' '$$(MOD_SPH_MHD_MAIN)' \ + -o '$$(TARGET_SPH_MHD)' '$$(MOD_SPH_MHD_VIZS)' \ '-L. $$(LIBS_SPH_MHD) $$(F90LIBS)' >> $(MAKENAME) @echo '' >> $(MAKENAME) @@ -41,6 +54,8 @@ lib_name: mod_list: @echo MOD_SPH_MHD_MAIN= \\ >> $(MAKENAME) @echo $(MOD_SPH_MHD_MAIN) >> $(MAKENAME) + @echo MOD_SPH_MHD_VIZS= \\ >> $(MAKENAME) + @echo $(MOD_SPH_MHD_VIZS) >> $(MAKENAME) @echo '#' >> $(MAKENAME) diff --git a/src/programs/SPH_MHD/Makefile.depends b/src/programs/SPH_MHD/Makefile.depends index 91cb8d56..27fe57f0 100644 --- a/src/programs/SPH_MHD/Makefile.depends +++ b/src/programs/SPH_MHD/Makefile.depends @@ -2,6 +2,10 @@ SPH_analyzer_MHD.o: $(SPH_MHD_MAINDIR)/SPH_analyzer_MHD.f90 m_precision.o m_cons $(F90) -c $(F90OPTFLAGS) $< analyzer_sph_MHD_w_psf.o: $(SPH_MHD_MAINDIR)/analyzer_sph_MHD_w_psf.f90 m_precision.o calypso_mpi.o m_machine_parameter.o m_work_time.o m_elapsed_labels_4_MHD.o m_elapsed_labels_SEND_RECV.o t_spherical_MHD.o t_sph_MHD_w_psf.o t_elapsed_labels_4_SECTIONS.o t_time_data.o t_ctl_data_MHD.o t_ctl_data_sph_MHD_w_psf.o t_SPH_mesh_field_data.o t_SPH_MHD_zmean_sections.o t_viz_sections.o input_control_sph_MHD.o set_control_sph_mhd.o set_control_4_SPH_to_FEM.o SPH_analyzer_MHD.o FEM_analyzer_sph_MHD.o FEM_to_PSF_bridge.o parallel_FEM_mesh_init.o init_sph_MHD_elapsed_label.o output_viz_file_control.o $(F90) -c $(F90OPTFLAGS) $< +analyzer_sph_MHD_w_vizs.o: $(SPH_MHD_MAINDIR)/analyzer_sph_MHD_w_vizs.f90 m_precision.o calypso_mpi.o m_machine_parameter.o m_work_time.o m_elapsed_labels_4_MHD.o m_elapsed_labels_4_VIZ.o m_elapsed_labels_SEND_RECV.o t_spherical_MHD.o t_sph_MHD_w_vizs.o t_time_data.o t_ctl_data_MHD.o t_ctl_data_sph_MHD_w_vizs.o t_SPH_mesh_field_data.o t_SPH_MHD_zonal_mean_viz.o t_four_visualizers.o input_control_sph_MHD.o set_control_sph_mhd.o set_control_4_SPH_to_FEM.o SPH_analyzer_MHD.o FEM_analyzer_sph_MHD.o FEM_to_VIZ_bridge.o parallel_FEM_mesh_init.o init_sph_MHD_elapsed_label.o input_control_sph_MHD_vizs.o output_viz_file_control.o + $(F90) -c $(F90OPTFLAGS) $< main_sph_MHD_w_psf.o: $(SPH_MHD_MAINDIR)/main_sph_MHD_w_psf.f90 m_precision.o calypso_mpi.o analyzer_sph_MHD_w_psf.o $(F90) -c $(F90OPTFLAGS) $< +main_sph_MHD_w_vizs.o: $(SPH_MHD_MAINDIR)/main_sph_MHD_w_vizs.f90 m_precision.o calypso_mpi.o analyzer_sph_MHD_w_vizs.o + $(F90) -c $(F90OPTFLAGS) $< diff --git a/src/programs/SPH_MHD/analyzer_sph_MHD_w_vizs.f90 b/src/programs/SPH_MHD/analyzer_sph_MHD_w_vizs.f90 new file mode 100644 index 00000000..3deef253 --- /dev/null +++ b/src/programs/SPH_MHD/analyzer_sph_MHD_w_vizs.f90 @@ -0,0 +1,238 @@ +!>@file analyzer_sph_MHD_w_vizs.f90 +!!@brief module analyzer_sph_MHD_w_vizs +!! +!!@author H. Matsui +!!@date Programmed H. Matsui in Apr., 2010 +! +!>@brief Main loop for MHD dynamo simulation +!! +!!@verbatim +!! subroutine initialize_sph_mhd_w_vizs(control_file_name) +!! subroutine evolution_sph_mhd_w_vizs +!! character(len=kchara), intent(in) :: control_file_name +!!@endverbatim +! + module analyzer_sph_MHD_w_vizs +! + use m_precision + use calypso_mpi +! + use m_machine_parameter + use m_work_time + use m_elapsed_labels_4_MHD + use m_elapsed_labels_4_VIZ + use m_elapsed_labels_SEND_RECV + use t_spherical_MHD + use t_sph_MHD_w_vizs +! + implicit none +! +! +!> Structure of the all data of program + type(spherical_MHD), save, private :: MHDMs +!> Structure for visualization in spherical MHD + type(sph_MHD_w_vizs), save, private :: MVIZs +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine initialize_sph_mhd_w_vizs(control_file_name) +! + use t_time_data + use t_ctl_data_MHD + use t_ctl_data_sph_MHD_w_vizs + use t_SPH_mesh_field_data + use t_SPH_MHD_zonal_mean_viz + use t_four_visualizers + use input_control_sph_MHD + use set_control_sph_mhd + use set_control_4_SPH_to_FEM + use SPH_analyzer_MHD + use FEM_analyzer_sph_MHD + use FEM_to_VIZ_bridge + use parallel_FEM_mesh_init + use init_sph_MHD_elapsed_label + use input_control_sph_MHD_vizs +! + character(len=kchara), intent(in) :: control_file_name +! +!> Control struture for MHD simulation + type(mhd_simulation_control), save :: MHD_ctl1 +!> Additional structures for spherical MHD dynamo with viz module + type(add_vizs_sph_mhd_ctl), save :: add_VMHD_ctl1 +! +! + write(*,*) 'Simulation start: PE. ', my_rank + MHDMs%MHD_step%finish_d%started_time = MPI_WTIME() + call init_elapse_time_by_TOTAL + call set_sph_MHD_elapsed_label + call set_elpsed_label_4_VIZ(flag_detailed1, elps_VIZ1, elps1) + call elpsed_label_field_send_recv +! +! Load parameter file +! + if(iflag_TOT_time) call start_elapsed_time(ied_total_elapsed) + if(iflag_MHD_time) call start_elapsed_time(ist_elapsed_MHD+3) + if (iflag_debug.eq.1) write(*,*) 's_input_control_SPH_MHD_vizs' + call s_input_control_SPH_MHD_vizs(control_file_name, & + & MHDMs%MHD_files, MHD_ctl1, add_VMHD_ctl1, & + & MHDMs%MHD_step, MHDMs%SPH_model, MHDMs%SPH_WK, & + & MHDMs%SPH_MHD, MVIZs%FEM_DAT) + if(iflag_MHD_time) call end_elapsed_time(ist_elapsed_MHD+3) +! +! Initialize FEM mesh data for field data IO +! + if(iflag_MHD_time) call start_elapsed_time(ist_elapsed_MHD+1) + if(iflag_debug .gt. 0) write(*,*) 'FEM_initialize_sph_MHD' + call FEM_initialize_sph_MHD(MHDMs%MHD_files, MHDMs%MHD_step, & + & MVIZs%FEM_DAT, MHDMs%MHD_IO, MHDMs%m_SR) + call init_FEM_to_VIZ_bridge(elps_VIZ1, MHDMs%MHD_step%viz_step, & + & MVIZs%FEM_DAT%geofem, MVIZs%VIZ_DAT, MHDMs%m_SR) +! +! Initialize spherical transform dynamo +! + if(iflag_debug .gt. 0) write(*,*) 'SPH_initialize_MHD' + call SPH_initialize_MHD & + & (MHDMs%MHD_files, MHDMs%SPH_model, MVIZs%FEM_DAT, & + & MHDMs%MHD_step, MHDMs%MHD_IO%rst_IO, MHDMs%SPH_MHD, & + & MHDMs%SPH_WK, MHDMs%m_SR) +! +! Initialize visualization +! + if(iflag_debug .gt. 0) write(*,*) 'init_four_visualize' + call init_four_visualize(elps_VIZ1, MHDMs%MHD_step%viz_step, & + & MVIZs%FEM_DAT%geofem, MVIZs%FEM_DAT%field, MVIZs%VIZ_DAT, & + & add_VMHD_ctl1%viz4_ctls, MVIZs%VIZ4s, MHDMs%m_SR) + call dealloc_viz4_controls(add_VMHD_ctl1%viz4_ctls) +! + call init_zonal_mean_vizs & + & (elps_VIZ1, MHDMs%MHD_step%viz_step, MVIZs%FEM_DAT%geofem, & + & MVIZs%VIZ_DAT%edge_comm, MVIZs%FEM_DAT%field, & + & add_VMHD_ctl1%zm_ctls, MVIZs%zmeans, MHDMs%m_SR) +! + if(iflag_MHD_time) call end_elapsed_time(ist_elapsed_MHD+1) + call calypso_MPI_barrier + call reset_elapse_4_init_sph_mhd + call reset_elapse_after_init_VIZ(elps_VIZ1, elps1) +! + end subroutine initialize_sph_mhd_w_vizs +! +! ---------------------------------------------------------------------- +! + subroutine evolution_sph_mhd_w_vizs +! + use t_time_data + use t_SPH_MHD_zonal_mean_viz + use t_four_visualizers + use SPH_analyzer_MHD + use FEM_analyzer_sph_MHD + use output_viz_file_control + use init_sph_MHD_elapsed_label +! + integer(kind = kint) :: iflag_finish +! +! --------------------- +! + if(iflag_MHD_time) call start_elapsed_time(ist_elapsed_MHD+2) +! +!* ------- time evelution loop start ----------- +!* + iflag_finish = 0 + do + call evolve_time_data(MHDMs%MHD_step%time_d) +! +!* ---------- time evolution by spectral methood ----------------- +!* + if(lead_field_data_flag(MHDMs%MHD_step%time_d%i_time_step, & + & MHDMs%MHD_step)) then + call alloc_sph_trans_area_snap(MHDMs%SPH_MHD%sph, & + & MHDMs%SPH_WK%trns_WK) + end if +! + if (iflag_debug.eq.1) write(*,*) 'SPH_analyze_MHD' + call SPH_analyze_MHD(MHDMs%MHD_files, iflag_finish, & + & MHDMs%SPH_model, MHDMs%MHD_step, MHDMs%MHD_IO%rst_IO, & + & MHDMs%SPH_MHD, MHDMs%SPH_WK, MHDMs%m_SR) +!* +!* ----------- output field data -------------- +!* + if(iflag_MHD_time) call start_elapsed_time(ist_elapsed_MHD+3) + if(lead_field_data_flag(MHDMs%MHD_step%time_d%i_time_step, & + & MHDMs%MHD_step)) then + if (iflag_debug.eq.1) write(*,*) 'SPH_to_FEM_bridge_MHD' + call SPH_to_FEM_bridge_MHD & + & (MHDMs%SPH_MHD%sph, MHDMs%SPH_WK%trns_WK, & + & MVIZs%FEM_DAT%geofem, MVIZs%FEM_DAT%field) + end if +! + if (iflag_debug.eq.1) write(*,*) 'FEM_analyze_sph_MHD' + call FEM_analyze_sph_MHD(MHDMs%MHD_files, MVIZs%FEM_DAT, & + & MHDMs%MHD_step, MHDMs%MHD_IO, MHDMs%m_SR) +! + if(iflag_MHD_time) call end_elapsed_time(ist_elapsed_MHD+3) +! +!* ----------- Visualization -------------- +!* + if(iflag_vizs_w_fix_step(MHDMs%MHD_step%time_d%i_time_step, & + & MHDMs%MHD_step%viz_step)) then + if (iflag_debug.eq.1) write(*,*) 'visualize_four', my_rank + if(iflag_MHD_time) call start_elapsed_time(ist_elapsed_MHD+4) + call istep_viz_w_fix_dt(MHDMs%MHD_step%time_d%i_time_step, & + & MHDMs%MHD_step%viz_step) + call visualize_four(elps_VIZ1, & + & MHDMs%MHD_step%viz_step, MHDMs%MHD_step%time_d, & + & MVIZs%FEM_DAT%geofem, MVIZs%FEM_DAT%field, & + & MVIZs%VIZ_DAT, MVIZs%VIZ4s, MHDMs%m_SR) +!* +!* ----------- Zonal means -------------- +!* + if(MHDMs%MHD_step%viz_step%istep_psf .ge. 0 & + & .or. MHDMs%MHD_step%viz_step%istep_map .ge. 0) then + call SPH_MHD_zmean_vizs(elps_VIZ1, & + & MHDMs%MHD_step%viz_step, MHDMs%MHD_step%time_d, & + & MHDMs%SPH_MHD%sph, MVIZs%FEM_DAT%geofem, & + & MHDMs%SPH_WK%trns_WK, MVIZs%FEM_DAT%field, & + & MVIZs%zmeans, MHDMs%m_SR) + end if + if(iflag_MHD_time) call end_elapsed_time(ist_elapsed_MHD+4) + end if +!* + if(lead_field_data_flag(MHDMs%MHD_step%time_d%i_time_step, & + & MHDMs%MHD_step)) then + call dealloc_sph_trans_area_snap(MHDMs%SPH_WK%trns_WK) + end if +! +!* ----------- exit loop -------------- +!* + if(iflag_finish .gt. 0) exit + end do +! +! time evolution end +! + if(iflag_MHD_time) call end_elapsed_time(ist_elapsed_MHD+2) +! + if (iflag_debug.eq.1) write(*,*) 'FEM_finalize' + call FEM_finalize(MHDMs%MHD_files, MHDMs%MHD_step, & + & MHDMs%MHD_IO) +! +! if (iflag_debug.eq.1) write(*,*) 'SPH_finalize_MHD' +! call SPH_finalize_MHD +! + if(iflag_TOT_time) call end_elapsed_time(ied_total_elapsed) +! + if (iflag_debug.eq.1) write(*,*) 'write_resolution_data' + call write_resolution_data(MHDMs%SPH_MHD%sph) + if (iflag_debug.eq.1) write(*,*) 'output_elapsed_times ' + call output_elapsed_times +! + call calypso_MPI_barrier + if (iflag_debug.eq.1) write(*,*) 'exit evolution' +! + end subroutine evolution_sph_mhd_w_vizs +! +! ---------------------------------------------------------------------- +! + end module analyzer_sph_MHD_w_vizs diff --git a/src/programs/SPH_MHD/main_sph_MHD_w_vizs.f90 b/src/programs/SPH_MHD/main_sph_MHD_w_vizs.f90 new file mode 100644 index 00000000..e47bf356 --- /dev/null +++ b/src/programs/SPH_MHD/main_sph_MHD_w_vizs.f90 @@ -0,0 +1,34 @@ +!>@file main_sph_MHD_w_vizs.f90 +!!@brief program kemorin_sph_MHD +!! +!!@author H. Matsui +!!@date Programmed by H. Okuda in 2000 +!!@n Modified by H. Matsui in May, 2003 (ver 2.0) +!!@n Connect to vizs by H. Matsui in July 2006 (ver 2.0) +! +!>@brief Main program for MHD dynamo simulation with PVR module +!! input control file: control_MHD +! + program kemorin_sph_MHD +! + use m_precision +! + use calypso_mpi + use analyzer_sph_MHD_w_vizs +! + implicit none +! +!> File name for control file + character(len=kchara), parameter :: MHD_ctl_name = 'control_MHD' +! +! + call calypso_MPI_init +! + call initialize_sph_mhd_w_vizs(MHD_ctl_name) + call evolution_sph_mhd_w_vizs +! + call calypso_MPI_finalize +! + stop '***** program finished *****' +! + end program kemorin_sph_MHD diff --git a/src/programs/data_utilities/SNAPSHOT_MHD/Makefile b/src/programs/data_utilities/SNAPSHOT_MHD/Makefile index 0568c1db..73cdd12f 100644 --- a/src/programs/data_utilities/SNAPSHOT_MHD/Makefile +++ b/src/programs/data_utilities/SNAPSHOT_MHD/Makefile @@ -4,19 +4,24 @@ SPH_SNAP_MAINDIR = $$(DATA_UTILS_DIR)/SNAPSHOT_MHD -TARGET_SPH_SNAP = sph_snapshot +TARGET_SPH_VIZS_SNAP = sph_snapshot +TARGET_SPH_PSF_SNAP = sph_snapshot_w_psf TARGET_CONTROL_MHD_CHECK = utilities/check_control_mhd - SOURCES = $(shell ls *.f90) -MOD_SPH_SNAP_MAIN = \ +MOD_SPH_SNAP_VIZS_MAIN = \ +main_sph_snapshot_w_vizs.o \ +analyzer_sph_snap_w_vizs.o \ +SPH_analyzer_snap_w_vizs.o + +MOD_SPH_SNAP_PSF_MAIN = \ main_sph_snapshot_w_psf.o \ analyzer_sph_snap_w_psf.o \ SPH_analyzer_snap_w_vizs.o MOD_CONTROL_MHD_CHECK = \ -main_control_MHD_psf_check.o +main_control_MHD_viz_check.o # # ------------------------------------------------------------------------- @@ -26,20 +31,27 @@ dir_list: @echo 'SPH_SNAP_MAINDIR = $(SPH_SNAP_MAINDIR)' >> $(MAKENAME) target_list: - @echo 'TARGET_SPH_SNAP = $$(BUILDDIR)/$(TARGET_SPH_SNAP)'>> $(MAKENAME) + @echo 'TARGET_SPH_PSF_SNAP = $$(BUILDDIR)/$(TARGET_SPH_PSF_SNAP)'>> $(MAKENAME) + @echo 'TARGET_SPH_VIZS_SNAP = $$(BUILDDIR)/$(TARGET_SPH_VIZS_SNAP)' >> $(MAKENAME) @echo 'TARGET_CONTROL_MHD_CHECK = $$(BUILDDIR)/$(TARGET_CONTROL_MHD_CHECK)'>> $(MAKENAME) @echo >> $(MAKENAME) target_task: @echo sph_snapshots: \ - '$$(TARGET_SPH_SNAP)' \ + '$$(TARGET_SPH_VIZS_SNAP)' \ '$$(TARGET_CONTROL_MHD_CHECK)' \ >> $(MAKENAME) @echo '' >> $(MAKENAME) - @echo '$$(TARGET_SPH_SNAP): $$(MOD_SPH_SNAP_MAIN) $$(LIB_FILES_SPH_MHD)' \ + @echo '$$(TARGET_SPH_PSF_SNAP): $$(MOD_SPH_SNAP_PSF_MAIN) $$(LIB_FILES_SPH_MHD)' \ + >> $(MAKENAME) + @echo ' ''$$(F90)' '$$(F90OPTFLAGS)' '$$(F90CPPFLAGS)' \ + -o '$$(TARGET_SPH_PSF_SNAP)' '$$(MOD_SPH_SNAP_PSF_MAIN)' \ + '-L. $$(LIBS_SPH_MHD) $$(F90LIBS)' >> $(MAKENAME) + @echo '' >> $(MAKENAME) + @echo '$$(TARGET_SPH_VIZS_SNAP): $$(MOD_SPH_SNAP_VIZS_MAIN) $$(LIB_FILES_SPH_MHD)' \ >> $(MAKENAME) @echo ' ''$$(F90)' '$$(F90OPTFLAGS)' '$$(F90CPPFLAGS)' \ - -o '$$(TARGET_SPH_SNAP)' '$$(MOD_SPH_SNAP_MAIN)' \ + -o '$$(TARGET_SPH_VIZS_SNAP)' '$$(MOD_SPH_SNAP_VIZS_MAIN)' \ '-L. $$(LIBS_SPH_MHD) $$(F90LIBS)' >> $(MAKENAME) @echo '' >> $(MAKENAME) @echo '$$(TARGET_CONTROL_MHD_CHECK): $$(MOD_CONTROL_MHD_CHECK) $$(LIB_FILES_SPH_MHD)' \ @@ -53,8 +65,10 @@ target_task: lib_name: mod_list: - @echo MOD_SPH_SNAP_MAIN= \\ >> $(MAKENAME) - @echo $(MOD_SPH_SNAP_MAIN) >> $(MAKENAME) + @echo MOD_SPH_SNAP_PSF_MAIN= \\ >> $(MAKENAME) + @echo $(MOD_SPH_SNAP_PSF_MAIN) >> $(MAKENAME) + @echo MOD_SPH_SNAP_VIZS_MAIN= \\ >> $(MAKENAME) + @echo $(MOD_SPH_SNAP_VIZS_MAIN) >> $(MAKENAME) @echo MOD_CONTROL_MHD_CHECK= \\ >> $(MAKENAME) @echo $(MOD_CONTROL_MHD_CHECK) >> $(MAKENAME) @echo '#' >> $(MAKENAME) diff --git a/src/programs/data_utilities/SNAPSHOT_MHD/Makefile.depends b/src/programs/data_utilities/SNAPSHOT_MHD/Makefile.depends index 4bc95c98..fc5662ab 100644 --- a/src/programs/data_utilities/SNAPSHOT_MHD/Makefile.depends +++ b/src/programs/data_utilities/SNAPSHOT_MHD/Makefile.depends @@ -2,8 +2,14 @@ SPH_analyzer_snap_w_vizs.o: $(SPH_SNAP_MAINDIR)/SPH_analyzer_snap_w_vizs.f90 m_p $(F90) -c $(F90OPTFLAGS) $< analyzer_sph_snap_w_psf.o: $(SPH_SNAP_MAINDIR)/analyzer_sph_snap_w_psf.f90 m_precision.o calypso_mpi.o m_work_time.o m_elapsed_labels_4_MHD.o m_elapsed_labels_SEND_RECV.o m_machine_parameter.o t_spherical_MHD.o t_sph_MHD_w_psf.o t_elapsed_labels_4_SECTIONS.o t_ctl_data_MHD.o t_ctl_data_sph_MHD_w_psf.o t_viz_sections.o t_SPH_MHD_zmean_sections.o init_sph_MHD_elapsed_label.o input_control_sph_MHD.o SPH_analyzer_snap_w_vizs.o FEM_analyzer_sph_MHD.o FEM_to_PSF_bridge.o output_viz_file_control.o set_time_step_params.o $(F90) -c $(F90OPTFLAGS) $< +analyzer_sph_snap_w_vizs.o: $(SPH_SNAP_MAINDIR)/analyzer_sph_snap_w_vizs.f90 m_precision.o calypso_mpi.o m_work_time.o m_elapsed_labels_4_MHD.o m_elapsed_labels_4_VIZ.o m_elapsed_labels_SEND_RECV.o m_machine_parameter.o t_spherical_MHD.o t_sph_MHD_w_vizs.o t_ctl_data_MHD.o t_ctl_data_sph_MHD_w_vizs.o init_sph_MHD_elapsed_label.o input_control_sph_MHD_vizs.o FEM_analyzer_sph_MHD.o SPH_analyzer_snap_w_vizs.o FEM_to_VIZ_bridge.o output_viz_file_control.o set_time_step_params.o + $(F90) -c $(F90OPTFLAGS) $< main_control_MHD_psf_check.o: $(SPH_SNAP_MAINDIR)/main_control_MHD_psf_check.f90 m_precision.o t_ctl_data_MHD.o t_ctl_data_sph_MHD_w_psf.o t_read_control_elements.o write_control_elements.o $(F90) -c $(F90OPTFLAGS) $< +main_control_MHD_viz_check.o: $(SPH_SNAP_MAINDIR)/main_control_MHD_viz_check.f90 m_precision.o t_ctl_data_MHD.o t_ctl_data_sph_MHD_w_vizs.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< main_sph_snapshot_w_psf.o: $(SPH_SNAP_MAINDIR)/main_sph_snapshot_w_psf.f90 m_precision.o calypso_mpi.o analyzer_sph_snap_w_psf.o $(F90) -c $(F90OPTFLAGS) $< +main_sph_snapshot_w_vizs.o: $(SPH_SNAP_MAINDIR)/main_sph_snapshot_w_vizs.f90 m_precision.o calypso_mpi.o analyzer_sph_snap_w_vizs.o + $(F90) -c $(F90OPTFLAGS) $< diff --git a/src/programs/data_utilities/SNAPSHOT_MHD/analyzer_sph_snap_w_vizs.f90 b/src/programs/data_utilities/SNAPSHOT_MHD/analyzer_sph_snap_w_vizs.f90 new file mode 100644 index 00000000..c1bfb120 --- /dev/null +++ b/src/programs/data_utilities/SNAPSHOT_MHD/analyzer_sph_snap_w_vizs.f90 @@ -0,0 +1,216 @@ +!>@file analyzer_sph_snap_w_vizs.f90 +!!@brief module analyzer_sph_snap_w_vizs +!! +!!@author H. Matsui +!!@date Programmed H. Matsui in Apr., 2010 +! +!>@brief Main loop to evaluate snapshots from spectr data +!! +!!@verbatim +!! subroutine initialize_sph_snap_w_vizs(control_file_name) +!! subroutine evolution_sph_snap_w_vizs +!! character(len=kchara), intent(in) :: control_file_name +!!@endverbatim +! + module analyzer_sph_snap_w_vizs +! + use m_precision + use calypso_mpi +! + use m_work_time + use m_elapsed_labels_4_MHD + use m_elapsed_labels_4_VIZ + use m_elapsed_labels_SEND_RECV + use m_machine_parameter + use t_spherical_MHD + use t_sph_MHD_w_vizs +! + implicit none +! +!> Structure of the all data of program + type(spherical_MHD), save, private :: SNAPs +!> Structure for visualization in spherical MHD + type(sph_MHD_w_vizs), save, private :: MVIZs +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine initialize_sph_snap_w_vizs(control_file_name) +! + use t_ctl_data_MHD + use t_ctl_data_sph_MHD_w_vizs + use init_sph_MHD_elapsed_label + use input_control_sph_MHD_vizs + use FEM_analyzer_sph_MHD + use SPH_analyzer_snap_w_vizs + use FEM_to_VIZ_bridge +! + character(len=kchara), intent(in) :: control_file_name +! +!> Control struture for MHD simulation + type(mhd_simulation_control), save :: DNS_MHD_ctl1 +!> Additional structures for spherical MHD dynamo with viz module + type(add_vizs_sph_mhd_ctl), save :: add_VMHD_ctl1 +! +! + write(*,*) 'Simulation start: PE. ', my_rank + SNAPs%MHD_step%finish_d%started_time = MPI_WTIME() + call init_elapse_time_by_TOTAL + call set_sph_MHD_elapsed_label + call set_elpsed_label_4_VIZ(flag_detailed1, elps_VIZ1, elps1) + call elpsed_label_field_send_recv +! +! Load parameter file +! + if(iflag_TOT_time) call start_elapsed_time(ied_total_elapsed) + if(iflag_MHD_time) call start_elapsed_time(ist_elapsed_MHD+3) + if (iflag_debug.eq.1) write(*,*) 's_input_control_SPH_MHD_vizs' + call s_input_control_SPH_MHD_vizs(control_file_name, & + & SNAPs%MHD_files, DNS_MHD_ctl1, add_VMHD_ctl1, SNAPs%MHD_step, & + & SNAPs%SPH_model, SNAPs%SPH_WK, SNAPs%SPH_MHD, MVIZs%FEM_DAT) + if(iflag_MHD_time) call end_elapsed_time(ist_elapsed_MHD+3) +! +! --------------------- +! + if(iflag_MHD_time) call start_elapsed_time(ist_elapsed_MHD+1) + if(iflag_debug .gt. 0) write(*,*) 'FEM_initialize_sph_MHD' + call FEM_initialize_sph_MHD(SNAPs%MHD_files, SNAPs%MHD_step, & + & MVIZs%FEM_DAT, SNAPs%MHD_IO, SNAPs%m_SR) + call init_FEM_to_VIZ_bridge(elps_VIZ1, SNAPs%MHD_step%viz_step, & + & MVIZs%FEM_DAT%geofem, MVIZs%VIZ_DAT, SNAPs%m_SR) +! +! Initialize spherical transform dynamo + if(iflag_debug .gt. 0) write(*,*) 'SPH_init_sph_snap_vizs' + call SPH_init_sph_snap_vizs & + & (SNAPs%MHD_files, MVIZs%FEM_DAT, SNAPs%SPH_model, & + & SNAPs%MHD_step, SNAPs%SPH_MHD, SNAPs%SPH_WK, SNAPs%m_SR) +! +! Initialize visualization + if(iflag_debug .gt. 0) write(*,*) 'init_four_visualize' + call init_four_visualize(elps_VIZ1, SNAPs%MHD_step%viz_step, & + & MVIZs%FEM_DAT%geofem, MVIZs%FEM_DAT%field, MVIZs%VIZ_DAT, & + & add_VMHD_ctl1%viz4_ctls, MVIZs%VIZ4s, SNAPs%m_SR) + + call init_zonal_mean_vizs(elps_VIZ1, SNAPs%MHD_step%viz_step, & + & MVIZs%FEM_DAT%geofem, MVIZs%VIZ_DAT%edge_comm, & + & MVIZs%FEM_DAT%field, add_VMHD_ctl1%zm_ctls, & + & MVIZs%zmeans, SNAPs%m_SR) +! + if(iflag_MHD_time) call end_elapsed_time(ist_elapsed_MHD+1) + call calypso_MPI_barrier + call reset_elapse_4_init_sph_mhd + call reset_elapse_after_init_VIZ(elps_VIZ1, elps1) +! + end subroutine initialize_sph_snap_w_vizs +! +! ---------------------------------------------------------------------- +! + subroutine evolution_sph_snap_w_vizs +! + use FEM_analyzer_sph_MHD + use SPH_analyzer_snap_w_vizs + use init_sph_MHD_elapsed_label + use output_viz_file_control + use set_time_step_params +! +!* ----------- set initial step data -------------- +!* + if(iflag_MHD_time) call start_elapsed_time(ist_elapsed_MHD+2) + call set_from_initial_step(SNAPs%MHD_step%init_d, & + & SNAPs%MHD_step%time_d) +!* +!* ------- time evelution loop start ----------- +!* + do + call add_one_step(SNAPs%MHD_step%time_d) + if(output_IO_flag(SNAPs%MHD_step%time_d%i_time_step, & + & SNAPs%MHD_step%rst_step) .eqv. .FALSE.) cycle +! +!* ---------- time evolution by spectral methood ----------------- +!* + if(lead_field_data_flag(SNAPs%MHD_step%time_d%i_time_step, & + & SNAPs%MHD_step)) then + call alloc_sph_trans_area_snap(SNAPs%SPH_MHD%sph, & + & SNAPs%SPH_WK%trns_WK) +! + if (iflag_debug.eq.1) write(*,*) 'SPH_analyze_snap_vizs' + call SPH_analyze_snap_vizs & + & (SNAPs%MHD_files, SNAPs%SPH_model, SNAPs%MHD_step, & + & SNAPs%SPH_MHD, SNAPs%SPH_WK, SNAPs%m_SR) +!* +!* ----------- output field data -------------- +!* + if(iflag_MHD_time) call start_elapsed_time(ist_elapsed_MHD+3) + if (iflag_debug.eq.1) write(*,*) 'SPH_to_FEM_bridge_MHD' + call SPH_to_FEM_bridge_MHD & + & (SNAPs%SPH_MHD%sph, SNAPs%SPH_WK%trns_WK, & + & MVIZs%FEM_DAT%geofem, MVIZs%FEM_DAT%field) +! + if (iflag_debug.eq.1) write(*,*) 'FEM_analyze_sph_MHD' + call FEM_analyze_sph_MHD(SNAPs%MHD_files, & + & MVIZs%FEM_DAT, SNAPs%MHD_step, SNAPs%MHD_IO, SNAPs%m_SR) + if(iflag_MHD_time) call end_elapsed_time(ist_elapsed_MHD+3) + end if +! +!* ----------- Visualization -------------- +!* + if(iflag_vizs_w_fix_step(SNAPs%MHD_step%time_d%i_time_step, & + & SNAPs%MHD_step%viz_step)) then + if (iflag_debug.eq.1) write(*,*) 'visualize_four' + if(iflag_MHD_time) call start_elapsed_time(ist_elapsed_MHD+4) + call istep_viz_w_fix_dt(SNAPs%MHD_step%time_d%i_time_step, & + & SNAPs%MHD_step%viz_step) + call visualize_four(elps_VIZ1, & + & SNAPs%MHD_step%viz_step, SNAPs%MHD_step%time_d, & + & MVIZs%FEM_DAT%geofem, MVIZs%FEM_DAT%field, MVIZs%VIZ_DAT, & + & MVIZs%VIZ4s, SNAPs%m_SR) +!* +!* ----------- Zonal means -------------- +!* + if(SNAPs%MHD_step%viz_step%istep_psf .ge. 0 & + & .or. SNAPs%MHD_step%viz_step%istep_map .ge. 0) then + call SPH_MHD_zmean_vizs(elps_VIZ1, & + & SNAPs%MHD_step%viz_step, SNAPs%MHD_step%time_d, & + & SNAPs%SPH_MHD%sph, MVIZs%FEM_DAT%geofem, & + & SNAPs%SPH_WK%trns_WK, MVIZs%FEM_DAT%field, & + & MVIZs%zmeans, SNAPs%m_SR) + end if + if(iflag_MHD_time) call end_elapsed_time(ist_elapsed_MHD+4) + end if +! + if(lead_field_data_flag(SNAPs%MHD_step%time_d%i_time_step, & + & SNAPs%MHD_step)) then + call dealloc_sph_trans_area_snap(SNAPs%SPH_WK%trns_WK) + end if +! +!* ----------- exit loop -------------- +!* + if(SNAPs%MHD_step%time_d%i_time_step & + & .ge. SNAPs%MHD_step%finish_d%i_end_step) exit + end do +! +! time evolution end +! + if(iflag_MHD_time) call end_elapsed_time(ist_elapsed_MHD+2) +! + if (iflag_debug.eq.1) write(*,*) 'FEM_finalize' + call FEM_finalize(SNAPs%MHD_files, SNAPs%MHD_step, SNAPs%MHD_IO) +! +! if (iflag_debug.eq.1) write(*,*) 'SPH_finalize_snap' +! call SPH_finalize_snap +! + if(iflag_TOT_time) call end_elapsed_time(ied_total_elapsed) +! + call output_elapsed_times +! + call calypso_MPI_barrier + if (iflag_debug.eq.1) write(*,*) 'exit evolution' +! + end subroutine evolution_sph_snap_w_vizs +! +! ---------------------------------------------------------------------- +! + end module analyzer_sph_snap_w_vizs diff --git a/src/programs/data_utilities/SNAPSHOT_MHD/main_control_MHD_viz_check.f90 b/src/programs/data_utilities/SNAPSHOT_MHD/main_control_MHD_viz_check.f90 new file mode 100644 index 00000000..dfd96ae5 --- /dev/null +++ b/src/programs/data_utilities/SNAPSHOT_MHD/main_control_MHD_viz_check.f90 @@ -0,0 +1,83 @@ +!>@file main_control_MHD_viz_check.f90 +!!@brief program kemorin_control_MHD_check +!! +!!@author H. Matsui +!!@date Programmed by by H. Matsui in July 2023 +! +!>@brief Main program to check control file for SPH_MHD +!! with visualizers +!! Input ontrol file: control_snapshot +! + program control_MHD_w_viz_check +! + use m_precision +! + use t_ctl_data_MHD + use t_ctl_data_sph_MHD_w_vizs + use write_control_elements +! + implicit none +! +!> File name for control file + character(len=kchara) :: MHD_ctl_name +! + type(mhd_simulation_control) :: MHD_ctl1 + type(add_vizs_sph_mhd_ctl) :: add_VMHD_ctl1 + type(buffer_for_control) :: c_buf1 +! +! + if(iargc_kemo() .le. 0) then + write(*,*) 'check_control_mhd CONTROL_FILE_NAME' + stop + end if + call getarg_k(1, MHD_ctl_name) +! + c_buf1%level = 0 + call read_control_4_sph_MHD_w_vizs(MHD_ctl_name, & + & MHD_ctl1, add_VMHD_ctl1, c_buf1) + if(c_buf1%iend .gt. 0) stop 'Error in control file' +! +! + write(id_monitor,'(a)') '! ' + write(id_monitor,'(a)') '! Checked control data' + write(id_monitor,'(a)') '! ' + call write_sph_mhd_ctl_w_vizs(id_monitor, & + & MHD_ctl1, add_VMHD_ctl1, c_buf1%level) +! + stop '***** program finished *****' +! +! -------------------------------------------------------------------- +! + contains +! +! -------------------------------------------------------------------- +! + subroutine getarg_k(i, argc) +! + integer, intent(in) :: i + character(len=*), intent(out) :: argc +! + call getarg(0, argc) + if(argc == "") then + call getarg(i + 1, argc) + else + call getarg(i, argc) + end if + end subroutine getarg_k +! +! -------------------------------------------------------------------- +! + integer function iargc_kemo() result(oresult) +! + integer :: iargc + character(len=8) :: argc + oresult = iargc() + call getarg(0, argc) + if(argc == "") then + oresult = oresult - 1 + end if + end function iargc_kemo +! +! -------------------------------------------------------------------- +! + end program control_MHD_w_viz_check diff --git a/src/programs/data_utilities/SNAPSHOT_MHD/main_sph_snapshot_w_vizs.f90 b/src/programs/data_utilities/SNAPSHOT_MHD/main_sph_snapshot_w_vizs.f90 new file mode 100644 index 00000000..4169ab72 --- /dev/null +++ b/src/programs/data_utilities/SNAPSHOT_MHD/main_sph_snapshot_w_vizs.f90 @@ -0,0 +1,36 @@ +!>@file main_sph_snapshot_w_vizs.f90 +!!@brief program sph_snapshot_w_vizs +!! +!!@author H. Matsui +!!@date Programmed by H. Okuda in 2000 +!!@n Modified by H. Matsui in May, 2003 (ver 2.0) +!!@n Connect to vizs by H. Matsui in July 2006 (ver 2.0) +! +!>@brief Main program to evaluate snapshots from spectr data +!! with visualizers +!! Input control file: control_snapshot +! + program sph_snapshot_w_vizs +! + use m_precision +! + use calypso_mpi + use analyzer_sph_snap_w_vizs +! + implicit none +! +!> File name for control file + character(len=kchara), parameter & + & :: snap_ctl_name = 'control_snapshot' +! +! + call calypso_MPI_init +! + call initialize_sph_snap_w_vizs(snap_ctl_name) + call evolution_sph_snap_w_vizs +! + call calypso_MPI_finalize +! + stop '***** program finished *****' +! + end program sph_snapshot_w_vizs diff --git a/src/programs/data_utilities/VIZ_only/FEM_analyzer_four_vizs.f90 b/src/programs/data_utilities/VIZ_only/FEM_analyzer_four_vizs.f90 new file mode 100644 index 00000000..74ea7d64 --- /dev/null +++ b/src/programs/data_utilities/VIZ_only/FEM_analyzer_four_vizs.f90 @@ -0,0 +1,146 @@ +!>@file FEM_analyzer_four_vizs.f90 +!!@brief module FEM_analyzer_four_vizs +!! +!!@author H. Matsui +!!@date Programmed in June, 2006 +! +!>@brief Arrays for Field data IO for visualizers +!! +!!@verbatim +!! subroutine FEM_initialize_four_vizs & +!! & (elps_VIZ, init_d, ucd_step, viz_step, & +!! & FEM_viz, pvr, m_SR) +!! type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ +!! type(IO_step_param), intent(in) :: ucd_step +!! type(time_data), intent(in) :: init_d +!! type(VIZ_step_params), intent(inout) :: viz_step +!! type(FEM_mesh_field_for_viz), intent(inout) :: FEM_viz +!! type(VIZ_mesh_field), intent(inout) :: pvr +!! type(mesh_SR), intent(inout) :: m_SR +!! subroutine FEM_analyze_four_vizs & +!! & (istep, ucd_step, time_d, FEM_viz, m_SR) +!! type(IO_step_param), intent(in) :: ucd_step +!! type(time_data), intent(inout) :: time_d +!! type(FEM_mesh_field_for_viz), intent(inout) :: FEM_viz +!! type(mesh_SR), intent(inout) :: m_SR +!!@endverbatim +! + module FEM_analyzer_four_vizs +! + use m_precision + use m_machine_parameter + use calypso_mpi +! + use t_step_parameter + use t_time_data + use t_FEM_mesh_field_4_viz + use t_ucd_data + use t_next_node_ele_4_node + use t_shape_functions + use t_jacobians + use t_file_IO_parameter + use t_field_list_for_vizs + use t_VIZ_step_parameter + use t_mesh_SR +! + implicit none +! +! ---------------------------------------------------------------------- +! + contains +! +! ---------------------------------------------------------------------- +! + subroutine FEM_initialize_four_vizs & + & (elps_VIZ, init_d, ucd_step, viz_step, & + & FEM_viz, pvr, m_SR) +! + use t_elapsed_labels_4_VIZ + use t_VIZ_mesh_field + use mpi_load_mesh_data + use nod_phys_send_recv + use parallel_FEM_mesh_init + use set_parallel_file_name + use set_ucd_data_to_type + use parallel_ucd_IO_select + use FEM_to_VIZ_bridge +! + type(elapsed_labels_4_VIZ), intent(in) :: elps_VIZ + type(IO_step_param), intent(in) :: ucd_step + type(time_data), intent(in) :: init_d +! + type(VIZ_step_params), intent(inout) :: viz_step + type(FEM_mesh_field_for_viz), intent(inout) :: FEM_viz + type(VIZ_mesh_field), intent(inout) :: pvr + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: istep_ucd +! +! -------------------------------- +! setup mesh information +! -------------------------------- +! + call mpi_input_mesh(FEM_viz%mesh_file_IO, nprocs, FEM_viz%geofem) +! + if(iflag_debug.gt.0) write(*,*) 'FEM_comm_initialization' + call FEM_comm_initialization(FEM_viz%geofem%mesh, m_SR) +! +! --------------------- +! + FEM_viz%ucd_in%nnod = FEM_viz%geofem%mesh%node%numnod + istep_ucd = IO_step_exc_zero_inc(init_d%i_time_step, ucd_step) + call sel_read_parallel_udt_param(istep_ucd, & + & FEM_viz%ucd_file_IO, FEM_viz%ucd_time, FEM_viz%ucd_in) + call alloc_phys_name_type_by_output(FEM_viz%ucd_in, & + & FEM_viz%field) +! + call add_field_in_viz_controls(FEM_viz%viz_fld_list, & + & FEM_viz%field) + call dealloc_field_lists_for_vizs(FEM_viz%viz_fld_list) +! + call alloc_phys_data(FEM_viz%geofem%mesh%node%numnod, & + & FEM_viz%field) +! +! --------------------- Connection information for PVR and fieldline +! --------------------- init for fieldline and PVR +! + if(iflag_debug.gt.0) write(*,*) 'init_FEM_to_VIZ_bridge' + call init_FEM_to_VIZ_bridge(elps_VIZ, viz_step, & + & FEM_viz%geofem, pvr, m_SR) + call calypso_mpi_barrier +! + end subroutine FEM_initialize_four_vizs +! +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! + subroutine FEM_analyze_four_vizs & + & (istep, ucd_step, time_d, FEM_viz, m_SR) +! + use output_parallel_ucd_file + use nod_phys_send_recv +! + integer(kind = kint), intent(in) :: istep + type(IO_step_param), intent(in) :: ucd_step +! + type(time_data), intent(inout) :: time_d + type(FEM_mesh_field_for_viz), intent(inout) :: FEM_viz + type(mesh_SR), intent(inout) :: m_SR +! + integer(kind = kint) :: istep_ucd +! +! + istep_ucd = IO_step_exc_zero_inc(istep, ucd_step) + call set_data_by_read_ucd(istep_ucd, FEM_viz%ucd_file_IO, & + & FEM_viz%ucd_time, FEM_viz%ucd_in, FEM_viz%field) + call copy_time_step_size_data(FEM_viz%ucd_time, time_d) +! + if (iflag_debug.gt.0) write(*,*) 'phys_send_recv_all' + call nod_fields_send_recv(FEM_viz%geofem%mesh, FEM_viz%field, & + & m_SR%v_sol, m_SR%SR_sig, m_SR%SR_r) +! + end subroutine FEM_analyze_four_vizs +! +! ---------------------------------------------------------------------- +! + end module FEM_analyzer_four_vizs diff --git a/src/programs/data_utilities/VIZ_only/Makefile b/src/programs/data_utilities/VIZ_only/Makefile index 7e836c4b..9d73256d 100644 --- a/src/programs/data_utilities/VIZ_only/Makefile +++ b/src/programs/data_utilities/VIZ_only/Makefile @@ -4,12 +4,22 @@ VIZ_PLUG_DIR = $$(DATA_UTILS_DIR)/VIZ_only +TARGET_FOUR_VIZS = utilities/four_vizualizations TARGET_PSF = utilities/sectioning TARGET_VTK_CONVERT = utilities/field_to_VTK TARGET_PSF_2_VTK = utilities/section_to_vtk SOURCES = $(shell ls *.f90) +MOD_FOUR_VIZS_PLUG = \ +main_four_visualizations.o \ +analyzer_four_vizs.o \ +FEM_analyzer_four_vizs.o \ +t_FEM_mesh_field_4_viz.o \ +t_control_data_four_vizs.o \ +t_field_list_for_vizs.o \ +input_control_four_vizs.o + MOD_PSF_PLUG = \ main_surface_rendering.o \ analyzer_psf.o \ @@ -41,18 +51,26 @@ dir_list: @echo 'VIZ_PLUG_DIR = $(VIZ_PLUG_DIR)' >> $(MAKENAME) target_list: + @echo 'TARGET_FOUR_VIZS = $$(BUILDDIR)/$(TARGET_FOUR_VIZS)' >> $(MAKENAME) @echo 'TARGET_PSF = $$(BUILDDIR)/$(TARGET_PSF)' >> $(MAKENAME) @echo 'TARGET_VTK_CONVERT = $$(BUILDDIR)/$(TARGET_VTK_CONVERT)' >> $(MAKENAME) - @echo 'TARGET_PSF_2_VTK = $$(BUILDDIR)/$(TARGET_PSF_2_VTK)' >> $(MAKENAME) + @echo 'TARGET_PSF_2_VTK = $$(BUILDDIR)/$(TARGET_PSF_2_VTK)' >> $(MAKENAME) @echo >> $(MAKENAME) target_task: @echo visualizer: \ + '$$(TARGET_FOUR_VIZS)' \ '$$(TARGET_PSF)' \ '$$(TARGET_VTK_CONVERT)' \ - '$$(TARGET_PSF_2_VTK)' \ + '$$(TARGET_PSF_2_VTK)' \ >> $(MAKENAME) @echo '' >> $(MAKENAME) + @echo '$$(TARGET_FOUR_VIZS): $$(MOD_FOUR_VIZS_PLUG)' \ + '$$(LIB_FILES_SPH_MHD)' >> $(MAKENAME) + @echo ' ''$$(F90)' '$$(F90OPTFLAGS)' '$$(F90CPPFLAGS)' \ + -o '$$(TARGET_FOUR_VIZS)' '$$(MOD_FOUR_VIZS_PLUG)' \ + '-L. $$(LIBS_SPH_MHD) $$(F90LIBS) $$(PNG_LIBS)' >> $(MAKENAME) + @echo '' >> $(MAKENAME) @echo '$$(TARGET_PSF): $$(MOD_PSF_PLUG)' \ '$$(LIB_FILES_SPH_MHD)' >> $(MAKENAME) @echo ' ''$$(F90)' '$$(F90OPTFLAGS)' '$$(F90CPPFLAGS)' \ @@ -75,6 +93,8 @@ target_task: lib_name: mod_list: + @echo MOD_FOUR_VIZS_PLUG= \\ >> $(MAKENAME) + @echo $(MOD_FOUR_VIZS_PLUG) >> $(MAKENAME) @echo MOD_PSF_PLUG= \\ >> $(MAKENAME) @echo $(MOD_PSF_PLUG) >> $(MAKENAME) @echo MOD_VTK_CONVERT_PLUG= \\ >> $(MAKENAME) diff --git a/src/programs/data_utilities/VIZ_only/Makefile.depends b/src/programs/data_utilities/VIZ_only/Makefile.depends index 23406221..aba3ab7a 100644 --- a/src/programs/data_utilities/VIZ_only/Makefile.depends +++ b/src/programs/data_utilities/VIZ_only/Makefile.depends @@ -1,19 +1,29 @@ +FEM_analyzer_four_vizs.o: $(VIZ_PLUG_DIR)/FEM_analyzer_four_vizs.f90 m_precision.o m_machine_parameter.o calypso_mpi.o t_step_parameter.o t_time_data.o t_FEM_mesh_field_4_viz.o t_ucd_data.o t_next_node_ele_4_node.o t_shape_functions.o t_jacobians.o t_file_IO_parameter.o t_field_list_for_vizs.o t_VIZ_step_parameter.o t_mesh_SR.o t_elapsed_labels_4_VIZ.o t_VIZ_mesh_field.o mpi_load_mesh_data.o nod_phys_send_recv.o parallel_FEM_mesh_init.o set_parallel_file_name.o set_ucd_data_to_type.o parallel_ucd_IO_select.o FEM_to_VIZ_bridge.o output_parallel_ucd_file.o + $(F90) -c $(F90OPTFLAGS) $< FEM_analyzer_viz_surf.o: $(VIZ_PLUG_DIR)/FEM_analyzer_viz_surf.f90 m_precision.o m_constants.o m_machine_parameter.o calypso_mpi.o t_time_data.o t_field_list_for_vizs.o t_VIZ_step_parameter.o t_IO_step_parameter.o t_FEM_mesh_field_4_viz.o t_mesh_SR.o mpi_load_mesh_data.o nod_phys_send_recv.o parallel_FEM_mesh_init.o set_parallel_file_name.o set_ucd_data_to_type.o parallel_ucd_IO_select.o const_element_comm_tables.o output_parallel_ucd_file.o $(F90) -c $(F90OPTFLAGS) $< analyzer_VTK_convert.o: $(VIZ_PLUG_DIR)/analyzer_VTK_convert.f90 m_precision.o m_work_time.o t_viz_VTK_convert.o t_VIZ_only_step_parameter.o t_control_data_section_only.o t_FEM_mesh_field_4_viz.o t_file_IO_parameter.o t_vector_for_solver.o t_elapsed_labels_4_SECTIONS.o FEM_analyzer_viz_surf.o t_mesh_SR.o calypso_mpi.o m_elapsed_labels_SEND_RECV.o input_control_section_only.o $(F90) -c $(F90OPTFLAGS) $< +analyzer_four_vizs.o: $(VIZ_PLUG_DIR)/analyzer_four_vizs.f90 m_precision.o m_machine_parameter.o m_work_time.o calypso_mpi.o t_control_data_four_vizs.o t_four_visualizers.o t_VIZ_only_step_parameter.o t_FEM_mesh_field_4_viz.o t_VIZ_mesh_field.o t_mesh_SR.o FEM_analyzer_four_vizs.o m_elapsed_labels_4_VIZ.o m_elapsed_labels_SEND_RECV.o input_control_four_vizs.o + $(F90) -c $(F90OPTFLAGS) $< analyzer_psf.o: $(VIZ_PLUG_DIR)/analyzer_psf.f90 m_precision.o m_work_time.o t_viz_sections.o t_VIZ_only_step_parameter.o t_control_data_section_only.o t_FEM_mesh_field_4_viz.o t_mesh_SR.o t_elapsed_labels_4_SECTIONS.o FEM_analyzer_viz_surf.o calypso_mpi.o m_elapsed_labels_SEND_RECV.o input_control_section_only.o $(F90) -c $(F90OPTFLAGS) $< +input_control_four_vizs.o: $(VIZ_PLUG_DIR)/input_control_four_vizs.f90 m_precision.o m_machine_parameter.o t_control_data_four_vizs.o t_FEM_mesh_field_4_viz.o t_VIZ_only_step_parameter.o calypso_mpi.o t_read_control_elements.o calypso_mpi_int.o bcast_4_platform_ctl.o bcast_4_time_step_ctl.o bcast_ctl_data_viz4.o bcast_control_arrays.o m_file_format_switch.o m_default_file_prefix.o set_control_platform_item.o set_control_platform_data.o parallel_ucd_IO_select.o + $(F90) -c $(F90OPTFLAGS) $< input_control_section_only.o: $(VIZ_PLUG_DIR)/input_control_section_only.f90 m_precision.o m_machine_parameter.o t_control_data_section_only.o t_FEM_mesh_field_4_viz.o t_VIZ_only_step_parameter.o calypso_mpi.o t_read_control_elements.o calypso_mpi_int.o bcast_4_platform_ctl.o bcast_4_time_step_ctl.o bcast_ctl_data_surfacings.o bcast_control_arrays.o t_viz_sections.o m_file_format_switch.o m_default_file_prefix.o set_control_platform_item.o set_control_platform_data.o parallel_ucd_IO_select.o $(F90) -c $(F90OPTFLAGS) $< main_VTK_convert.o: $(VIZ_PLUG_DIR)/main_VTK_convert.f90 m_precision.o calypso_mpi.o analyzer_VTK_convert.o $(F90) -c $(F90OPTFLAGS) $< +main_four_visualizations.o: $(VIZ_PLUG_DIR)/main_four_visualizations.f90 m_precision.o calypso_mpi.o analyzer_four_vizs.o + $(F90) -c $(F90OPTFLAGS) $< main_surface_rendering.o: $(VIZ_PLUG_DIR)/main_surface_rendering.f90 m_precision.o calypso_mpi.o analyzer_psf.o $(F90) -c $(F90OPTFLAGS) $< psf_file_to_VTK.o: $(VIZ_PLUG_DIR)/psf_file_to_VTK.f90 m_precision.o m_constants.o m_field_file_format.o m_section_file_extensions.o t_file_IO_parameter.o t_ucd_data.o ucd_IO_select.o $(F90) -c $(F90OPTFLAGS) $< t_FEM_mesh_field_4_viz.o: $(VIZ_PLUG_DIR)/t_FEM_mesh_field_4_viz.f90 m_precision.o t_mesh_data.o t_phys_data.o t_field_list_for_vizs.o t_file_IO_parameter.o t_time_data.o t_ucd_data.o $(F90) -c $(F90OPTFLAGS) $< +t_control_data_four_vizs.o: $(VIZ_PLUG_DIR)/t_control_data_four_vizs.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_4_platforms.o t_ctl_data_4_time_steps.o t_control_data_viz4.o t_control_array_character3.o skip_comment_f.o viz4_step_ctls_to_time_ctl.o delete_data_files.o ctl_data_platforms_IO.o ctl_data_4_time_steps_IO.o ctl_data_four_vizs_IO.o write_control_elements.o + $(F90) -c $(F90OPTFLAGS) $< t_control_data_section_only.o: $(VIZ_PLUG_DIR)/t_control_data_section_only.f90 m_precision.o m_machine_parameter.o t_read_control_elements.o t_ctl_data_4_platforms.o t_ctl_data_4_time_steps.o t_control_data_surfacings.o t_control_array_character3.o skip_comment_f.o delete_data_files.o ctl_data_platforms_IO.o ctl_data_4_time_steps_IO.o control_data_surfacing_IO.o write_control_elements.o $(F90) -c $(F90OPTFLAGS) $< t_field_list_for_vizs.o: $(VIZ_PLUG_DIR)/t_field_list_for_vizs.f90 m_precision.o m_machine_parameter.o t_control_array_character3.o t_phys_data.o set_each_field_name.o diff --git a/src/programs/data_utilities/VIZ_only/analyzer_four_vizs.f90 b/src/programs/data_utilities/VIZ_only/analyzer_four_vizs.f90 new file mode 100644 index 00000000..2b954409 --- /dev/null +++ b/src/programs/data_utilities/VIZ_only/analyzer_four_vizs.f90 @@ -0,0 +1,114 @@ +!analyzer_four_vizs.f90 +! module analyzer_four_vizs +! +! Written by H. Matsui on July, 2006 +! +! subroutine initialize_four_vizs +! subroutine analyze_four_vizs +! + module analyzer_four_vizs +! + use m_precision + use m_machine_parameter + use m_work_time + use calypso_mpi +! + use t_control_data_four_vizs + use t_four_visualizers + use t_VIZ_only_step_parameter + use t_FEM_mesh_field_4_viz + use t_VIZ_mesh_field + use t_mesh_SR + use FEM_analyzer_four_vizs + use m_elapsed_labels_4_VIZ +! + implicit none +! + character(len = kchara), parameter, private & + & :: fname_viz_ctl = "control_viz" +! +!> Structure for time stepping parameters +!! with field and visualization + type(time_step_param_w_viz), save :: t_VIZ4 +! +!> Structure of control data for visualization + type(control_data_four_vizs), save :: vizs_ctl4 +!> Structure of FEM mesh and field structures + type(FEM_mesh_field_for_viz), save :: FEM_viz4 +!> Structure of work area for mesh communications + type(mesh_SR) :: m_SR14 +!> Structure of data for visualization + type(VIZ_mesh_field), save :: VIZ_DAT4 +!> Structure of viualization modules + type(four_visualize_modules), save :: vizs_m4 +! +! --------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine initialize_four_vizs +! + use m_elapsed_labels_SEND_RECV + use input_control_four_vizs +! + call init_elapse_time_by_TOTAL + call set_elpsed_label_4_VIZ(flag_detailed1, elps_VIZ1, elps1) + call elpsed_label_field_send_recv + + if(iflag_TOT_time) call start_elapsed_time(ied_total_elapsed) +! +! Load controls + if (iflag_debug.gt.0) write(*,*) 's_input_control_four_vizs' + call s_input_control_four_vizs(fname_viz_ctl, vizs_ctl4, & + & FEM_viz4, t_VIZ4) +! +! FEM Initialization + if(iflag_debug .gt. 0) write(*,*) 'FEM_initialize_four_vizs' + call FEM_initialize_four_vizs & + & (elps_VIZ1, t_VIZ4%init_d, t_VIZ4%ucd_step, & + & t_VIZ4%viz_step, FEM_viz4, VIZ_DAT4, m_SR14) +! +! VIZ Initialization + if(iflag_debug .gt. 0) write(*,*) 'init_four_visualize' + call init_four_visualize(elps_VIZ1, t_VIZ4%viz_step, & + & FEM_viz4%geofem, FEM_viz4%field, VIZ_DAT4, & + & vizs_ctl4%viz4_ctl, vizs_m4, m_SR14) + call dealloc_viz4_controls(vizs_ctl4%viz4_ctl) +! + end subroutine initialize_four_vizs +! +! --------------------------------------------------------------------- +! + subroutine analyze_four_vizs +! + integer(kind=kint ) :: i_step +! +! + do i_step = t_VIZ4%init_d%i_time_step, t_VIZ4%finish_d%i_end_step + if(output_IO_flag(i_step,t_VIZ4%ucd_step) .eqv. .FALSE.) cycle + if(iflag_vizs_w_fix_step(i_step, t_VIZ4%viz_step) & + & .eqv. .FALSE.) cycle +! +! Load field data + if(iflag_debug .gt. 0) write(*,*) & + & 'FEM_analyze_four_vizs', i_step + call FEM_analyze_four_vizs & + & (i_step, t_VIZ4%ucd_step, t_VIZ4%time_d, FEM_viz4, m_SR14) +! +! Rendering + if(iflag_debug .gt. 0) write(*,*) 'visualize_four', i_step + call istep_viz_w_fix_dt(i_step, t_VIZ4%viz_step) + call visualize_four(elps_VIZ1, t_VIZ4%viz_step, t_VIZ4%time_d, & + & FEM_viz4%geofem, FEM_viz4%field, VIZ_DAT4, vizs_m4, m_SR14) + end do +! + if(iflag_TOT_time) call end_elapsed_time(ied_total_elapsed) + call output_elapsed_times +! + end subroutine analyze_four_vizs +! +! --------------------------------------------------------------------- +! + end module analyzer_four_vizs diff --git a/src/programs/data_utilities/VIZ_only/input_control_four_vizs.f90 b/src/programs/data_utilities/VIZ_only/input_control_four_vizs.f90 new file mode 100644 index 00000000..2a15bd9d --- /dev/null +++ b/src/programs/data_utilities/VIZ_only/input_control_four_vizs.f90 @@ -0,0 +1,142 @@ +!>@file input_control_four_vizs.f90 +!!@brief module input_control_four_vizs +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +!! +!>@brief Control data for visualization without repartitioning +!! +!!@verbatim +!! subroutine s_input_control_four_vizs & +!! & (ctl_file_name, viz4_ctl, FEM_viz, t_viz_param) +!! character(len = kchara), intent(in) :: ctl_file_name +!! type(control_data_four_vizs), intent(inout) :: viz4_ctl +!! type(FEM_mesh_field_for_viz), intent(inout) :: FEM_viz +!! type(time_step_param_w_viz), intent(inout) :: t_viz_param +!! +!! subroutine bcast_four_vizs_control_data(viz4_ctl) +!! type(control_data_four_vizs), intent(inout) :: viz4_ctl +!! subroutine set_ctl_params_four_vizs & +!! & (pvr_vizs_c, FEM_viz, t_viz_param, ierr) +!! type(control_data_four_vizs), intent(in) :: pvr_vizs_c +!! type(FEM_mesh_field_for_viz), intent(inout) :: FEM_viz +!! type(time_step_param_w_viz), intent(inout) :: t_viz_param +!!@endverbatim +! + module input_control_four_vizs +! + use m_precision + use m_machine_parameter + use t_control_data_four_vizs + use t_FEM_mesh_field_4_viz + use t_VIZ_only_step_parameter +! + use calypso_mpi +! + implicit none +! + private :: bcast_four_vizs_control_data, set_ctl_params_four_vizs +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine s_input_control_four_vizs & + & (ctl_file_name, viz4_ctl, FEM_viz, t_viz_param) +! + use t_read_control_elements +! + character(len = kchara), intent(in) :: ctl_file_name + type(control_data_four_vizs), intent(inout) :: viz4_ctl + type(FEM_mesh_field_for_viz), intent(inout) :: FEM_viz + type(time_step_param_w_viz), intent(inout) :: t_viz_param +! + integer(kind = kint) :: ierr + type(buffer_for_control) :: c_buf1 +! +! + c_buf1%level = 0 + if(my_rank .eq. 0) then + call read_control_file_four_vizs(ctl_file_name, & + & viz4_ctl, c_buf1) + end if + call bcast_four_vizs_control_data(viz4_ctl) +! + if(c_buf1%iend .gt. 0) then + call calypso_MPI_abort(viz4_ctl%i_viz_only_file, & + & 'control file is broken') + end if +! +! set control data + call set_ctl_params_four_vizs(viz4_ctl, FEM_viz, & + & t_viz_param, ierr) + if(ierr .gt. 0) call calypso_MPI_abort(ierr, e_message) +! + end subroutine s_input_control_four_vizs +! +! -------------------------------------------------------------------- +! -------------------------------------------------------------------- +! + subroutine bcast_four_vizs_control_data(viz4_ctl) +! + use calypso_mpi_int + use bcast_4_platform_ctl + use bcast_4_time_step_ctl + use bcast_ctl_data_viz4 + use bcast_control_arrays +! + type(control_data_four_vizs), intent(inout) :: viz4_ctl +! +! + call bcast_ctl_array_c3(viz4_ctl%viz_field_ctl) + call bcast_ctl_data_4_platform(viz4_ctl%viz_plt) + call bcast_ctl_data_4_time_step(viz4_ctl%t_viz_ctl) +! + call bcast_viz4_controls(viz4_ctl%viz4_ctl) +! + call calypso_mpi_bcast_one_int(viz4_ctl%i_viz_only_file, 0) +! + end subroutine bcast_four_vizs_control_data +! +! -------------------------------------------------------------------- +! + subroutine set_ctl_params_four_vizs & + & (pvr_vizs_c, FEM_viz, t_viz_param, ierr) +! + use t_control_data_four_vizs + use t_VIZ_only_step_parameter +! + use m_file_format_switch + use m_default_file_prefix + use set_control_platform_item + use set_control_platform_data + use parallel_ucd_IO_select +! + type(control_data_four_vizs), intent(in) :: pvr_vizs_c +! + type(FEM_mesh_field_for_viz), intent(inout) :: FEM_viz + type(time_step_param_w_viz), intent(inout) :: t_viz_param + integer(kind = kint), intent(inout) :: ierr +! +! + call turn_off_debug_flag_by_ctl(my_rank, pvr_vizs_c%viz_plt) + call set_control_smp_def(my_rank, pvr_vizs_c%viz_plt) + call set_control_parallel_mesh(pvr_vizs_c%viz_plt, & + & FEM_viz%mesh_file_IO) + call set_merged_ucd_file_define(pvr_vizs_c%viz_plt, & + & FEM_viz%ucd_file_IO) +! + call init_viz_field_list_control(pvr_vizs_c%viz_field_ctl, & + & FEM_viz%viz_fld_list) +! + call set_fixed_t_step_params_w_viz & + & (pvr_vizs_c%t_viz_ctl, t_viz_param, ierr, e_message) + call copy_delta_t(t_viz_param%init_d, t_viz_param%time_d) +! + end subroutine set_ctl_params_four_vizs +! +! ---------------------------------------------------------------------- +! + end module input_control_four_vizs diff --git a/src/programs/data_utilities/VIZ_only/main_four_visualizations.f90 b/src/programs/data_utilities/VIZ_only/main_four_visualizations.f90 new file mode 100644 index 00000000..d80718a2 --- /dev/null +++ b/src/programs/data_utilities/VIZ_only/main_four_visualizations.f90 @@ -0,0 +1,35 @@ +!>@file main_four_visualizations.f90 +!!@brief program kemo_four_visualizations +!! +!!@author H. Matsui +!!@date Programmed in Mar., 2000 (ver 1.0) +!! Modified in May, 2003 +!! Modified in July 2006 +!! +!> @brief Main program for four data visualization +!! +!!@verbatim +!! main routine for GeoFEM/Tiger version on mar. 2000 (ver 1.0) +!! main routine for Kemo's MHD on May, 2003 (ver 2.0) +!! main routine for Kemo's MHD connect to vizs on July 2006 (ver 3.0) +!!@endverbatim + program kemo_four_visualizations +! + use m_precision +! + use calypso_mpi + use analyzer_four_vizs +! + implicit none +! +! + call calypso_MPI_init +! + call initialize_four_vizs + call analyze_four_vizs +! + call calypso_MPI_finalize +! + stop '***** program finished *****' +! + end program kemo_four_visualizations diff --git a/src/programs/data_utilities/VIZ_only/t_control_data_four_vizs.f90 b/src/programs/data_utilities/VIZ_only/t_control_data_four_vizs.f90 new file mode 100644 index 00000000..424c99d8 --- /dev/null +++ b/src/programs/data_utilities/VIZ_only/t_control_data_four_vizs.f90 @@ -0,0 +1,257 @@ +!>@file t_control_data_four_vizs.f90 +!!@brief module t_control_data_four_vizs +!! +!!@author H. Matsui +!!@date Programmed in July, 2006 +!! +!>@brief Control data for visualization without repartitioning +!! +!!@verbatim +!! subroutine read_control_file_four_vizs(file_name, viz4_c, c_buf) +!! subroutine write_control_file_four_vizs(file_name, viz4_c) +!! subroutine dealloc_four_vizs_control_data(viz4_c) +!! character(len = kchara), intent(in) :: file_name +!! type(control_data_four_vizs), intent(inout) :: viz4_c +!! +!! -------------------------------------------------------------------- +!! Example of control block +!! +!! begin visualizer +!! begin data_files_def +!! ... +!! end data_files_def +!! +!! begin time_step_ctl +!! ... +!! end time_step_ctl +!! +!! begin visual_control +!! ... +!! end visual_control +!! end visualizer +!! ------------------------------------------------------------------- +!!@endverbatim +! + module t_control_data_four_vizs +! + use m_precision + use m_machine_parameter + use t_read_control_elements + use t_ctl_data_4_platforms + use t_ctl_data_4_time_steps + use t_control_data_viz4 + use t_control_array_character3 +! + implicit none +! +! + integer(kind = kint), parameter :: viz_ctl_file_code = 11 +! +!> Structure for visulization program + type control_data_four_vizs +!> Block name + character(len=kchara) :: block_name = 'visualizer' +!> Structure for file settings + type(platform_data_control) :: viz_plt +!> Structure for time stepping control + type(time_data_control) :: t_viz_ctl +! +!> Structures of visualization controls + type(vis4_controls) :: viz4_ctl +! +!> Structures of field used in visualization + type(ctl_array_c3) :: viz_field_ctl +! + integer(kind=kint) :: i_viz_only_file = 0 + end type control_data_four_vizs +! +! Top level +! + character(len=kchara), parameter, private & + & :: hd_viz_only_file = 'visualizer' +! + character(len=kchara), parameter, private & + & :: hd_platform = 'data_files_def' + character(len=kchara), parameter, private & + & :: hd_time_step = 'time_step_ctl' +! + character(len=kchara), parameter, private & + & :: hd_viz_control = 'visual_control' +! + private :: viz_ctl_file_code + private :: read_four_vizs_control_data + private :: write_four_vizs_control_data +! +! -------------------------------------------------------------------- +! + contains +! +! --------------------------------------------------------------------- +! + subroutine read_control_file_four_vizs(file_name, viz4_c, c_buf) +! + use skip_comment_f + use viz4_step_ctls_to_time_ctl +! + character(len = kchara), intent(in) :: file_name + type(control_data_four_vizs), intent(inout) :: viz4_c + type(buffer_for_control), intent(inout) :: c_buf +! +! + c_buf%level = c_buf%level + 1 + open (viz_ctl_file_code, file=file_name, status='old') + do + call load_one_line_from_control(viz_ctl_file_code, & + & hd_viz_only_file, c_buf) + if(c_buf%iend .gt. 0) exit +! + call read_four_vizs_control_data & + & (viz_ctl_file_code, hd_viz_only_file, viz4_c, c_buf) + if(viz4_c%i_viz_only_file .gt. 0) exit + end do + close(viz_ctl_file_code) +! + c_buf%level = c_buf%level - 1 + if(c_buf%iend .gt. 0) return +! + call s_viz4_step_ctls_to_time_ctl & + & (viz4_c%viz4_ctl, viz4_c%t_viz_ctl) +! + viz4_c%viz_field_ctl%num = 0 + call alloc_control_array_c3(viz4_c%viz_field_ctl) + call add_fields_viz4_to_fld_ctl(viz4_c%viz4_ctl, & + & viz4_c%viz_field_ctl) +! + end subroutine read_control_file_four_vizs +! +! -------------------------------------------------------------------- +! + subroutine write_control_file_four_vizs(file_name, viz4_c) +! + use delete_data_files +! + character(len = kchara), intent(in) :: file_name + type(control_data_four_vizs), intent(inout) :: viz4_c + integer(kind = kint) :: level1 +! +! + if(check_file_exist(file_name)) then + write(*,*) 'File ', trim(file_name), ' exist. Continue?' + read(*,*) + end if +! + open (viz_ctl_file_code, file=file_name) + level1 = 0 + call write_four_vizs_control_data & + & (viz_ctl_file_code, hd_viz_only_file, viz4_c, level1) + close(viz_ctl_file_code) +! + end subroutine write_control_file_four_vizs +! +! -------------------------------------------------------------------- +! -------------------------------------------------------------------- +! + subroutine read_four_vizs_control_data & + & (id_control, hd_block, viz4_c, c_buf) +! + use skip_comment_f + use ctl_data_platforms_IO + use ctl_data_4_time_steps_IO + use ctl_data_four_vizs_IO +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block +! + type(control_data_four_vizs), intent(inout) :: viz4_c + type(buffer_for_control), intent(inout) :: c_buf +! +! + if(viz4_c%i_viz_only_file .gt. 0) return + call init_platforms_labels(hd_platform, viz4_c%viz_plt) + call init_ctl_time_step_label(hd_time_step, viz4_c%t_viz_ctl) + if(check_begin_flag(c_buf, hd_block) .eqv. .FALSE.) return + do + call load_one_line_from_control(id_control, hd_block, c_buf) + if(c_buf%iend .gt. 0) exit + if(check_end_flag(c_buf, hd_block)) exit +! + call read_control_platforms & + & (id_control, hd_platform, viz4_c%viz_plt, c_buf) + call read_control_time_step_data & + & (id_control, hd_time_step, viz4_c%t_viz_ctl, c_buf) +! + call s_read_viz4_controls(id_control, hd_viz_control, & + & viz4_c%viz4_ctl, c_buf) + end do + viz4_c%i_viz_only_file = 1 +! + end subroutine read_four_vizs_control_data +! +! -------------------------------------------------------------------- +! + subroutine write_four_vizs_control_data & + & (id_control, hd_block, viz4_c, level) +! + use skip_comment_f + use ctl_data_platforms_IO + use ctl_data_4_time_steps_IO + use ctl_data_four_vizs_IO + use write_control_elements +! + integer(kind = kint), intent(in) :: id_control + character(len=kchara), intent(in) :: hd_block + type(control_data_four_vizs), intent(in) :: viz4_c +! + integer(kind = kint), intent(inout) :: level +! +! + if(viz4_c%i_viz_only_file .le. 0) return +! + level = write_begin_flag_for_ctl(id_control, level, hd_block) + call write_control_platforms & + & (id_control, hd_platform, viz4_c%viz_plt, level) + call write_control_time_step_data & + & (id_control, viz4_c%t_viz_ctl, level) +! + call write_viz4_controls(id_control, viz4_c%viz4_ctl, level) + level = write_end_flag_for_ctl(id_control, level, hd_block) +! + end subroutine write_four_vizs_control_data +! +! -------------------------------------------------------------------- +! + subroutine init_four_vizs_control_label(hd_block, viz4_c) +! + use ctl_data_platforms_IO + use ctl_data_4_time_steps_IO + use ctl_data_four_vizs_IO +! + character(len=kchara), intent(in) :: hd_block + type(control_data_four_vizs), intent(inout) :: viz4_c +! +! + viz4_c%block_name = hd_block + call init_platforms_labels(hd_platform, viz4_c%viz_plt) + call init_ctl_time_step_label(hd_time_step, viz4_c%t_viz_ctl) + call init_viz4_ctl_label(hd_viz_control, viz4_c%viz4_ctl) +! + end subroutine init_four_vizs_control_label +! +! -------------------------------------------------------------------- +! + subroutine dealloc_four_vizs_control_data(viz4_c) +! + type(control_data_four_vizs), intent(inout) :: viz4_c +! + call dealloc_control_array_c3(viz4_c%viz_field_ctl) + call reset_control_platforms(viz4_c%viz_plt) + call reset_ctl_data_4_time_step(viz4_c%t_viz_ctl) +! + viz4_c%t_viz_ctl%i_tstep = 0 + viz4_c%i_viz_only_file = 0 +! + end subroutine dealloc_four_vizs_control_data +! +! -------------------------------------------------------------------- +! + end module t_control_data_four_vizs diff --git a/tests/Makefile b/tests/Makefile index 32d4ab6c..2640498c 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -34,7 +34,8 @@ Dynamobench_case1 \ Dynamobench_case2 \ Dynamobench_case2_cont \ snapshot_test \ -heterogineous_temp +heterogineous_temp \ +Rendering_tests # # ------------------------------------------------------------------------- diff --git a/tests/Rendering_tests/ISOSURFACE_defs/ctl_iso_temp b/tests/Rendering_tests/ISOSURFACE_defs/ctl_iso_temp new file mode 100644 index 00000000..d58a8a28 --- /dev/null +++ b/tests/Rendering_tests/ISOSURFACE_defs/ctl_iso_temp @@ -0,0 +1,26 @@ +! +begin isosurface_ctl + isosurface_file_prefix 'isosurfaces/iso_temp' + iso_output_type 'VTK_gz' +! + begin isosurf_define + isosurf_field temperature + isosurf_component scalar + isosurf_value 0.3 +! + array isosurf_area_ctl + isosurf_area_ctl outer_core end + end array isosurf_area_ctl + end isosurf_define +! + begin field_on_isosurf +! result_type constant +! result_value 0.7 + array output_field + output_field velocity vector end + output_field magnetic_field radial end + end array output_field + end field_on_isosurf +! +end isosurface_ctl + diff --git a/tests/Rendering_tests/MAP_defs/ctl_map_cmb_Br b/tests/Rendering_tests/MAP_defs/ctl_map_cmb_Br new file mode 100644 index 00000000..dcf340ff --- /dev/null +++ b/tests/Rendering_tests/MAP_defs/ctl_map_cmb_Br @@ -0,0 +1,48 @@ +! +! +! example of control for Kemo's surface rendering +! +begin map_rendering_ctl + map_image_prefix 'maps/map_cmb_Br' + map_image_format PNG +! + output_field magnetic_field + output_component r +! + begin colormap_ctl + colormap_ctl rainbow +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl -2.0 0.0 + color_table_ctl 0.0 0.5 + color_table_ctl 2.0 1.0 + end array color_table_ctl + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_position_ctl 'bottom' + colorbar_scale_ctl ON + iflag_zeromarker OFF + colorbar_range -2.0 2.0 + font_size_ctl 2 + num_grid_ctl 1 +! + time_label_switch On + map_grid_switch On + end colorbar_ctl +! + begin section_ctl + file surface_define 'SURFACE_defs/ctl_section_CMB' +! + zeroline_switch_ctl On + isoline_width_ctl 1.5 + grid_width_ctl 1.0 + tangent_cylinder_switch_ctl On + inner_radius_ctl 0.53846 + outer_radius_ctl 1.53846 + end section_ctl +! + file map_projection_ctl 'view_defines/control_map_view' +end map_rendering_ctl diff --git a/tests/Rendering_tests/MAP_defs/ctl_map_cmb_T b/tests/Rendering_tests/MAP_defs/ctl_map_cmb_T new file mode 100644 index 00000000..95449940 --- /dev/null +++ b/tests/Rendering_tests/MAP_defs/ctl_map_cmb_T @@ -0,0 +1,48 @@ +! +! +! example of control for Kemo's surface rendering +! +begin map_rendering_ctl + map_image_prefix 'maps/map_cmb_T' + map_image_format PNG +! + output_field temperature + output_component scalar +! + begin colormap_ctl + colormap_ctl rainbow +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl 0.0 0.0 + color_table_ctl 0.25 0.5 + color_table_ctl 0.5 1.0 + end array color_table_ctl + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_position_ctl 'bottom' + colorbar_scale_ctl ON + iflag_zeromarker OFF + colorbar_range 0.0 0.5 + font_size_ctl 1 + num_grid_ctl 2 +! + time_label_switch On + map_grid_switch On + end colorbar_ctl +! + begin section_ctl + file surface_define 'SURFACE_defs/ctl_section_CMB' +! + zeroline_switch_ctl On + isoline_width_ctl 1.5 + grid_width_ctl 1.0 + tangent_cylinder_switch_ctl On + inner_radius_ctl 0.53846 + outer_radius_ctl 1.53846 + end section_ctl +! + file map_projection_ctl 'view_defines/control_map_view' +end map_rendering_ctl diff --git a/tests/Rendering_tests/MAP_defs/ctl_map_line_cmb_Br b/tests/Rendering_tests/MAP_defs/ctl_map_line_cmb_Br new file mode 100644 index 00000000..bb526b1b --- /dev/null +++ b/tests/Rendering_tests/MAP_defs/ctl_map_line_cmb_Br @@ -0,0 +1,53 @@ +! +! +! example of control for Kemo's surface rendering +! +begin map_rendering_ctl + map_image_prefix 'maps/map_cmb_Br_line' + map_image_format PNG +! +! output_field magnetic_field +! output_component r +! + isoline_field magnetic_field + isoline_component r +! + begin colormap_ctl + colormap_ctl rainbow +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl -4.0 0.0 + color_table_ctl 0.0 0.5 + color_table_ctl 4.0 1.0 + end array color_table_ctl + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_position_ctl 'bottom' + colorbar_scale_ctl ON + iflag_zeromarker ON + colorbar_range -4.0 4.0 + font_size_ctl 2 + num_grid_ctl 0 +! + time_label_switch On + map_grid_switch On + end colorbar_ctl +! + begin section_ctl + file surface_define 'SURFACE_defs/ctl_section_CMB' +! + isoline_color_mode color + isoline_number_ctl 11 + zeroline_switch_ctl On + isoline_width_ctl 1.5 + grid_width_ctl 1.0 + tangent_cylinder_switch_ctl On + inner_radius_ctl 0.53846 + outer_radius_ctl 1.53846 + end section_ctl +! + file map_projection_ctl 'view_defines/control_map_view' +end map_rendering_ctl diff --git a/tests/Rendering_tests/MAP_defs/ctl_map_line_cmb_T b/tests/Rendering_tests/MAP_defs/ctl_map_line_cmb_T new file mode 100644 index 00000000..b6617804 --- /dev/null +++ b/tests/Rendering_tests/MAP_defs/ctl_map_line_cmb_T @@ -0,0 +1,52 @@ +! +! +! example of control for Kemo's surface rendering +! +begin map_rendering_ctl + map_image_prefix 'maps/map_cmb_T_line' + map_image_format PNG +! + output_field temperature + output_component scalar +! + begin colormap_ctl + colormap_ctl rainbow +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl 0.0 0.0 + color_table_ctl 0.25 0.5 + color_table_ctl 0.5 1.0 + end array color_table_ctl + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_position_ctl 'bottom' + colorbar_scale_ctl ON + iflag_zeromarker OFF + colorbar_range 0.0 0.5 + font_size_ctl 1 + num_grid_ctl 2 +! + time_label_switch On + map_grid_switch On + end colorbar_ctl +! + begin section_ctl + file surface_define 'SURFACE_defs/ctl_section_CMB' +! + zeroline_switch_ctl On + isoline_switch_ctl On + isoline_color_mode black + isoline_number_ctl 11 + isoline_width_ctl 1.5 + grid_width_ctl 1.0 +! + tangent_cylinder_switch_ctl On + inner_radius_ctl 0.53846 + outer_radius_ctl 1.53846 + end section_ctl +! + file map_projection_ctl 'view_defines/control_map_view' +end map_rendering_ctl diff --git a/tests/Rendering_tests/MAP_defs/ctl_zm_yz_magne b/tests/Rendering_tests/MAP_defs/ctl_zm_yz_magne new file mode 100644 index 00000000..40902971 --- /dev/null +++ b/tests/Rendering_tests/MAP_defs/ctl_zm_yz_magne @@ -0,0 +1,54 @@ +! +! +! example of control for Kemo's surface rendering +! +begin map_rendering_ctl + map_image_prefix 'maps/zm_yz_magne' + map_image_format PNG +! + output_field magnetic_field + output_component phi +! + isoline_field stream_pol_magne + isoline_component phi +! + begin colormap_ctl + colormap_mode_ctl blue_to_red + background_color_ctl 1.0 1.0 1.0 +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl -0.5 0.0 + color_table_ctl 0.0 0.5 + color_table_ctl 0.5 1.0 + end array color_table_ctl + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_position_ctl 'right' + colorbar_scale_ctl ON + iflag_zeromarker OFF + colorbar_range -0.5 0.5 + font_size_ctl 2 + num_grid_ctl 3 +! + time_label_switch On + map_grid_switch On + end colorbar_ctl +! + begin section_ctl + file surface_define 'SURFACE_defs/ctl_section_zm' +! + isoline_color_mode white + isoline_number_ctl 11 + zeroline_switch_ctl On + isoline_width_ctl 1.5 + grid_width_ctl 1.0 + tangent_cylinder_switch_ctl On + inner_radius_ctl 0.53846 + outer_radius_ctl 1.53846 + end section_ctl +! + file map_projection_ctl 'view_defines/control_zm_view' +end map_rendering_ctl diff --git a/tests/Rendering_tests/MAP_defs/ctl_zm_yz_velo b/tests/Rendering_tests/MAP_defs/ctl_zm_yz_velo new file mode 100644 index 00000000..28940bd2 --- /dev/null +++ b/tests/Rendering_tests/MAP_defs/ctl_zm_yz_velo @@ -0,0 +1,54 @@ +! +! +! example of control for Kemo's surface rendering +! +begin map_rendering_ctl + map_image_prefix 'maps/zm_yz_velo' + map_image_format PNG +! + output_field velocity + output_component phi +! + isoline_field stream_pol_velo + isoline_component phi +! + begin colormap_ctl + colormap_mode_ctl blue_to_red + background_color_ctl 1.0 1.0 1.0 +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl -20.0 0.0 + color_table_ctl 0.0 0.5 + color_table_ctl 20.0 1.0 + end array color_table_ctl + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_position_ctl 'right' + colorbar_scale_ctl ON + iflag_zeromarker OFF + colorbar_range -10.0 10.0 + font_size_ctl 2 + num_grid_ctl 3 +! + time_label_switch On + map_grid_switch On + end colorbar_ctl +! + begin section_ctl + file surface_define 'SURFACE_defs/ctl_section_zm' +! + isoline_color_mode white + isoline_number_ctl 11 + isoline_width_ctl 1.5 + grid_width_ctl 1.0 + zeroline_switch_ctl On + tangent_cylinder_switch_ctl On + inner_radius_ctl 0.53846 + outer_radius_ctl 1.53846 + end section_ctl +! + file map_projection_ctl 'view_defines/control_zm_view' +end map_rendering_ctl diff --git a/tests/Rendering_tests/Makefile b/tests/Rendering_tests/Makefile new file mode 100644 index 00000000..52167deb --- /dev/null +++ b/tests/Rendering_tests/Makefile @@ -0,0 +1,37 @@ +# +# Makefile for Kemo's Dynamo toolkit +# Written by H. Matsui +# +SHELL = /bin/sh +# +# directories of Kemo's Dynamo toolkit +# +SRCDIR = /Users/matsui/src_kemo +# +MHDDIR = $(SRCDIR)/MHD +BUILDDIR= $(SRCDIR)/bin +TESTDIR= $(SRCDIR)/tests +# +# MPI settings +# +MPICHDIR = +MPICHLIBDIR = $(MPICHDIR)/lib +MPICHBINDIR = $(MPICHDIR)/bin +MPICHINCDIR = +MPILIBS = +# + +all: test + +test: clean + $(MPIRUN) -np 6 $(BUILDDIR)/sph_mhd + +clean: + rm -f *.dat *.txt + rm -f sections/*.gz + rm -f isosurfaces/*.gz + rm -f */*.png + rm -f */*.dat + rm -f */*.dat.gz + +distclean: clean diff --git a/tests/Rendering_tests/PVR_defs/control_lights b/tests/Rendering_tests/PVR_defs/control_lights new file mode 100644 index 00000000..1410ac4e --- /dev/null +++ b/tests/Rendering_tests/PVR_defs/control_lights @@ -0,0 +1,16 @@ +!! +! +! example of control for lighting parameter for PVR +! + begin lighting_ctl + array position_of_lights + position_of_lights -10.0 -10.0 10.0 end + position_of_lights -10.0 10.0 -10.0 end + position_of_lights -10.0 0.0 -10.0 end + end array position_of_lights +! + ambient_coef_ctl 0.5 + diffuse_coef_ctl 0.7 + specular_coef_ctl 0.9 + end lighting_ctl + diff --git a/tests/Rendering_tests/PVR_defs/ctl_pvr_Bpole b/tests/Rendering_tests/PVR_defs/ctl_pvr_Bpole new file mode 100644 index 00000000..03d5cd7f --- /dev/null +++ b/tests/Rendering_tests/PVR_defs/ctl_pvr_Bpole @@ -0,0 +1,65 @@ +!! +! +! example of control for Kemo's volume rendering +! +begin volume_rendering (BMP or PNG) + pvr_file_head 'pvr/pvr_Bpole' + pvr_output_type PNG +! image_tranceparency transparent +! + output_field magnetic_field + output_component magnitude +! + begin plot_area_ctl + array chosen_ele_grp_ctl + chosen_ele_grp_ctl all end + end array chosen_ele_grp_ctl +! + array surface_enhanse_ctl + surface_enhanse_ctl ICB reverse_surface 0.3 + surface_enhanse_ctl CMB reverse_surface 0.1 + end array surface_enhanse_ctl + end plot_area_ctl +! + begin colormap_ctl + colormap_mode_ctl rainbow +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl 0.0e+01 0.0 + color_table_ctl 0.5e+01 0.5 + color_table_ctl 1.0e+01 1.0 + end array color_table_ctl +! + opacity_style_ctl point_linear + array linear_opacity_ctl + linear_opacity_ctl 0.0e+00 0.001 + linear_opacity_ctl 0.1e+00 0.01 + linear_opacity_ctl 0.2e+01 0.015 + linear_opacity_ctl 0.6e+01 0.02 + linear_opacity_ctl 0.7e+01 0.05 + linear_opacity_ctl 0.8e+01 0.1 + linear_opacity_ctl 0.9e+01 0.3 + linear_opacity_ctl 1.0e+01 0.4 + end array linear_opacity_ctl + constant_opacity_ctl 0.0001 +! + range_min_ctl 0.0e+00 + range_max_ctl 1.0e+01 + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_scale_ctl ON + iflag_zeromarker OFF + colorbar_range 0.0e+00 1.0e+01 + font_size_ctl 1 + num_grid_ctl 4 +! + axis_label_switch ON + end colorbar_ctl +! + file lighting_ctl 'PVR_defs/control_lights' + file view_transform_ctl 'view_defines/control_pole' +end volume_rendering + diff --git a/tests/Rendering_tests/PVR_defs/ctl_pvr_Bz b/tests/Rendering_tests/PVR_defs/ctl_pvr_Bz new file mode 100644 index 00000000..4b4a441e --- /dev/null +++ b/tests/Rendering_tests/PVR_defs/ctl_pvr_Bz @@ -0,0 +1,77 @@ +! +! +! example of control for Kemo's volume rendering +! +begin volume_rendering (BMP or PNG) + pvr_file_head 'pvr/pvr_Bz' + pvr_output_type PNG +! image_tranceparency transparent +! + output_field magnetic_field + output_component z +! + begin plot_area_ctl + array chosen_ele_grp_ctl + chosen_ele_grp_ctl outer_core + end array chosen_ele_grp_ctl +! + array surface_enhanse_ctl + surface_enhanse_ctl ICB reverse_surface 0.85 + surface_enhanse_ctl CMB forward_surface 0.01 + end array surface_enhanse_ctl + end plot_area_ctl +! + begin colormap_ctl + colormap_ctl rainbow +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl -5.0 0.0 + color_table_ctl 0.0 0.5 + color_table_ctl 5.0 1.0 + end array color_table_ctl +! + opacity_style_ctl point_linear + array linear_opacity_ctl + linear_opacity_ctl -6.0 0.3 + linear_opacity_ctl -4.0 0.4 + linear_opacity_ctl -3.4 0.6 + linear_opacity_ctl -2.4 0.2 + linear_opacity_ctl -2.0 0.1 + linear_opacity_ctl -0.5 0.01 + linear_opacity_ctl 0.0 0.0001 + linear_opacity_ctl 0.5 0.01 + linear_opacity_ctl 2.0 0.1 + linear_opacity_ctl 2.4 0.2 + linear_opacity_ctl 3.4 0.6 + linear_opacity_ctl 4.0 0.4 + linear_opacity_ctl 6.0 0.3 + end array linear_opacity_ctl + constant_opacity_ctl 0.003 +! + range_min_ctl -6.0 + range_max_ctl 6.0 + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_scale_ctl ON + iflag_zeromarker OFF + colorbar_range -5.0 5.0 + font_size_ctl 1 + num_grid_ctl 5 +! + axis_label_switch ON + end colorbar_ctl +! + array section_ctl + begin section_ctl + opacity_ctl 0.5 + file surface_define 'SURFACE_defs/ctl_section_z0.3s' + end section_ctl + end array section_ctl +! + file lighting_ctl 'PVR_defs/control_lights' + file view_transform_ctl 'view_defines/control_camera' +end volume_rendering + diff --git a/tests/Rendering_tests/PVR_defs/ctl_pvr_temp b/tests/Rendering_tests/PVR_defs/ctl_pvr_temp new file mode 100644 index 00000000..81fe4e43 --- /dev/null +++ b/tests/Rendering_tests/PVR_defs/ctl_pvr_temp @@ -0,0 +1,68 @@ +! +! +! example of control for Kemo's volume rendering +! +begin volume_rendering (BMP or PNG) + updated_sign end +! + pvr_file_head 'pvr/pvr_temp' + pvr_output_type PNG +! image_tranceparency transparent +! + output_field temperature end + output_component scalar +! + begin plot_area_ctl + array chosen_ele_grp_ctl + chosen_ele_grp_ctl all + end array chosen_ele_grp_ctl +! + array surface_enhanse_ctl + surface_enhanse_ctl ICB reverse_surface 0.7 + surface_enhanse_ctl CMB reverse_surface 0.1 + end array surface_enhanse_ctl + end plot_area_ctl +! + begin colormap_ctl + colormap_mode_ctl rainbow +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl 0.0 0.0 + color_table_ctl 0.25 0.5 + color_table_ctl 0.5 1.0 + end array color_table_ctl +! + opacity_style_ctl point_linear + array linear_opacity_ctl + linear_opacity_ctl 0.0 0.01 + linear_opacity_ctl 0.01 0.02 + linear_opacity_ctl 0.28 0.03 + linear_opacity_ctl 0.30 0.6 + linear_opacity_ctl 0.32 0.05 + linear_opacity_ctl 0.38 0.05 + linear_opacity_ctl 0.40 0.6 + linear_opacity_ctl 0.42 0.05 + linear_opacity_ctl 0.45 0.03 + linear_opacity_ctl 0.5 0.1 + end array linear_opacity_ctl + constant_opacity_ctl 0.003 +! + range_min_ctl 0.0 + range_max_ctl 0.5 + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_scale_ctl ON + iflag_zeromarker OFF + colorbar_range 0.0 0.5 + font_size_ctl 1 + num_grid_ctl 4 +! + axis_label_switch ON + end colorbar_ctl +! + file lighting_ctl 'PVR_defs/control_lights' + file view_transform_ctl 'view_defines/control_view' +end volume_rendering diff --git a/tests/Rendering_tests/PVR_defs/ctl_pvr_vr b/tests/Rendering_tests/PVR_defs/ctl_pvr_vr new file mode 100644 index 00000000..ea4700cd --- /dev/null +++ b/tests/Rendering_tests/PVR_defs/ctl_pvr_vr @@ -0,0 +1,92 @@ +! +! +! example of control for Kemo's volume rendering +! +begin volume_rendering (BMP or PNG) + pvr_file_head 'pvr/pvr_vr' + pvr_output_type PNG +! image_tranceparency transparent +! + output_field velocity + output_component r +! + begin plot_area_ctl + array chosen_ele_grp_ctl + chosen_ele_grp_ctl outer_core + end array chosen_ele_grp_ctl +! + array surface_enhanse_ctl + surface_enhanse_ctl ICB reverse_surface 0.9 + surface_enhanse_ctl CMB forward_surface 0.01 + end array surface_enhanse_ctl + end plot_area_ctl +! + begin colormap_ctl + colormap_mode_ctl rainbow +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl -80.0 0.0 + color_table_ctl 0.0 0.5 + color_table_ctl 80.0 1.0 + end array color_table_ctl +! + opacity_style_ctl point_linear + array linear_opacity_ctl + linear_opacity_ctl -80.0 0.02 + linear_opacity_ctl -70.0 0.1 + linear_opacity_ctl -60.0 0.2 + linear_opacity_ctl -50.0 0.5 + linear_opacity_ctl -40.0 0.2 + linear_opacity_ctl -20.0 0.01 + linear_opacity_ctl -10.0 0.001 + linear_opacity_ctl 0.0 0.0001 + linear_opacity_ctl 10.0 0.001 + linear_opacity_ctl 20.0 0.01 + linear_opacity_ctl 40.0 0.2 + linear_opacity_ctl 50.0 0.5 + linear_opacity_ctl 60.0 0.2 + linear_opacity_ctl 70.0 0.1 + linear_opacity_ctl 80.0 0.02 + end array linear_opacity_ctl + constant_opacity_ctl 0.003 +! + range_min_ctl -80.0 + range_max_ctl 80.0 + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_scale_ctl On + iflag_zeromarker OFF + colorbar_range -80.0 80.0 + font_size_ctl 1 + num_grid_ctl 5 +! + axis_label_switch ON + end colorbar_ctl +! + array section_ctl + begin section_ctl + opacity_ctl 0.9 + file surface_define 'SURFACE_defs/ctl_section_z0.3s' + end section_ctl + end array section_ctl +! + array isosurface_ctl + begin isosurface_ctl + isosurf_value -60.0 + opacity_ctl 0.8 + surface_direction decrease + end isosurface_ctl +! + begin isosurface_ctl + isosurf_value 60.0 + opacity_ctl 0.8 + surface_direction increase + end isosurface_ctl + end array isosurface_ctl +! + file lighting_ctl 'PVR_defs/control_lights' + file view_transform_ctl 'view_defines/control_camera' +end volume_rendering diff --git a/tests/Rendering_tests/PVR_defs/ctl_pvr_wz b/tests/Rendering_tests/PVR_defs/ctl_pvr_wz new file mode 100644 index 00000000..53891dbf --- /dev/null +++ b/tests/Rendering_tests/PVR_defs/ctl_pvr_wz @@ -0,0 +1,80 @@ +! +! +! example of control for Kemo's volume rendering +! +begin volume_rendering (BMP or PNG) + pvr_file_head 'pvr/pvr_wz' + pvr_output_type PNG +! image_tranceparency transparent +! + output_field vorticity + output_component z +! + begin plot_area_ctl + array chosen_ele_grp_ctl + chosen_ele_grp_ctl outer_core + end array chosen_ele_grp_ctl +! + array surface_enhanse_ctl + surface_enhanse_ctl ICB reverse_surface 0.85 + surface_enhanse_ctl CMB forward_surface 0.01 + end array surface_enhanse_ctl + end plot_area_ctl +! + begin colormap_ctl + colormap_mode_ctl rainbow +! + data_mapping_ctl Colormap_list + array color_table_ctl + color_table_ctl -2000.0 0.0 + color_table_ctl 0.0 0.5 + color_table_ctl 2000.0 1.0 + end array color_table_ctl +! + opacity_style_ctl point_linear + array linear_opacity_ctl + linear_opacity_ctl -3000.0 0.3 + linear_opacity_ctl -2000.0 0.4 + linear_opacity_ctl -1800.0 0.5 + linear_opacity_ctl -1700.0 0.8 + linear_opacity_ctl -1200.0 0.4 + linear_opacity_ctl -1000.0 0.05 + linear_opacity_ctl -300.0 0.01 + linear_opacity_ctl 0.0 0.0001 + linear_opacity_ctl 300.0 0.01 + linear_opacity_ctl 1000.0 0.05 + linear_opacity_ctl 1200.0 0.4 + linear_opacity_ctl 1700.0 0.8 + linear_opacity_ctl 1800.0 0.5 + linear_opacity_ctl 2000.0 0.4 + linear_opacity_ctl 3000.0 0.3 + end array linear_opacity_ctl + constant_opacity_ctl 0.003 +! + range_min_ctl -3000.0 + range_max_ctl 3000.0 + end colormap_ctl +! + begin colorbar_ctl + colorbar_switch_ctl On + colorbar_scale_ctl ON + iflag_zeromarker OFF + colorbar_range -2000.0 2000.0 + font_size_ctl 1 + num_grid_ctl 5 +! + axis_label_switch ON + end colorbar_ctl +! + array section_ctl + begin section_ctl + opacity_ctl 0.5 + file surface_define 'SURFACE_defs/ctl_section_z0.3s' + end section_ctl + end array section_ctl +! + file lighting_ctl 'PVR_defs/control_lights' + file view_transform_ctl 'view_defines/control_view' +! +end volume_rendering + diff --git a/tests/Rendering_tests/SECTION_defs/ctl_fields_z_sections b/tests/Rendering_tests/SECTION_defs/ctl_fields_z_sections new file mode 100644 index 00000000..651145c6 --- /dev/null +++ b/tests/Rendering_tests/SECTION_defs/ctl_fields_z_sections @@ -0,0 +1,14 @@ +! +! example of field linst for sectioning module +! + begin output_field_define + array output_field + output_field temperature scalar + output_field velocity cylindrical_vector + output_field vorticity cylindrical_vector + output_field magnetic_field cylindrical_vector +! + output_field Lorentz_work scalar + output_field buoyancy_flux scalar + end array output_field + end output_field_define diff --git a/tests/Rendering_tests/SECTION_defs/ctl_psf_cmb b/tests/Rendering_tests/SECTION_defs/ctl_psf_cmb new file mode 100644 index 00000000..943be9a3 --- /dev/null +++ b/tests/Rendering_tests/SECTION_defs/ctl_psf_cmb @@ -0,0 +1,17 @@ +! +! +! example of control for Kemo's surface rendering +! +begin surface_rendering + psf_file_head 'sections/cmb' + psf_output_type UDT_gzip +! + file surface_define 'SURFACE_defs/ctl_section_CMB' +! + begin output_field_define + array output_field + output_field temperature scalar + output_field magnetic_field spherical_vector + end array output_field + end output_field_define +end surface_rendering diff --git a/tests/Rendering_tests/SECTION_defs/ctl_psf_icb b/tests/Rendering_tests/SECTION_defs/ctl_psf_icb new file mode 100644 index 00000000..f1e6f082 --- /dev/null +++ b/tests/Rendering_tests/SECTION_defs/ctl_psf_icb @@ -0,0 +1,18 @@ +! +! +! example of control for Kemo's surface rendering +! +begin surface_rendering + psf_file_head 'sections/icb' + psf_output_type UDT_gzip +! + file surface_define 'SURFACE_defs/ctl_section_ICB' +! + begin output_field_define + array output_field + output_field magnetic_field spherical_vector + output_field temperature scalar + output_field grad_temp spherical_vector + end array output_field + end output_field_define +end surface_rendering diff --git a/tests/Rendering_tests/SECTION_defs/ctl_psf_z0 b/tests/Rendering_tests/SECTION_defs/ctl_psf_z0 new file mode 100644 index 00000000..092ebd76 --- /dev/null +++ b/tests/Rendering_tests/SECTION_defs/ctl_psf_z0 @@ -0,0 +1,33 @@ +! +! +! example of control for Kemo's surface rendering +! +begin surface_rendering + psf_file_head 'sections/equator' + psf_output_type UDT_gzip +! + begin surface_define + section_method equation +! + array coefs_ctl 10 + coefs_ctl x2 0.0 + coefs_ctl y2 0.0 + coefs_ctl z2 0.0 + coefs_ctl xy 0.0 + coefs_ctl yz 0.0 + coefs_ctl zx 0.0 + coefs_ctl x 0.0 + coefs_ctl y 0.0 + coefs_ctl z 1.0 + coefs_ctl const 0.0 + end array coefs_ctl +! + begin plot_area_ctl + array chosen_ele_grp_ctl 1 + chosen_ele_grp_ctl all end + end array chosen_ele_grp_ctl + end plot_area_ctl + end surface_define +! + file output_field_define 'SECTION_defs/ctl_fields_z_sections' +end surface_rendering diff --git a/tests/Rendering_tests/SECTION_defs/ctl_psf_z0.3 b/tests/Rendering_tests/SECTION_defs/ctl_psf_z0.3 new file mode 100644 index 00000000..ed52188a --- /dev/null +++ b/tests/Rendering_tests/SECTION_defs/ctl_psf_z0.3 @@ -0,0 +1,34 @@ +! +! +! example of control for Kemo's surface rendering +! +begin surface_rendering + psf_file_head 'sections/z0.3' + psf_output_type UDT_gzip +! + begin surface_define + section_method equation +! + array coefs_ctl 10 + coefs_ctl x2 0.0 + coefs_ctl y2 0.0 + coefs_ctl z2 0.0 + coefs_ctl xy 0.0 + coefs_ctl yz 0.0 + coefs_ctl zx 0.0 + coefs_ctl x 0.0 + coefs_ctl y 0.0 + coefs_ctl z 1.0 + coefs_ctl const -0.3 + end array coefs_ctl +! + begin plot_area_ctl + array chosen_ele_grp_ctl 1 +! chosen_ele_grp_ctl outer_core end + chosen_ele_grp_ctl all + end array chosen_ele_grp_ctl + end plot_area_ctl + end surface_define +! + file output_field_define 'SECTION_defs/ctl_fields_z_sections' +end surface_rendering diff --git a/tests/Rendering_tests/SECTION_defs/ctl_psf_z1.0 b/tests/Rendering_tests/SECTION_defs/ctl_psf_z1.0 new file mode 100644 index 00000000..f01e0ba0 --- /dev/null +++ b/tests/Rendering_tests/SECTION_defs/ctl_psf_z1.0 @@ -0,0 +1,33 @@ +! +! +! example of control for Kemo's surface rendering +! +begin surface_rendering + psf_file_head 'sections/z1.0' + psf_output_type UDT_gzip +! + begin surface_define + section_method equation +! + array coefs_ctl + coefs_ctl x2 0.0 + coefs_ctl y2 0.0 + coefs_ctl z2 0.0 + coefs_ctl xy 0.0 + coefs_ctl yz 0.0 + coefs_ctl zx 0.0 + coefs_ctl x 0.0 + coefs_ctl y 0.0 + coefs_ctl z 1.0 + coefs_ctl const -1.0 + end array coefs_ctl +! + begin plot_area_ctl + array chosen_ele_grp_ctl 1 + chosen_ele_grp_ctl outer_core end + end array chosen_ele_grp_ctl + end plot_area_ctl + end surface_define +! + file output_field_define 'SECTION_defs/ctl_fields_z_sections' +end surface_rendering diff --git a/tests/Rendering_tests/SECTION_defs/ctl_zm_y0 b/tests/Rendering_tests/SECTION_defs/ctl_zm_y0 new file mode 100644 index 00000000..3338b033 --- /dev/null +++ b/tests/Rendering_tests/SECTION_defs/ctl_zm_y0 @@ -0,0 +1,22 @@ +! +! +! example of control for Kemo's surface rendering +! +begin surface_rendering + psf_file_head 'sections/zm_y0' + psf_output_type PSF_gzip +! + file surface_define 'SURFACE_defs/ctl_section_zm' +! + begin output_field_define + array output_field + output_field temperature scalar + output_field velocity spherical_vector + output_field vorticity spherical_vector + output_field magnetic_field spherical_vector +! + output_field stream_pol_velocity phi + output_field stream_pol_magne phi + end array output_field + end output_field_define +end surface_rendering diff --git a/tests/Rendering_tests/SURFACE_defs/ctl_section_CMB b/tests/Rendering_tests/SURFACE_defs/ctl_section_CMB new file mode 100644 index 00000000..62c55ca8 --- /dev/null +++ b/tests/Rendering_tests/SURFACE_defs/ctl_section_CMB @@ -0,0 +1,25 @@ +! +! example of control for CMB section +! + begin surface_define + section_method equation +! + array coefs_ctl 10 + coefs_ctl x2 1.0 + coefs_ctl y2 1.0 + coefs_ctl z2 1.0 + coefs_ctl xy 0.0 + coefs_ctl yz 0.0 + coefs_ctl zx 0.0 + coefs_ctl x 0.0 + coefs_ctl y 0.0 + coefs_ctl z 0.0 + coefs_ctl const -2.3667 + end array coefs_ctl +! + begin plot_area_ctl + array chosen_ele_grp_ctl + chosen_ele_grp_ctl all + end array chosen_ele_grp_ctl + end plot_area_ctl + end surface_define diff --git a/tests/Rendering_tests/SURFACE_defs/ctl_section_ICB b/tests/Rendering_tests/SURFACE_defs/ctl_section_ICB new file mode 100644 index 00000000..837336cf --- /dev/null +++ b/tests/Rendering_tests/SURFACE_defs/ctl_section_ICB @@ -0,0 +1,25 @@ +! +! example of control for ICB setting +! + begin surface_define + section_method equation +! + array coefs_ctl 10 + coefs_ctl x2 1.0 + coefs_ctl y2 1.0 + coefs_ctl z2 1.0 + coefs_ctl xy 0.0 + coefs_ctl yz 0.0 + coefs_ctl zx 0.0 + coefs_ctl x 0.0 + coefs_ctl y 0.0 + coefs_ctl z 0.0 + coefs_ctl const -0.29 + end array coefs_ctl +! + begin plot_area_ctl + array chosen_ele_grp_ctl 1 + chosen_ele_grp_ctl all end + end array chosen_ele_grp_ctl + end plot_area_ctl + end surface_define diff --git a/tests/Rendering_tests/SURFACE_defs/ctl_section_z0.3s b/tests/Rendering_tests/SURFACE_defs/ctl_section_z0.3s new file mode 100644 index 00000000..27647cd6 --- /dev/null +++ b/tests/Rendering_tests/SURFACE_defs/ctl_section_z0.3s @@ -0,0 +1,11 @@ +! +! example of control for Kemo's surface rendering +! + begin surface_define + section_method equation +! + array coefs_ctl + coefs_ctl z 1.0 + coefs_ctl const 0.3 + end array coefs_ctl + end surface_define diff --git a/tests/Rendering_tests/SURFACE_defs/ctl_section_zm b/tests/Rendering_tests/SURFACE_defs/ctl_section_zm new file mode 100644 index 00000000..57646be5 --- /dev/null +++ b/tests/Rendering_tests/SURFACE_defs/ctl_section_zm @@ -0,0 +1,25 @@ +! +! +! example of control for Kemo's surface rendering +! + begin surface_define + section_method equation + array coefs_ctl + coefs_ctl x2 0.0 + coefs_ctl y2 0.0 + coefs_ctl z2 0.0 + coefs_ctl xy 0.0 + coefs_ctl yz 0.0 + coefs_ctl zx 0.0 + coefs_ctl x 0.0 + coefs_ctl y -1.0 + coefs_ctl z 0.0 + coefs_ctl const 0.0 + end array coefs_ctl +! + begin plot_area_ctl + array chosen_ele_grp_ctl + chosen_ele_grp_ctl all + end array chosen_ele_grp_ctl + end plot_area_ctl + end surface_define diff --git a/tests/Rendering_tests/control_MHD b/tests/Rendering_tests/control_MHD new file mode 100644 index 00000000..7b2cd526 --- /dev/null +++ b/tests/Rendering_tests/control_MHD @@ -0,0 +1,327 @@ +begin MHD_control +!!!!! Define for files !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! num_subdomain_ctl: number of subdomains +! num_smp_ctl: number of smp processes +! +! mesh_file_head_ctl: header of mesh file (Default: in.domain#) +! +! sph_file_prefix: prefix of spherical transfoem grid +! restart_file_prefix: prefix of restart file +! (Default: restart/rst.step#.domain#) +! field_file_prefix: prefix of snapshot field data +! (Default: out.step#.domain#.udt) +! +! field_file_fmt_ctl: data format for field files +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + begin data_files_def + debug_flag_ctl 'Off' +! + num_subdomain_ctl 6 + num_smp_ctl 2 +! + restart_file_prefix 'rst_6/rst' + field_file_prefix 'rst_6/out' +! + restart_file_fmt_ctl 'merged_bin_gzip' + field_file_fmt_ctl 'merged_bin_gzip' + end data_files_def +! + file spherical_shell_ctl 'sph_lm47_r63c_6/control_resolution' +! + begin model +!!!!! physical values!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! available valuables +! velocity, temperature, pressure, vorticity +! vector_potential, magnetic_field, current_density, magnetic_potential +! composition, perturbation_temp +! +! buoyancy_flux, Lorentz_work, mag_tension_work +! magnetic_ene_generation +! temp_generation, part_temp_gen +! vis_ene_diffuse, mag_ene_diffuse +! +! thermal_diffusion, viscous_diffusion, magnetic_diffusion +! Coriolis_force, buoyancy +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + begin phys_values_ctl + array nod_value_ctl + nod_value_ctl velocity Viz_On Monitor_On + nod_value_ctl temperature Viz_On Monitor_On + nod_value_ctl heat_source Viz_Off Monitor_Off + nod_value_ctl pressure Viz_On Monitor_On + nod_value_ctl vorticity Viz_On Monitor_On + nod_value_ctl magnetic_field Viz_On Monitor_On + nod_value_ctl current_density Viz_On Monitor_On +! + nod_value_ctl grad_temp Viz_On Monitor_On + nod_value_ctl buoyancy_flux Viz_On Monitor_On + nod_value_ctl Lorentz_work Viz_On Monitor_On +! + nod_value_ctl truncated_magnetic_field Viz_On Monitor_Off + nod_value_ctl stream_pol_velocity Viz_On Monitor_Off + nod_value_ctl stream_pol_magne Viz_On Monitor_Off + end array nod_value_ctl + end phys_values_ctl +! +!!!!! physical values for time evolution !!!!!!!!!!!!!!!!!! +! aviable valuables: velocity, temperature, magnetic_field +! vector_potential, composition +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + begin time_evolution_ctl + array time_evo_ctl + time_evo_ctl temperature + time_evo_ctl velocity + time_evo_ctl magnetic_field + end array time_evo_ctl + end time_evolution_ctl +! +!!!!! setting for boundary condition +! + begin boundary_condition + array bc_temperature + bc_temperature fixed_flux ICB 3.44898 + bc_temperature fixed_flux CMB -0.4225 + end array bc_temperature +! + array bc_velocity + bc_velocity non_slip_sph ICB 0.000 + bc_velocity non_slip_sph CMB 0.000 + end array bc_velocity +! + array bc_composition 0 +! + array bc_magnetic_field +! bc_magnetic_field sph_to_center to_Center 0.000 + bc_magnetic_field insulator ICB 0.000 + bc_magnetic_field insulator CMB 0.000 + end array bc_magnetic_field + end boundary_condition +! +! begin bc_4_surface +! array heat_flux_surf 0 +! array velocity_surf 0 +! array pressure_surf 0 +! array magnetic_field_surf 0 +! array electric_potential_surf 0 +! end bc_4_surface +! +!!!!! define of forces !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! available forces +! gravity, Coriolis, Lorentz +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + begin forces_define + array force_ctl + force_ctl gravity + force_ctl Coriolis + force_ctl Lorentz + end array force_ctl + end forces_define +! +!!!!! dimensionless numbers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! available numbers +! Prandtl_number, magnetic_Prandtl_number +! Rayleigh_number, modified_Rayleigh_number +! Reynords_number +! Taylor_number, Ekman_number +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + begin dimensionless_ctl + array dimless_ctl + dimless_ctl Pr 1.0e+0 + dimless_ctl mod_Raf 2.0E+3 + dimless_ctl Ek 6.0e-4 + dimless_ctl Pm 5.0e+0 + dimless_ctl R_o 1.5384615e+0 + end array dimless_ctl + end dimensionless_ctl +! +!!!!! Normalization settings !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! define +! coef_4_termal_ctl: time integration and advection of temp +! coef_4_velocity_ctl: time integration and advection of temperature +! coef_4_magnetic_ctl: time integration and advection of magnetic f. +! coef_4_t_diffuse_ctl: coefficients for thermal diffusion +! coef_4_v_diffuse_ctl: coefficients for viscous diffusion +! coef_4_m_diffuse_ctl: coefficients for magnetic diffusion +! coef_4_buoyancy_ctl: coefficients for buoyancy +! coef_4_Coriolis_ctl: coefficients for Coriolis force +! coef_4_Lorentz_ctl: coefficients for Lorantz force +! coef_4_composit_buoyancy_ctl: +! coefficients for compositional buoyancy +! coef_4_induction_ctl: coefficients for magnetic induction +! +! One: 1, Zero (Ignore), Two: 2, Radial_parameter: (1-ri/ro) +! Radial_35: (1-0.35) +! +! Real number.... Power of each numbers +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + begin coefficients_ctl + begin thermal + array coef_4_termal_ctl 1 + coef_4_termal_ctl One 1.0 + end array coef_4_termal_ctl +! + array coef_4_t_diffuse_ctl 1 + coef_4_t_diffuse_ctl Pr -1.0 + end array coef_4_t_diffuse_ctl + end thermal +! +! + begin momentum + array coef_4_velocity_ctl + coef_4_velocity_ctl One 1.0 + end array coef_4_velocity_ctl +! + array coef_4_press_ctl + coef_4_press_ctl Ek -1.0 + end array coef_4_press_ctl +! + array coef_4_v_diffuse_ctl + coef_4_v_diffuse_ctl One 1.0 + end array coef_4_v_diffuse_ctl +! + array coef_4_buoyancy_ctl + coef_4_buoyancy_ctl R_o -1.0 + coef_4_buoyancy_ctl mod_Raf 1.0 + coef_4_buoyancy_ctl Ek -1.0 + end array coef_4_buoyancy_ctl +! + array coef_4_Coriolis_ctl + coef_4_Coriolis_ctl Two 1.0 + coef_4_Coriolis_ctl Ek -1.0 + end array coef_4_Coriolis_ctl +! + array coef_4_Lorentz_ctl + coef_4_Lorentz_ctl Pm -1.0 + coef_4_Lorentz_ctl Ek -1.0 + end array coef_4_Lorentz_ctl + end momentum +! +! + begin induction + array coef_4_magnetic_ctl + coef_4_magnetic_ctl One 1.0 + end array coef_4_magnetic_ctl +! + array coef_4_m_diffuse_ctl + coef_4_m_diffuse_ctl Pm -1.0 + end array coef_4_m_diffuse_ctl +! + array coef_4_induction_ctl + coef_4_induction_ctl One -1.0 + end array coef_4_induction_ctl + end induction + end coefficients_ctl +! +!!!!!!!!! model for hydrostatic !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! ref_temperature_ctl: none (No reference of temperature) +! spherical_shell ( for spherical shell model) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + begin temperature_define + ref_temp_ctl none + end temperature_define + end model +! +! +! + begin control +!!!!! information for sime integration + begin time_step_ctl + elapsed_time_ctl 83000. + i_step_init_ctl 40000000 + i_step_finish_ctl 40000040 +! + i_step_check_ctl 10 + i_step_rst_ctl 200000 + i_step_field_ctl 0 + i_step_sectioning_ctl 40 + i_step_isosurface_ctl 40 + i_step_map_projection_ctl 20 + i_step_pvr_ctl 20 +! + dt_ctl 2.0e-6 + time_init_ctl 0.0e-8 + end time_step_ctl +! +!!!!! control for restart data + begin restart_file_ctl + rst_ctl start_from_rst_file + end restart_file_ctl +! +!!!!!! method for time evolution +! + begin time_loop_ctl + scheme_ctl Crank_Nicolson + coef_imp_v_ctl 6.0e-1 + coef_imp_t_ctl 6.0e-1 + coef_imp_b_ctl 6.0e-1 + coef_imp_d_ctl 6.0e-1 + end time_loop_ctl + end control +! + begin sph_monitor_ctl + volume_average_prefix 'monitor/sph_ave_volume' + volume_pwr_spectr_prefix 'monitor/sph_pwr_volume' + nusselt_number_prefix 'monitor/Nusselt' +! + begin gauss_coefficient_ctl + gauss_coefs_prefix 'monitor/gauss_coefs_Re' + gauss_coefs_radius_ctl 2.82 +! + array pick_gauss_coef_degree_ctl + pick_gauss_coef_degree_ctl 1 + pick_gauss_coef_degree_ctl 3 + end array pick_gauss_coef_degree_ctl + end gauss_coefficient_ctl + end sph_monitor_ctl +! + begin visual_control + array surface_rendering + file surface_rendering 'SECTION_defs/ctl_psf_cmb' + file surface_rendering 'SECTION_defs/ctl_psf_z0' + file surface_rendering 'SECTION_defs/ctl_psf_z0.3' + file surface_rendering 'SECTION_defs/ctl_psf_z1.0' + file surface_rendering 'SECTION_defs/ctl_psf_icb' + end array surface_rendering +! + array isosurface_ctl + file isosurface_ctl 'ISOSURFACE_defs/ctl_iso_temp' + end array isosurface_ctl +! + array map_rendering_ctl + file map_rendering_ctl 'MAP_defs/ctl_map_cmb_Br' + file map_rendering_ctl 'MAP_defs/ctl_map_cmb_T' + file map_rendering_ctl 'MAP_defs/ctl_map_line_cmb_Br' + file map_rendering_ctl 'MAP_defs/ctl_map_line_cmb_T' + end array map_rendering_ctl +! + array volume_rendering + file volume_rendering 'PVR_defs/ctl_pvr_temp' + file volume_rendering 'PVR_defs/ctl_pvr_Bpole' + file volume_rendering 'PVR_defs/ctl_pvr_Bz' + file volume_rendering 'PVR_defs/ctl_pvr_wz' + file volume_rendering 'PVR_defs/ctl_pvr_vr' + end array volume_rendering + end visual_control +! + begin dynamo_vizs_control + begin crustal_filtering_ctl + truncation_degree_ctl 13 + end crustal_filtering_ctl +!! + file zonal_mean_section_ctl 'SECTION_defs/ctl_zm_y0' + array zonal_mean_rendering_ctl + file zonal_mean_rendering_ctl 'MAP_defs/ctl_zm_yz_velo' + file zonal_mean_rendering_ctl 'MAP_defs/ctl_zm_yz_magne' + end array zonal_mean_rendering_ctl + end dynamo_vizs_control +end MHD_control + diff --git a/tests/Rendering_tests/control_snapshot b/tests/Rendering_tests/control_snapshot new file mode 100644 index 00000000..8f2c36d2 --- /dev/null +++ b/tests/Rendering_tests/control_snapshot @@ -0,0 +1,384 @@ +begin MHD_control +!!!!! Define for files !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! num_subdomain_ctl: number of subdomains +! num_smp_ctl: number of smp processes +! +! mesh_file_head_ctl: header of mesh file (Default: in.domain#) +! +! sph_file_prefix: prefix of spherical transfoem grid +! restart_file_prefix: prefix of restart file +! (Default: restart/rst.step#.domain#) +! field_file_prefix: prefix of snapshot field data +! (Default: out.step#.domain#.udt) +! +! field_file_fmt_ctl: data format for field files +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + begin data_files_def + debug_flag_ctl 'Off' +! + num_subdomain_ctl 7168 + num_smp_ctl 1 +! + sph_file_prefix '../sph_lm255_r335c_ic_7168_2/in' + restart_file_prefix '../sph_lm255_r335c_ic_7168_2/rst' + field_file_prefix '../sph_lm255_r335c_ic_7168_2/out' +! + sph_file_fmt_ctl 'merged_bin_gzip' + restart_file_fmt_ctl 'merged_bin_gzip' + field_file_fmt_ctl 'merged_bin_gzip' + end data_files_def +! + file spherical_shell_ctl '../sph_lm255_r335c_ic_7168_2/control_resolution' +! + begin visual_control + array surface_rendering + file surface_rendering '../ctl_psf_cmb' + file surface_rendering '../ctl_psf_z0' + file surface_rendering '../ctl_psf_z0.3' + file surface_rendering '../ctl_psf_z1.0' + file surface_rendering '../ctl_psf_icb' + end array surface_rendering + array volume_rendering + file volume_rendering '../ctl_pvr_temp' + file volume_rendering '../ctl_pvr_Bmag' + file volume_rendering '../ctl_pvr_Tpole' + file volume_rendering '../ctl_pvr_Bpole' + file volume_rendering '../ctl_pvr_wz' + file volume_rendering '../ctl_pvr_vr' +! file volume_rendering '../ctl_pvr_temp2' +! file volume_rendering '../ctl_pvr_Bmag2' + end array volume_rendering +! + array LIC_rendering + file LIC_rendering 'ctl_lic_velo' + file LIC_rendering 'ctl_lic_magne' + file LIC_rendering 'ctl_lic_velo2' + file LIC_rendering 'ctl_lic_magne2' + end array LIC_rendering +! + begin LIC_repartition_ctl + begin viz_data_files_def + num_subdomain_ctl 7168 + end viz_data_files_def +! + begin FEM_mesh_ctl + FEM_surface_output_switch 'NO' + FEM_viewer_mesh_output_switch 'NO' + end FEM_mesh_ctl +! + begin new_partitioning_ctl +!!!! partition_reference_ctl: +!!!! PREDICTED_COUNT, STACKED_COUNT, AVERAGE_COUNT +!!!! VOLUME_BASED, NUMBER_BASED, or NO_REPARTITION + partition_reference_ctl VOLUME_BASED + power_of_volume_ctl 0.5 + array dir_domain_ctl + dir_domain_ctl x 16 + dir_domain_ctl y 16 + dir_domain_ctl z 28 + end array dir_domain_ctl + group_ratio_to_domain_ctl 100 + end new_partitioning_ctl +! + begin FEM_sleeve_ctl +!! sleeve_extension_mode: +!! element_count, sleeve_length, vector_trace + sleeve_extension_mode sleeve_length + sleeve_size_ctl 0.05 +! reference_vector_ctl velocity + end FEM_sleeve_ctl + end LIC_repartition_ctl + end visual_control +! + begin model +!!!!! physical values!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! available valuables +! velocity, temperature, pressure, vorticity +! vector_potential, magnetic_field, current_density, magnetic_potential +! composition, perturbation_temp +! +! buoyancy_flux, Lorentz_work, mag_tension_work +! magnetic_ene_generation +! temp_generation, part_temp_gen +! vis_ene_diffuse, mag_ene_diffuse +! +! thermal_diffusion, viscous_diffusion, magnetic_diffusion +! Coriolis_force, buoyancy +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + begin phys_values_ctl + array nod_value_ctl + nod_value_ctl velocity Viz_On Monitor_On + nod_value_ctl temperature Viz_On Monitor_On + nod_value_ctl heat_source Viz_Off Monitor_Off + nod_value_ctl pressure Viz_On Monitor_On + nod_value_ctl vorticity Viz_On Monitor_On + nod_value_ctl magnetic_field Viz_On Monitor_On + nod_value_ctl current_density Viz_On Monitor_On +! + nod_value_ctl grad_temp Viz_On Monitor_On + nod_value_ctl buoyancy_flux Viz_On Monitor_On + nod_value_ctl Lorentz_work Viz_On Monitor_On +! + nod_value_ctl truncated_magnetic_field Viz_On Monitor_Off + end array nod_value_ctl + end phys_values_ctl +! +!!!!! physical values for time evolution !!!!!!!!!!!!!!!!!! +! aviable valuables: velocity, temperature, magnetic_field +! vector_potential, composition +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + begin time_evolution_ctl + array time_evo_ctl + time_evo_ctl temperature + time_evo_ctl velocity + time_evo_ctl magnetic_field + end array time_evo_ctl + end time_evolution_ctl +! +!!!!! setting for boundary condition +! + begin boundary_condition + array bc_temperature + bc_temperature fixed_flux ICB 3.44898 + bc_temperature fixed_flux CMB -0.4225 + end array bc_temperature +! + array bc_velocity + bc_velocity non_slip_sph ICB 0.000 + bc_velocity non_slip_sph CMB 0.000 + end array bc_velocity +! + array bc_composition 0 +! + array bc_magnetic_field +! bc_magnetic_field sph_to_center to_Center 0.000 + bc_magnetic_field insulator ICB 0.000 + bc_magnetic_field insulator CMB 0.000 + end array bc_magnetic_field + end boundary_condition +! +! begin bc_4_surface +! array heat_flux_surf 0 +! array velocity_surf 0 +! array pressure_surf 0 +! array magnetic_field_surf 0 +! array electric_potential_surf 0 +! end bc_4_surface +! +!!!!! define of forces !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! available forces +! gravity, Coriolis, Lorentz +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + begin forces_define + array force_ctl + force_ctl gravity + force_ctl Coriolis + force_ctl Lorentz + end array force_ctl + end forces_define +! +!!!!! dimensionless numbers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! available numbers +! Prandtl_number, magnetic_Prandtl_number +! Rayleigh_number, modified_Rayleigh_number +! Reynords_number +! Taylor_number, Ekman_number +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + begin dimensionless_ctl + array dimless_ctl + dimless_ctl Pr 1.0e+0 + dimless_ctl mod_Raf 2.0E+3 + dimless_ctl Ek 6.0e-4 + dimless_ctl Pm 5.0e+0 + dimless_ctl R_o 1.5384615e+0 + end array dimless_ctl + end dimensionless_ctl +! +!!!!! Normalization settings !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! define +! coef_4_termal_ctl: time integration and advection of temp +! coef_4_velocity_ctl: time integration and advection of temperature +! coef_4_magnetic_ctl: time integration and advection of magnetic f. +! coef_4_t_diffuse_ctl: coefficients for thermal diffusion +! coef_4_v_diffuse_ctl: coefficients for viscous diffusion +! coef_4_m_diffuse_ctl: coefficients for magnetic diffusion +! coef_4_buoyancy_ctl: coefficients for buoyancy +! coef_4_Coriolis_ctl: coefficients for Coriolis force +! coef_4_Lorentz_ctl: coefficients for Lorantz force +! coef_4_composit_buoyancy_ctl: +! coefficients for compositional buoyancy +! coef_4_induction_ctl: coefficients for magnetic induction +! +! One: 1, Zero (Ignore), Two: 2, Radial_parameter: (1-ri/ro) +! Radial_35: (1-0.35) +! +! Real number.... Power of each numbers +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + begin coefficients_ctl + begin thermal + array coef_4_termal_ctl 1 + coef_4_termal_ctl One 1.0 + end array coef_4_termal_ctl +! + array coef_4_t_diffuse_ctl 1 + coef_4_t_diffuse_ctl Pr -1.0 + end array coef_4_t_diffuse_ctl + end thermal +! +! + begin momentum + array coef_4_velocity_ctl + coef_4_velocity_ctl One 1.0 + end array coef_4_velocity_ctl +! + array coef_4_press_ctl + coef_4_press_ctl Ek -1.0 + end array coef_4_press_ctl +! + array coef_4_v_diffuse_ctl + coef_4_v_diffuse_ctl One 1.0 + end array coef_4_v_diffuse_ctl +! + array coef_4_buoyancy_ctl + coef_4_buoyancy_ctl R_o -1.0 + coef_4_buoyancy_ctl mod_Raf 1.0 + coef_4_buoyancy_ctl Ek -1.0 + end array coef_4_buoyancy_ctl +! + array coef_4_Coriolis_ctl + coef_4_Coriolis_ctl Two 1.0 + coef_4_Coriolis_ctl Ek -1.0 + end array coef_4_Coriolis_ctl +! + array coef_4_Lorentz_ctl + coef_4_Lorentz_ctl Pm -1.0 + coef_4_Lorentz_ctl Ek -1.0 + end array coef_4_Lorentz_ctl + end momentum +! +! + begin induction + array coef_4_magnetic_ctl + coef_4_magnetic_ctl One 1.0 + end array coef_4_magnetic_ctl +! + array coef_4_m_diffuse_ctl + coef_4_m_diffuse_ctl Pm -1.0 + end array coef_4_m_diffuse_ctl +! + array coef_4_induction_ctl + coef_4_induction_ctl One -1.0 + end array coef_4_induction_ctl + end induction + end coefficients_ctl +! +!!!!!!!!! model for hydrostatic !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! ref_temperature_ctl: none (No reference of temperature) +! spherical_shell ( for spherical shell model) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + begin temperature_define + ref_temp_ctl none + end temperature_define + end model +! +! +! + begin control +!!!!! information for sime integration + begin time_step_ctl + elapsed_time_ctl 83000. + i_step_init_ctl 200 + i_step_finish_ctl 200 +! + i_step_check_ctl 1 + i_step_rst_ctl 1 + i_step_field_ctl 1 + i_step_sectioning_ctl 1 + i_step_pvr_ctl 1 + i_step_LIC_ctl 1 +! + dt_ctl 4.0e-1 + time_init_ctl 0.0e-8 + end time_step_ctl +! +!!!!! control for restart data + begin restart_file_ctl + rst_ctl start_from_rst_file + end restart_file_ctl +! +!!!!!! method for time evolution +! + begin time_loop_ctl + scheme_ctl Crank_Nicolson + coef_imp_v_ctl 6.0e-1 + coef_imp_t_ctl 6.0e-1 + coef_imp_b_ctl 6.0e-1 + coef_imp_d_ctl 6.0e-1 +! + FFT_library_ctl FFTW + send_recv_routine_ctl 'SEND_RECV' +! + Legendre_trans_loop_ctl 'SYMMETRIC_MATMUL_BIG' + end time_loop_ctl + end control +! + begin sph_monitor_ctl + volume_average_prefix 'sph_ave_volume' + volume_pwr_spectr_prefix 'sph_pwr_volume' + nusselt_number_prefix 'Nusselt' +! +! begin layered_spectrum_ctl +! layered_pwr_spectr_prefix 'sph_pwr_layer' +! end layered_spectrum_ctl +! + begin pickup_spectr_ctl + picked_sph_prefix 'picked_mode' +! + array pick_layer_ctl + pick_layer_ctl 1 + pick_layer_ctl 113 + pick_layer_ctl 225 + end array pick_layer_ctl +! + array pick_sph_degree_ctl + pick_sph_degree_ctl 0 + pick_sph_degree_ctl 1 + pick_sph_degree_ctl 2 + end array pick_sph_degree_ctl +! + array pick_sph_spectr_ctl + pick_sph_spectr_ctl 3 -2 + pick_sph_spectr_ctl 3 0 + pick_sph_spectr_ctl 3 2 + end array pick_sph_spectr_ctl + end pickup_spectr_ctl +! + begin gauss_coefficient_ctl + gauss_coefs_prefix 'gauss_coefs_Re' + gauss_coefs_radius_ctl 2.82 +! + array pick_gauss_coef_degree_ctl + pick_gauss_coef_degree_ctl 1 + pick_gauss_coef_degree_ctl 3 + end array pick_gauss_coef_degree_ctl + end gauss_coefficient_ctl +! +! array volume_spectrum_ctl +! begin volume_spectrum_ctl +! volume_pwr_spectr_prefix 'sph_pwr_convective' +! volume_average_prefix 'sph_ave_convective' +! inner_radius_ctl 0.54346 +! outer_radius_ctl 1.53346 +! end volume_spectrum_ctl +! end array volume_spectrum_ctl + end sph_monitor_ctl +end MHD_control diff --git a/tests/Rendering_tests/isosurfaces/README b/tests/Rendering_tests/isosurfaces/README new file mode 100644 index 00000000..285ef831 --- /dev/null +++ b/tests/Rendering_tests/isosurfaces/README @@ -0,0 +1,6 @@ +!----------------------------------------------------------------------- +! Cross section data directory for dynamo benchmark test Case 2 +! Please see Christensen et.al. (2001) for the model description +!----------------------------------------------------------------------- +! + Restart data files are stored in this directory. diff --git a/tests/Rendering_tests/maps/README b/tests/Rendering_tests/maps/README new file mode 100644 index 00000000..285ef831 --- /dev/null +++ b/tests/Rendering_tests/maps/README @@ -0,0 +1,6 @@ +!----------------------------------------------------------------------- +! Cross section data directory for dynamo benchmark test Case 2 +! Please see Christensen et.al. (2001) for the model description +!----------------------------------------------------------------------- +! + Restart data files are stored in this directory. diff --git a/tests/Rendering_tests/monitor/README b/tests/Rendering_tests/monitor/README new file mode 100644 index 00000000..285ef831 --- /dev/null +++ b/tests/Rendering_tests/monitor/README @@ -0,0 +1,6 @@ +!----------------------------------------------------------------------- +! Cross section data directory for dynamo benchmark test Case 2 +! Please see Christensen et.al. (2001) for the model description +!----------------------------------------------------------------------- +! + Restart data files are stored in this directory. diff --git a/tests/Rendering_tests/pvr/README b/tests/Rendering_tests/pvr/README new file mode 100644 index 00000000..285ef831 --- /dev/null +++ b/tests/Rendering_tests/pvr/README @@ -0,0 +1,6 @@ +!----------------------------------------------------------------------- +! Cross section data directory for dynamo benchmark test Case 2 +! Please see Christensen et.al. (2001) for the model description +!----------------------------------------------------------------------- +! + Restart data files are stored in this directory. diff --git a/tests/Rendering_tests/references/README b/tests/Rendering_tests/references/README new file mode 100644 index 00000000..285ef831 --- /dev/null +++ b/tests/Rendering_tests/references/README @@ -0,0 +1,6 @@ +!----------------------------------------------------------------------- +! Cross section data directory for dynamo benchmark test Case 2 +! Please see Christensen et.al. (2001) for the model description +!----------------------------------------------------------------------- +! + Restart data files are stored in this directory. diff --git a/tests/Rendering_tests/references/maps/README b/tests/Rendering_tests/references/maps/README new file mode 100644 index 00000000..285ef831 --- /dev/null +++ b/tests/Rendering_tests/references/maps/README @@ -0,0 +1,6 @@ +!----------------------------------------------------------------------- +! Cross section data directory for dynamo benchmark test Case 2 +! Please see Christensen et.al. (2001) for the model description +!----------------------------------------------------------------------- +! + Restart data files are stored in this directory. diff --git a/tests/Rendering_tests/references/maps/map_cmb_Br.2000001.png b/tests/Rendering_tests/references/maps/map_cmb_Br.2000001.png new file mode 100644 index 00000000..0b7442d5 Binary files /dev/null and b/tests/Rendering_tests/references/maps/map_cmb_Br.2000001.png differ diff --git a/tests/Rendering_tests/references/maps/map_cmb_Br.2000002.png b/tests/Rendering_tests/references/maps/map_cmb_Br.2000002.png new file mode 100644 index 00000000..78b9dc7d Binary files /dev/null and b/tests/Rendering_tests/references/maps/map_cmb_Br.2000002.png differ diff --git a/tests/Rendering_tests/references/maps/map_cmb_Br_line.2000001.png b/tests/Rendering_tests/references/maps/map_cmb_Br_line.2000001.png new file mode 100644 index 00000000..f5f736a3 Binary files /dev/null and b/tests/Rendering_tests/references/maps/map_cmb_Br_line.2000001.png differ diff --git a/tests/Rendering_tests/references/maps/map_cmb_Br_line.2000002.png b/tests/Rendering_tests/references/maps/map_cmb_Br_line.2000002.png new file mode 100644 index 00000000..2d4b9472 Binary files /dev/null and b/tests/Rendering_tests/references/maps/map_cmb_Br_line.2000002.png differ diff --git a/tests/Rendering_tests/references/maps/map_cmb_T.2000001.png b/tests/Rendering_tests/references/maps/map_cmb_T.2000001.png new file mode 100644 index 00000000..acb2e988 Binary files /dev/null and b/tests/Rendering_tests/references/maps/map_cmb_T.2000001.png differ diff --git a/tests/Rendering_tests/references/maps/map_cmb_T.2000002.png b/tests/Rendering_tests/references/maps/map_cmb_T.2000002.png new file mode 100644 index 00000000..8aadb3ce Binary files /dev/null and b/tests/Rendering_tests/references/maps/map_cmb_T.2000002.png differ diff --git a/tests/Rendering_tests/references/maps/map_cmb_T_line.2000001.png b/tests/Rendering_tests/references/maps/map_cmb_T_line.2000001.png new file mode 100644 index 00000000..9e24029a Binary files /dev/null and b/tests/Rendering_tests/references/maps/map_cmb_T_line.2000001.png differ diff --git a/tests/Rendering_tests/references/maps/map_cmb_T_line.2000002.png b/tests/Rendering_tests/references/maps/map_cmb_T_line.2000002.png new file mode 100644 index 00000000..f21d9ae7 Binary files /dev/null and b/tests/Rendering_tests/references/maps/map_cmb_T_line.2000002.png differ diff --git a/tests/Rendering_tests/references/maps/zm_yz_magne.2000001.png b/tests/Rendering_tests/references/maps/zm_yz_magne.2000001.png new file mode 100644 index 00000000..e75d928c Binary files /dev/null and b/tests/Rendering_tests/references/maps/zm_yz_magne.2000001.png differ diff --git a/tests/Rendering_tests/references/maps/zm_yz_magne.2000002.png b/tests/Rendering_tests/references/maps/zm_yz_magne.2000002.png new file mode 100644 index 00000000..00c56c04 Binary files /dev/null and b/tests/Rendering_tests/references/maps/zm_yz_magne.2000002.png differ diff --git a/tests/Rendering_tests/references/maps/zm_yz_velo.2000001.png b/tests/Rendering_tests/references/maps/zm_yz_velo.2000001.png new file mode 100644 index 00000000..c9636bb3 Binary files /dev/null and b/tests/Rendering_tests/references/maps/zm_yz_velo.2000001.png differ diff --git a/tests/Rendering_tests/references/maps/zm_yz_velo.2000002.png b/tests/Rendering_tests/references/maps/zm_yz_velo.2000002.png new file mode 100644 index 00000000..62b39c85 Binary files /dev/null and b/tests/Rendering_tests/references/maps/zm_yz_velo.2000002.png differ diff --git a/tests/Rendering_tests/references/pvr/README b/tests/Rendering_tests/references/pvr/README new file mode 100644 index 00000000..285ef831 --- /dev/null +++ b/tests/Rendering_tests/references/pvr/README @@ -0,0 +1,6 @@ +!----------------------------------------------------------------------- +! Cross section data directory for dynamo benchmark test Case 2 +! Please see Christensen et.al. (2001) for the model description +!----------------------------------------------------------------------- +! + Restart data files are stored in this directory. diff --git a/tests/Rendering_tests/references/pvr/pvr_Bpole.2000001.png b/tests/Rendering_tests/references/pvr/pvr_Bpole.2000001.png new file mode 100644 index 00000000..69ae7aa4 Binary files /dev/null and b/tests/Rendering_tests/references/pvr/pvr_Bpole.2000001.png differ diff --git a/tests/Rendering_tests/references/pvr/pvr_Bpole.2000002.png b/tests/Rendering_tests/references/pvr/pvr_Bpole.2000002.png new file mode 100644 index 00000000..ebc10df7 Binary files /dev/null and b/tests/Rendering_tests/references/pvr/pvr_Bpole.2000002.png differ diff --git a/tests/Rendering_tests/references/pvr/pvr_Bz.2000001.png b/tests/Rendering_tests/references/pvr/pvr_Bz.2000001.png new file mode 100644 index 00000000..b9282e70 Binary files /dev/null and b/tests/Rendering_tests/references/pvr/pvr_Bz.2000001.png differ diff --git a/tests/Rendering_tests/references/pvr/pvr_Bz.2000002.png b/tests/Rendering_tests/references/pvr/pvr_Bz.2000002.png new file mode 100644 index 00000000..58577bce Binary files /dev/null and b/tests/Rendering_tests/references/pvr/pvr_Bz.2000002.png differ diff --git a/tests/Rendering_tests/references/pvr/pvr_temp.2000001.png b/tests/Rendering_tests/references/pvr/pvr_temp.2000001.png new file mode 100644 index 00000000..29a3558d Binary files /dev/null and b/tests/Rendering_tests/references/pvr/pvr_temp.2000001.png differ diff --git a/tests/Rendering_tests/references/pvr/pvr_temp.2000002.png b/tests/Rendering_tests/references/pvr/pvr_temp.2000002.png new file mode 100644 index 00000000..9d929aba Binary files /dev/null and b/tests/Rendering_tests/references/pvr/pvr_temp.2000002.png differ diff --git a/tests/Rendering_tests/references/pvr/pvr_vr.2000001.png b/tests/Rendering_tests/references/pvr/pvr_vr.2000001.png new file mode 100644 index 00000000..511f01bb Binary files /dev/null and b/tests/Rendering_tests/references/pvr/pvr_vr.2000001.png differ diff --git a/tests/Rendering_tests/references/pvr/pvr_vr.2000002.png b/tests/Rendering_tests/references/pvr/pvr_vr.2000002.png new file mode 100644 index 00000000..4dec35e1 Binary files /dev/null and b/tests/Rendering_tests/references/pvr/pvr_vr.2000002.png differ diff --git a/tests/Rendering_tests/references/pvr/pvr_wz.2000001.png b/tests/Rendering_tests/references/pvr/pvr_wz.2000001.png new file mode 100644 index 00000000..d31146ee Binary files /dev/null and b/tests/Rendering_tests/references/pvr/pvr_wz.2000001.png differ diff --git a/tests/Rendering_tests/references/pvr/pvr_wz.2000002.png b/tests/Rendering_tests/references/pvr/pvr_wz.2000002.png new file mode 100644 index 00000000..6bc07412 Binary files /dev/null and b/tests/Rendering_tests/references/pvr/pvr_wz.2000002.png differ diff --git a/tests/Rendering_tests/rst_6/rst.200.fsb.gz b/tests/Rendering_tests/rst_6/rst.200.fsb.gz new file mode 100644 index 00000000..fd08f6e6 Binary files /dev/null and b/tests/Rendering_tests/rst_6/rst.200.fsb.gz differ diff --git a/tests/Rendering_tests/sections/README b/tests/Rendering_tests/sections/README new file mode 100644 index 00000000..285ef831 --- /dev/null +++ b/tests/Rendering_tests/sections/README @@ -0,0 +1,6 @@ +!----------------------------------------------------------------------- +! Cross section data directory for dynamo benchmark test Case 2 +! Please see Christensen et.al. (2001) for the model description +!----------------------------------------------------------------------- +! + Restart data files are stored in this directory. diff --git a/tests/Rendering_tests/sph_lm47_r63c_6/README b/tests/Rendering_tests/sph_lm47_r63c_6/README new file mode 100644 index 00000000..285ef831 --- /dev/null +++ b/tests/Rendering_tests/sph_lm47_r63c_6/README @@ -0,0 +1,6 @@ +!----------------------------------------------------------------------- +! Cross section data directory for dynamo benchmark test Case 2 +! Please see Christensen et.al. (2001) for the model description +!----------------------------------------------------------------------- +! + Restart data files are stored in this directory. diff --git a/tests/Rendering_tests/sph_lm47_r63c_6/control_assemble_sph b/tests/Rendering_tests/sph_lm47_r63c_6/control_assemble_sph new file mode 100644 index 00000000..f350d47f --- /dev/null +++ b/tests/Rendering_tests/sph_lm47_r63c_6/control_assemble_sph @@ -0,0 +1,34 @@ +begin assemble_control +! + begin data_files_def + num_subdomain_ctl 64 + sph_file_prefix '../sph_lm127t192r224c_64/in' + restart_file_prefix '../sph_lm127t192r224c_64/rst' +! + sph_file_fmt_ctl 'merged_gz' + restart_file_fmt_ctl 'merged_gz' + end data_files_def +! + begin new_data_files_def + num_subdomain_ctl 6 + restart_file_prefix 'rst' + restart_file_fmt_ctl 'merged_bin_gz' + end new_data_files_def +! + file new_spherical_shell_ctl 'control_resolution' +! + begin control +!!!!! information for time integration + begin time_step_ctl + i_step_init_ctl 200 + i_step_number_ctl 200 + i_step_rst_ctl 1 + i_step_ucd_ctl 1 + end time_step_ctl +! begin new_time_step_ctl +! i_step_init_ctl 0 +! time_init_ctl 0.0 +! end new_time_step_ctl + end control +end assemble_control + diff --git a/tests/Rendering_tests/sph_lm47_r63c_6/control_resolution b/tests/Rendering_tests/sph_lm47_r63c_6/control_resolution new file mode 100644 index 00000000..a8a43b43 --- /dev/null +++ b/tests/Rendering_tests/sph_lm47_r63c_6/control_resolution @@ -0,0 +1,22 @@ +begin spherical_shell_ctl + begin num_domain_ctl + num_radial_domain_ctl 2 + num_horizontal_domain_ctl 3 + end num_domain_ctl +! + begin num_grid_sph + sph_coef_type_ctl no_pole + sph_grid_type_ctl with_pole + + truncation_level_ctl 47 +! + ngrid_meridonal_ctl 72 + ngrid_zonal_ctl 144 +! + radial_grid_type_ctl Chebyshev + num_fluid_grid_ctl 63 + fluid_core_size_ctl 1.0 + ICB_to_CMB_ratio_ctl 0.35 + end num_grid_sph +end spherical_shell_ctl + diff --git a/tests/Rendering_tests/view_defines/control_camera b/tests/Rendering_tests/view_defines/control_camera new file mode 100644 index 00000000..8fadb5f6 --- /dev/null +++ b/tests/Rendering_tests/view_defines/control_camera @@ -0,0 +1,29 @@ +! + begin view_transform_ctl + begin image_size_ctl + x_pixel_ctl 720 + y_pixel_ctl 600 + end image_size_ctl +! + array eye_position_ctl + eye_position_ctl x 15.5250 + eye_position_ctl y 2.44416 + eye_position_ctl z 19.1197 + end array eye_position_ctl +! + array look_at_point_ctl + look_at_point_ctl x 0.0 + look_at_point_ctl y 0.0 + look_at_point_ctl z 0.0 + end array look_at_point_ctl +! + array up_direction_ctl + up_direction_ctl x -0.751889 + up_direction_ctl y -0.181709 + up_direction_ctl z 0.633754 + end array up_direction_ctl +! + begin projection_matrix_ctl + perspective_angle_ctl 10.0 + end projection_matrix_ctl + end view_transform_ctl diff --git a/tests/Rendering_tests/view_defines/control_map_view b/tests/Rendering_tests/view_defines/control_map_view new file mode 100644 index 00000000..aa1fd4ac --- /dev/null +++ b/tests/Rendering_tests/view_defines/control_map_view @@ -0,0 +1,18 @@ +! +! +! example of control for Kemo's surface rendering +! + begin map_projection_ctl + projection_type_ctl Aitoff + begin image_size_ctl + x_pixel_ctl 640 + y_pixel_ctl 480 + end image_size_ctl +! + begin projection_matrix_ctl + perspective_xy_ratio_ctl 1.33333333333333e+00 +! + horizontal_range_ctl -2.4 2.4 + vertical_range_ctl -1.92 1.92 + end projection_matrix_ctl + end map_projection_ctl diff --git a/tests/Rendering_tests/view_defines/control_pole b/tests/Rendering_tests/view_defines/control_pole new file mode 100644 index 00000000..48fc3288 --- /dev/null +++ b/tests/Rendering_tests/view_defines/control_pole @@ -0,0 +1,34 @@ + begin view_transform_ctl +! + begin image_size_ctl + x_pixel_ctl 800 + y_pixel_ctl 600 + end image_size_ctl +! + array viewpoint_in_viewer_ctl 3 + viewpoint_in_viewer_ctl x 0.000000000000e+00 + viewpoint_in_viewer_ctl y 0.000000000000e+00 + viewpoint_in_viewer_ctl z 1.000000000000e+01 + end array viewpoint_in_viewer_ctl +! + scale_factor_ctl 3.752906696377e-01 +! + array look_at_point_ctl 3 + look_at_point_ctl x 0.000000000000e+00 + look_at_point_ctl y 0.000000000000e+00 + look_at_point_ctl z 0.000000000000e+00 + end array look_at_point_ctl +! + array view_rotation_vec_ctl 3 + view_rotation_vec_ctl x 0.0e+00 + view_rotation_vec_ctl y 0.0e+00 + view_rotation_vec_ctl z 1.0e+00 + end array view_rotation_vec_ctl + view_rotation_deg_ctl 2.70e+02 +! + begin projection_matrix_ctl + perspective_angle_ctl 8.000000000000e+00 + end projection_matrix_ctl +! + end view_transform_ctl +! diff --git a/tests/Rendering_tests/view_defines/control_view b/tests/Rendering_tests/view_defines/control_view new file mode 100644 index 00000000..c04509fa --- /dev/null +++ b/tests/Rendering_tests/view_defines/control_view @@ -0,0 +1,34 @@ + begin view_transform_ctl +! + begin image_size_ctl + x_pixel_ctl 800 + y_pixel_ctl 600 + end image_size_ctl +! + array viewpoint_in_viewer_ctl 3 + viewpoint_in_viewer_ctl x 0.000000000000e+00 + viewpoint_in_viewer_ctl y 0.000000000000e+00 + viewpoint_in_viewer_ctl z 1.000000000000e+01 + end array viewpoint_in_viewer_ctl +! + scale_factor_ctl 3.752906696377e-01 +! + array look_at_point_ctl 3 + look_at_point_ctl x 0.000000000000e+00 + look_at_point_ctl y 0.000000000000e+00 + look_at_point_ctl z 0.000000000000e+00 + end array look_at_point_ctl +! + array view_rotation_vec_ctl 3 + view_rotation_vec_ctl x -3.690266841943e-01 + view_rotation_vec_ctl y -4.439897059620e-01 + view_rotation_vec_ctl z -8.164053523597e-01 + end array view_rotation_vec_ctl + view_rotation_deg_ctl 1.144756353644e+02 +! + begin projection_matrix_ctl + perspective_angle_ctl 8.000000000000e+00 + end projection_matrix_ctl +! + end view_transform_ctl +! diff --git a/tests/Rendering_tests/view_defines/control_zm_view b/tests/Rendering_tests/view_defines/control_zm_view new file mode 100644 index 00000000..2cd5f291 --- /dev/null +++ b/tests/Rendering_tests/view_defines/control_zm_view @@ -0,0 +1,16 @@ +! +! +! example of control for Kemo's surface rendering +! + begin map_projection_ctl + projection_type_ctl xz_plane + begin image_size_ctl + x_pixel_ctl 480 + y_pixel_ctl 640 + end image_size_ctl +! + begin projection_matrix_ctl + horizontal_range_ctl 0.0 1.8 + vertical_range_ctl -1.8 1.8 + end projection_matrix_ctl + end map_projection_ctl diff --git a/tests/snapshot_test/ave_press_test.txt b/tests/snapshot_test/ave_press_test.txt deleted file mode 100644 index 656633de..00000000 --- a/tests/snapshot_test/ave_press_test.txt +++ /dev/null @@ -1,392 +0,0 @@ - Matrix for average pressure -k, r, a(k,k-1), a(k,k), a(k,k+1) - 1 3.846153846153855E-002 -1.000000000000000E+030 1.000000000000000E+000 0.000000000000000E+000 - 2 7.116310307661011E-002 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 3 1.037246345715643E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 4 1.360066994696026E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 5 1.678710610127989E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 6 1.991812711131193E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 7 2.298032546440834E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 8 2.596058835710391E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 9 2.884615384615385E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 10 3.162466549713396E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 11 3.428422529658989E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 12 3.681344460115730E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 13 3.920149290548123E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 14 4.143814422010271E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 15 4.351382086071560E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 16 4.541963446128111E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 17 4.714742403537578E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 18 4.868979092278826E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 19 5.004013047171818E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 20 5.119266032090913E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 21 5.214244516060726E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 22 5.288541786631537E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 23 5.341839691484437E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 24 5.373910000808402E-001 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 25 5.384615384615384E-001 0.000000000000000E+000 -1.745117152055719E+009 1.745120866341434E+009 - 26 5.395320768422367E-001 4.341517007716752E+008 -5.802316683284662E+008 1.460799675567909E+008 - 27 5.427391077746332E-001 7.233437373469011E+007 -1.165506682518483E+008 4.421629451715823E+007 - 28 5.480688982599232E-001 2.901068318519428E+007 -5.031295152340897E+007 2.130226833821469E+007 - 29 5.554986253170042E-001 1.563049205152470E+007 -2.823657436112545E+007 1.260608230960075E+007 - 30 5.649964737139855E-001 9.811972181033149E+006 -1.820502763382994E+007 8.393055452796793E+006 - 31 5.765217722058951E-001 6.770901294177487E+006 -1.280684523730546E+007 6.035943943127974E+006 - 32 5.900251676951942E-001 4.986305275908343E+006 -9.571578641305983E+006 4.585273365397639E+006 - 33 6.054488365693190E-001 3.852120691287336E+006 -7.482028487737804E+006 3.629907796450468E+006 - 34 6.227267323102658E-001 3.088180843873033E+006 -6.056411748098361E+006 2.968230904225329E+006 - 35 6.417848683159209E-001 2.550502171290022E+006 -5.042418557088568E+006 2.491916385798546E+006 - 36 6.625416347220497E-001 2.158957701605353E+006 -4.297496623446099E+006 2.138538921840746E+006 - 37 6.849081478682646E-001 1.866102454494147E+006 -3.736177887523318E+006 1.870075433029170E+006 - 38 7.087886309115039E-001 1.642413692201792E+006 -3.304719050208723E+006 1.662305358006932E+006 - 39 7.340808239571780E-001 1.468763329985340E+006 -2.967986672236349E+006 1.499223342251010E+006 - 40 7.606764219517372E-001 1.332339614509768E+006 -2.702267561911082E+006 1.369927947401315E+006 - 41 7.884615384615383E-001 1.224324163306001E+006 -2.491132178157572E+006 1.266808014851571E+006 - 42 8.173171933520378E-001 1.138512143858391E+006 -2.322956106020598E+006 1.184443962162207E+006 - 43 8.471198222789935E-001 1.070463200046384E+006 -2.189383487830629E+006 1.118920287784245E+006 - 44 8.777418058099575E-001 1.016963338137901E+006 -2.084347072557325E+006 1.067383734419424E+006 - 45 9.090520159102780E-001 9.756756905063555E+005 -2.003429061326547E+006 1.027753370820192E+006 - 46 9.409163774534742E-001 9.449099291131161E+005 -1.943437721950630E+006 9.985277928375136E+005 - 47 9.731984423515125E-001 9.234687570476582E+005 -1.902125356118177E+006 9.786565990705187E+005 - 48 1.005759973846467E+000 9.105463577697546E+005 -1.878002511792656E+006 9.674561540229013E+005 - 49 1.038461538461538E+000 9.056635051872859E+005 -1.870221009747260E+006 9.645575045599738E+005 - 50 1.071163103076610E+000 9.086301873089111E+005 -1.878509570056394E+006 9.698793827474829E+005 - 51 1.103724634571564E+000 9.195307139062994E+005 -1.903153495615584E+006 9.836227817092844E+005 - 52 1.136006699469602E+000 9.387293417726284E+005 -1.945015768911274E+006 1.006286427138646E+006 - 53 1.167871061012799E+000 9.668971146848000E+005 -2.005602283070297E+006 1.038705168385497E+006 - 54 1.199181271113119E+000 1.005063416459423E+006 -2.087179839991032E+006 1.082116423531609E+006 - 55 1.229803254644083E+000 1.054699251606884E+006 -2.192963247984720E+006 1.138263996377836E+006 - 56 1.259605883571039E+000 1.117844288786615E+006 -2.327399119729792E+006 1.209554830943177E+006 - 57 1.288461538461538E+000 1.197297490774676E+006 -2.496591736609156E+006 1.299294245834480E+006 - 58 1.316246654971339E+000 1.296903916852857E+006 -2.708945807660314E+006 1.412041890807457E+006 - 59 1.342842252965899E+000 1.421992090121676E+006 -2.976151831272249E+006 1.554159741150573E+006 - 60 1.368134446011573E+000 1.580055025487036E+006 -3.314731048894996E+006 1.734676023407960E+006 - 61 1.392014929054812E+000 1.781839429555182E+006 -3.748527406162724E+006 1.966687976607542E+006 - 62 1.414381442201027E+000 2.043145085488233E+006 -4.312866495599495E+006 2.269721410111262E+006 - 63 1.435138208607156E+000 2.387914245816063E+006 -5.061783935142444E+006 2.673869689326381E+006 - 64 1.454196344612811E+000 2.853784334489649E+006 -6.081210921083110E+006 3.227426586593462E+006 - 65 1.471474240353758E+000 3.502631184345186E+006 -7.514470263813373E+006 4.011839079468188E+006 - 66 1.486897909227882E+000 4.441972223060525E+006 -9.615233350738570E+006 5.173261127678046E+006 - 67 1.500401304717182E+000 5.872187548706667E+006 -1.286788033944560E+007 6.995692790738929E+006 - 68 1.511926603209091E+000 8.202443869863209E+006 -1.829509069814473E+007 1.009264682828152E+007 - 69 1.521424451606072E+000 1.237895471826116E+007 -2.838061828732684E+007 1.600166356906568E+007 - 70 1.528854178663154E+000 2.102355855741072E+007 -5.057584049400239E+007 2.955228193659168E+007 - 71 1.534183969148444E+000 4.386467039104225E+007 -1.171702082764917E+008 7.330553788544939E+007 - 72 1.537391000080840E+000 1.456891708988215E+008 -5.833480080504832E+008 4.376588371516617E+008 - 73 1.538461538461538E+000 1.745120866341796E+009 -1.745120866341796E+009 0.000000000000000E+000 - 74 1.539532076842236E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 75 1.542739107774633E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 76 1.548068898259923E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 77 1.555498625317004E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 78 1.564996473713985E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 79 1.576521772205895E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 80 1.590025167695194E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 81 1.605448836569319E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 82 1.622726732310266E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 83 1.641784868315921E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 84 1.662541634722050E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 85 1.684908147868265E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 86 1.708788630911504E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 87 1.734080823957178E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 88 1.760676421951737E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 89 1.788461538461538E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 90 1.817317193352038E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 91 1.847119822278993E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 92 1.877741805809957E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 93 1.909052015910278E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 94 1.940916377453474E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 95 1.973198442351512E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 - 96 2.005759973846467E+000 0.000000000000000E+000 1.000000000000000E+000 1.000000000000000E+030 - LU decomposition for average pressure -k, r, a(k,k-2), a(k,k-1), a(k,k), a(k,k+1), a(k,k+2) - 1 3.846153846153855E-002 -1.000000000000000E+030 -1.000000000000000E+030 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 2 7.116310307661011E-002 -1.000000000000000E+030 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 3 1.037246345715643E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 4 1.360066994696026E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 5 1.678710610127989E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 6 1.991812711131193E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 7 2.298032546440834E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 8 2.596058835710391E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 9 2.884615384615385E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 10 3.162466549713396E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 11 3.428422529658989E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 12 3.681344460115730E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 13 3.920149290548123E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 14 4.143814422010271E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 15 4.351382086071560E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 16 4.541963446128111E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 17 4.714742403537578E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 18 4.868979092278826E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 19 5.004013047171818E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 20 5.119266032090913E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 21 5.214244516060726E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 22 5.288541786631537E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 23 5.341839691484437E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 24 5.373910000808402E-001 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 25 5.384615384615384E-001 0.000000000000000E+000 0.000000000000000E+000 -1.745117152055719E+009 1.745120866341434E+009 0.000000000000000E+000 - 26 5.395320768422367E-001 0.000000000000000E+000 0.000000000000000E+000 7.233437373469011E+007 -1.165506682518483E+008 4.421629451715823E+007 - 27 5.427391077746332E-001 -2.487808341464363E-001 -2.019496899903844E+000 -8.929374565953818E+007 8.929466970263638E+007 0.000000000000000E+000 - 28 5.480688982599232E-001 0.000000000000000E+000 0.000000000000000E+000 1.563049205152470E+007 -2.823657436112545E+007 1.260608230960075E+007 - 29 5.554986253170042E-001 -3.248904273296706E-001 -1.362846931193040E+000 -1.717986037724921E+007 1.718016059000625E+007 0.000000000000000E+000 - 30 5.649964737139855E-001 0.000000000000000E+000 0.000000000000000E+000 6.770901294177487E+006 -1.280684523730546E+007 6.035943943127974E+006 - 31 5.765217722058951E-001 -5.711322423799705E-001 -1.239551963167589E+000 -7.481694703088673E+006 7.481866164273796E+006 0.000000000000000E+000 - 32 5.900251676951942E-001 0.000000000000000E+000 0.000000000000000E+000 3.852120691287336E+006 -7.482028487737804E+006 3.629907796450468E+006 - 33 6.054488365693190E-001 -6.664673544952113E-001 -1.190294764773552E+000 -4.320545973443246E+006 4.320660246725693E+006 0.000000000000000E+000 - 34 6.227267323102658E-001 0.000000000000000E+000 0.000000000000000E+000 2.550502171290022E+006 -5.042418557088568E+006 2.491916385798546E+006 - 35 6.417848683159209E-001 -7.147663426925455E-001 -1.163750911071721E+000 -2.899888285591446E+006 2.899969964287608E+006 0.000000000000000E+000 - 36 6.625416347220497E-001 0.000000000000000E+000 0.000000000000000E+000 1.866102454494147E+006 -3.736177887523318E+006 1.870075433029170E+006 - 37 6.849081478682646E-001 -7.444968526313500E-001 -1.145959648227467E+000 -2.142970175860716E+006 2.143030985392936E+006 0.000000000000000E+000 - 38 7.087886309115039E-001 0.000000000000000E+000 -7.664192953791912E-001 -1.662258752408095E+006 1.662305358006932E+006 0.000000000000000E+000 - 39 7.340808239571780E-001 0.000000000000000E+000 -8.835948842847475E-001 -1.499182161782299E+006 1.499223342251010E+006 0.000000000000000E+000 - 40 7.606764219517372E-001 0.000000000000000E+000 -8.887109575302173E-001 -1.369891349867535E+006 1.369927947401315E+006 0.000000000000000E+000 - 41 7.884615384615383E-001 0.000000000000000E+000 -8.937381518792644E-001 -1.266775306239367E+006 1.266808014851571E+006 0.000000000000000E+000 - 42 8.173171933520378E-001 0.000000000000000E+000 -8.987482928114958E-001 -1.184414565352829E+006 1.184443962162207E+006 0.000000000000000E+000 - 43 8.471198222789935E-001 0.000000000000000E+000 -9.037909794088871E-001 -1.118893719213105E+006 1.118920287784245E+006 0.000000000000000E+000 - 44 8.777418058099575E-001 0.000000000000000E+000 -9.089007478325208E-001 -1.067359586225246E+006 1.067383734419424E+006 0.000000000000000E+000 - 45 9.090520159102780E-001 0.000000000000000E+000 -9.141021480463453E-001 -1.027731296904022E+006 1.027753370820192E+006 0.000000000000000E+000 - 46 9.409163774534742E-001 0.000000000000000E+000 -9.194134030554481E-001 -9.985074977831296E+005 9.985277928375136E+005 0.000000000000000E+000 - 47 9.731984423515125E-001 0.000000000000000E+000 -9.248490963742674E-001 -9.786378292078107E+005 9.786565990705187E+005 0.000000000000000E+000 - 48 1.005759973846467E+000 0.000000000000000E+000 -9.304221956214641E-001 -9.674386901260291E+005 9.674561540229013E+005 0.000000000000000E+000 - 49 1.038461538461538E+000 0.000000000000000E+000 -9.361456332383237E-001 -9.645411558091777E+005 9.645575045599738E+005 0.000000000000000E+000 - 50 1.071163103076610E+000 0.000000000000000E+000 -9.420336103197573E-001 -9.698639816747460E+005 9.698793827474829E+005 0.000000000000000E+000 - 51 1.103724634571564E+000 0.000000000000000E+000 -9.481027559333300E-001 -9.836081799097783E+005 9.836227817092844E+005 0.000000000000000E+000 - 52 1.136006699469602E+000 0.000000000000000E+000 -9.543732564919637E-001 -1.006272491571700E+006 1.006286427138646E+006 0.000000000000000E+000 - 53 1.167871061012799E+000 0.000000000000000E+000 -9.608700652987145E-001 -1.038691778116376E+006 1.038705168385497E+006 0.000000000000000E+000 - 54 1.199181271113119E+000 0.000000000000000E+000 -9.676243113063472E-001 -1.082103466781673E+006 1.082116423531609E+006 0.000000000000000E+000 - 55 1.229803254644083E+000 0.000000000000000E+000 -9.746750509391748E-001 -1.138251367756932E+006 1.138263996377836E+006 0.000000000000000E+000 - 56 1.259605883571039E+000 0.000000000000000E+000 -9.820715533067786E-001 -1.209542428733829E+006 1.209554830943177E+006 0.000000000000000E+000 - 57 1.288461538461538E+000 0.000000000000000E+000 -9.898763882371857E-001 -1.299281969180285E+006 1.299294245834480E+006 0.000000000000000E+000 - 58 1.316246654971339E+000 0.000000000000000E+000 -9.981697180567136E-001 -1.412029636623000E+006 1.412041890807457E+006 0.000000000000000E+000 - 59 1.342842252965899E+000 0.000000000000000E+000 -1.007055413881045E+000 -1.554147400507773E+006 1.554159741150573E+006 0.000000000000000E+000 - 60 1.368134446011573E+000 0.000000000000000E+000 -1.016669992158272E+000 -1.734663477046741E+006 1.734676023407960E+006 0.000000000000000E+000 - 61 1.392014929054812E+000 0.000000000000000E+000 -1.027196025703359E+000 -1.966675089035161E+006 1.966687976607542E+006 0.000000000000000E+000 - 62 1.414381442201027E+000 0.000000000000000E+000 -1.038882882525648E+000 -2.269708021432918E+006 2.269721410111262E+006 0.000000000000000E+000 - 63 1.435138208607156E+000 0.000000000000000E+000 -1.052079925376709E+000 -2.673855603366668E+006 2.673869689326381E+006 0.000000000000000E+000 - 64 1.454196344612811E+000 0.000000000000000E+000 -1.067291865311063E+000 -3.227411552763244E+006 3.227426586593462E+006 0.000000000000000E+000 - 65 1.471474240353758E+000 0.000000000000000E+000 -1.085275654214692E+000 -4.011822763618262E+006 4.011839079468188E+006 0.000000000000000E+000 - 66 1.486897909227882E+000 0.000000000000000E+000 -1.107220454338893E+000 -5.173243062435277E+006 5.173261127678046E+006 0.000000000000000E+000 - 67 1.500401304717182E+000 0.000000000000000E+000 -1.135107606164240E+000 -6.995672284744455E+006 6.995692790738929E+006 0.000000000000000E+000 - 68 1.511926603209091E+000 0.000000000000000E+000 -1.172502589601056E+000 -1.009262278494990E+007 1.009264682828152E+007 0.000000000000000E+000 - 69 1.521424451606072E+000 0.000000000000000E+000 -1.226534963411160E+000 -1.600163407907881E+007 1.600166356906568E+007 0.000000000000000E+000 - 70 1.528854178663154E+000 0.000000000000000E+000 -1.313838227615626E+000 -2.955224319151960E+007 2.955228193659168E+007 0.000000000000000E+000 - 71 1.534183969148444E+000 0.000000000000000E+000 -1.484309333364913E+000 -7.330548037577730E+007 7.330553788544939E+007 0.000000000000000E+000 - 72 1.537391000080840E+000 0.000000000000000E+000 0.000000000000000E+000 1.745120866341796E+009 -1.745120866341796E+009 0.000000000000000E+000 - 73 1.538461538461538E+000 -1.987425362360251E+000 -2.507899202265122E-001 1.142961809039116E+002 0.000000000000000E+000 0.000000000000000E+000 - 74 1.539532076842236E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 75 1.542739107774633E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 76 1.548068898259923E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 77 1.555498625317004E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 78 1.564996473713985E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 79 1.576521772205895E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 80 1.590025167695194E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 81 1.605448836569319E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 82 1.622726732310266E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 83 1.641784868315921E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 84 1.662541634722050E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 85 1.684908147868265E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 86 1.708788630911504E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 87 1.734080823957178E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 88 1.760676421951737E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 89 1.788461538461538E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 90 1.817317193352038E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 91 1.847119822278993E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 92 1.877741805809957E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 93 1.909052015910278E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 94 1.940916377453474E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 0.000000000000000E+000 - 95 1.973198442351512E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+030 - 96 2.005759973846467E+000 0.000000000000000E+000 0.000000000000000E+000 1.000000000000000E+000 1.000000000000000E+030 1.000000000000000E+030 - RHS for average pressure - field ID, l, m: 13 0 0 - 1 0.0000000000000000 - 2 0.0000000000000000 - 3 0.0000000000000000 - 4 0.0000000000000000 - 5 0.0000000000000000 - 6 0.0000000000000000 - 7 0.0000000000000000 - 8 0.0000000000000000 - 9 0.0000000000000000 - 10 0.0000000000000000 - 11 0.0000000000000000 - 12 0.0000000000000000 - 13 0.0000000000000000 - 14 0.0000000000000000 - 15 0.0000000000000000 - 16 0.0000000000000000 - 17 0.0000000000000000 - 18 0.0000000000000000 - 19 0.0000000000000000 - 20 0.0000000000000000 - 21 0.0000000000000000 - 22 0.0000000000000000 - 23 0.0000000000000000 - 24 0.0000000000000000 - 25 -584116.48606233764 - 26 -16159522.004919827 - 27 -2724045.2539472599 - 28 -1783282.9962249291 - 29 -1228361.3776524677 - 30 -873151.53784186428 - 31 -594245.17922584293 - 32 -371621.19121649978 - 33 -205466.43460054303 - 34 -88093.093563015427 - 35 -10252.656419867504 - 36 34730.533024702570 - 37 52892.916831577197 - 38 51638.478373808197 - 39 39743.476045036470 - 40 25469.476659565898 - 41 14201.402056861276 - 42 7591.8087983947498 - 43 4674.1328623831687 - 44 3690.3311326537705 - 45 3305.0646790496548 - 46 2884.3082899486253 - 47 2258.1320751562735 - 48 1430.7617623244132 - 49 423.95740210030544 - 50 -763.94103511256435 - 51 -2149.2216205756686 - 52 -3745.5959904796619 - 53 -5552.6317693370656 - 54 -7552.1743728271476 - 55 -9712.6259893262650 - 56 -11998.673020504990 - 57 -14377.349357695401 - 58 -16803.932536310436 - 59 -19176.511791460252 - 60 -21275.021690389811 - 61 -22727.521589230666 - 62 -23028.816455367953 - 63 -21577.351562454820 - 64 -17685.022274970048 - 65 -10586.225001938550 - 66 495.87303173645159 - 67 16073.149621034892 - 68 35362.483894434263 - 69 54603.682391774077 - 70 67500.243462242652 - 71 70137.369884977015 - 72 65909.599062441630 - 73 75831.258495350456 - 74 0.0000000000000000 - 75 0.0000000000000000 - 76 0.0000000000000000 - 77 0.0000000000000000 - 78 0.0000000000000000 - 79 0.0000000000000000 - 80 0.0000000000000000 - 81 0.0000000000000000 - 82 0.0000000000000000 - 83 0.0000000000000000 - 84 0.0000000000000000 - 85 0.0000000000000000 - 86 0.0000000000000000 - 87 0.0000000000000000 - 88 0.0000000000000000 - 89 0.0000000000000000 - 90 0.0000000000000000 - 91 0.0000000000000000 - 92 0.0000000000000000 - 93 0.0000000000000000 - 94 0.0000000000000000 - 95 0.0000000000000000 - 96 0.0000000000000000 - Solution of average pressure - field ID, l, m: 13 0 0 - 1 0.0000000000000000 - 2 0.0000000000000000 - 3 0.0000000000000000 - 4 0.0000000000000000 - 5 0.0000000000000000 - 6 0.0000000000000000 - 7 0.0000000000000000 - 8 0.0000000000000000 - 9 0.0000000000000000 - 10 0.0000000000000000 - 11 0.0000000000000000 - 12 0.0000000000000000 - 13 0.0000000000000000 - 14 0.0000000000000000 - 15 0.0000000000000000 - 16 0.0000000000000000 - 17 0.0000000000000000 - 18 0.0000000000000000 - 19 0.0000000000000000 - 20 0.0000000000000000 - 21 0.0000000000000000 - 22 0.0000000000000000 - 23 0.0000000000000000 - 24 0.0000000000000000 - 25 -53240.482053909014 - 26 -53240.369072482208 - 27 -53240.143911174026 - 28 -53239.837172287131 - 29 -53239.503150503202 - 30 -53239.186433273921 - 31 -53238.920204947681 - 32 -53238.720010818826 - 33 -53238.583354222887 - 34 -53238.494935650226 - 35 -53238.432622624445 - 36 -53238.372958964806 - 37 -53238.296485327213 - 38 -53238.191890316666 - 39 -53238.057482546901 - 40 -53237.899296189433 - 41 -53237.726858341397 - 42 -53237.548993011012 - 43 -53237.371615562930 - 44 -53237.197742441051 - 45 -53237.028625266285 - 46 -53236.864861676957 - 47 -53236.707003126590 - 48 -53236.555739065720 - 49 -53236.411894095727 - 50 -53236.276392483320 - 51 -53236.150235647117 - 52 -53236.034484094635 - 53 -53235.930225724602 - 54 -53235.838520697711 - 55 -53235.760324681629 - 56 -53235.696402205038 - 57 -53235.647246349647 - 58 -53235.613014817332 - 59 -53235.593474975074 - 60 -53235.587935654279 - 61 -53235.595154633425 - 62 -53235.613251344083 - 63 -53235.639687637813 - 64 -53235.671366426912 - 65 -53235.704857337209 - 66 -53235.736736116298 - 67 -53235.764012678344 - 68 -53235.784611058334 - 69 -53235.797847880574 - 70 -53235.804675566978 - 71 -53235.807248702331 - 72 -53235.807831637350 - 73 -53235.807875090657 - 74 0.0000000000000000 - 75 0.0000000000000000 - 76 0.0000000000000000 - 77 0.0000000000000000 - 78 0.0000000000000000 - 79 0.0000000000000000 - 80 0.0000000000000000 - 81 0.0000000000000000 - 82 0.0000000000000000 - 83 0.0000000000000000 - 84 0.0000000000000000 - 85 0.0000000000000000 - 86 0.0000000000000000 - 87 0.0000000000000000 - 88 0.0000000000000000 - 89 0.0000000000000000 - 90 0.0000000000000000 - 91 0.0000000000000000 - 92 0.0000000000000000 - 93 0.0000000000000000 - 94 0.0000000000000000 - 95 0.0000000000000000 - 96 0.0000000000000000