2011-08-26 19:36:37 +05:30
! Copyright 2011 Max-Planck-Institut fuer Eisenforschung GmbH
2011-04-04 19:39:54 +05:30
!
! This file is part of DAMASK,
2011-11-04 01:02:11 +05:30
! the Duesseldorf Advanced Material Simulation Kit.
2011-04-04 19:39:54 +05:30
!
! DAMASK is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! DAMASK is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with DAMASK. If not, see <http://www.gnu.org/licenses/>.
!
!##############################################################
2010-06-08 15:40:57 +05:30
!* $Id$
2010-06-08 15:38:15 +05:30
!********************************************************************
! Material subroutine for BVP solution using spectral method
!
2012-01-04 23:13:26 +05:30
! Run 'DAMASK_spectral.exe --help' to get usage hints
!
2010-06-08 15:38:15 +05:30
! written by P. Eisenlohr,
! F. Roters,
! L. Hantcherli,
2011-02-07 20:05:42 +05:30
! W.A. Counts,
! D.D. Tjahjanto,
! C. Kords,
! M. Diehl,
2010-06-08 15:38:15 +05:30
! R. Lebensohn
!
! MPI fuer Eisenforschung, Duesseldorf
!
2011-05-11 22:08:45 +05:30
program DAMASK_spectral
2010-06-10 20:21:10 +05:30
!********************************************************************
2010-06-08 15:38:15 +05:30
2011-05-11 22:31:03 +05:30
use DAMASK_interface
2012-01-13 21:48:16 +05:30
use prec , only : pInt , pReal , DAMASK_NaN
2010-06-10 20:21:10 +05:30
use IO
2012-01-13 21:48:16 +05:30
use debug , only : debug_spectral , &
debug_spectralGeneral , &
debug_spectralDivergence , &
debug_spectralRestart , &
debug_spectralFFTW
2010-07-05 21:31:36 +05:30
use math
2012-01-04 23:13:26 +05:30
use kdtree2_module
2012-01-13 21:48:16 +05:30
use mesh , only : mesh_ipCenterOfGravity
use CPFEM , only : CPFEM_general , CPFEM_initAll
use FEsolving , only : restartWrite , restartReadInc
use numerics , only : err_div_tol , err_stress_tolrel , rotation_tol , &
itmax , memory_efficient , DAMASK_NumThreadsInt , divergence_correction , &
fftw_planner_flag , fftw_timelimit
2010-10-27 22:45:49 +05:30
use homogenization , only : materialpoint_sizeResults , materialpoint_results
2011-11-21 23:42:40 +05:30
!$ use OMP_LIB ! the openMP function library
added fftw3 as fft(library will not versioned, should be in a linkable folder) , did some corrections on the code, splitted main file up (allows use of makefile), added makefile
changes on mpie_spectral.f90:
new structure, changed variable names, now using defgrad instead of disgrad, cleaned up, removed augmented Lagrange.
ToDo: Implement Augmented Lagrange again (but then a working version), implement Large strain, think about complex-to real-transform backwards, try to implement MP-support
2010-08-27 22:09:38 +05:30
2010-06-08 15:38:15 +05:30
implicit none
2011-01-07 18:26:45 +05:30
! variables to read from loadcase and geom file
2011-11-21 23:42:40 +05:30
real ( pReal ) , dimension ( 9 ) :: temp_valueVector ! stores information temporarily from loadcase file
2011-11-15 23:24:18 +05:30
logical , dimension ( 9 ) :: temp_maskVector
2011-10-18 20:15:32 +05:30
integer ( pInt ) , parameter :: maxNchunksLoadcase = &
2012-01-12 15:53:05 +05:30
( 1_pInt + 9_pInt ) * 3_pInt + & ! deformation, rotation, and stress
( 1_pInt + 1_pInt ) * 5_pInt + & ! time, (log)incs, temp, restartfrequency, and outputfrequency
1_pInt , & ! dropguessing
2012-01-12 20:38:44 +05:30
maxNchunksGeom = 7_pInt , & ! 4 identifiers, 3 values
2012-01-12 15:53:05 +05:30
myUnit = 234_pInt
integer ( pInt ) , dimension ( 1_pInt + maxNchunksLoadcase * 2_pInt ) :: positions ! this is longer than needed for geometry parsing
2011-11-15 23:24:18 +05:30
integer ( pInt ) :: headerLength , N_l = 0_pInt , N_t = 0_pInt , N_n = 0_pInt , N_Fdot = 0_pInt
2011-10-18 20:15:32 +05:30
character ( len = 1024 ) :: path , line , keyword
2011-11-07 23:55:10 +05:30
logical :: gotResolution = . false . , gotDimension = . false . , gotHomogenization = . false .
2011-11-15 23:24:18 +05:30
type bc_type
2012-01-13 21:48:16 +05:30
real ( pReal ) , dimension ( 3 , 3 ) :: deformation = 0.0_pReal , & ! applied velocity gradient or time derivative of deformation gradient
stress = 0.0_pReal , & ! stress BC (if applicable)
rotation = math_I3 ! rotation of BC (if applicable)
real ( pReal ) :: time = 0.0_pReal , & ! length of increment
temperature = 300_pReal ! isothermal starting conditions
integer ( pInt ) :: incs = 0_pInt , & ! number of increments
outputfrequency = 1_pInt , & ! frequency of result writes
restartfrequency = 0_pInt , & ! frequency of restart writes
logscale = 0_pInt ! linear/logaritmic time inc flag
logical :: followFormerTrajectory = . true . , & ! follow trajectory of former loadcase
velGradApplied = . false . ! decide wether velocity gradient or fdot is given
logical , dimension ( 3 , 3 ) :: maskDeformation = . false . , & ! mask of deformation boundary conditions
maskStress = . false . ! mask of stress boundary conditions
logical , dimension ( 9 ) :: maskStressVector = . false . ! linear mask of boundary conditions
2011-11-15 23:24:18 +05:30
end type
2012-01-13 21:48:16 +05:30
2011-12-04 15:31:32 +05:30
type ( bc_type ) , allocatable , dimension ( : ) :: bc
2012-01-12 15:53:05 +05:30
character ( len = 6 ) :: loadcase_string
2010-07-01 20:50:06 +05:30
2011-01-07 18:26:45 +05:30
! variables storing information from geom file
2011-12-04 15:31:32 +05:30
real ( pReal ) :: wgt
real ( pReal ) , dimension ( 3 ) :: geomdimension = 0.0_pReal ! physical dimension of volume element per direction
integer ( pInt ) :: Npoints , & ! number of Fourier points
homog ! homogenization scheme used
integer ( pInt ) , dimension ( 3 ) :: res = 1_pInt ! resolution (number of Fourier points) in each direction
2012-01-13 21:48:16 +05:30
integer ( pInt ) :: res1_red
2010-07-01 20:50:06 +05:30
2011-11-07 23:55:10 +05:30
! stress, stiffness and compliance average etc.
2011-12-06 22:28:17 +05:30
real ( pReal ) , dimension ( 3 , 3 ) :: pstress , pstress_av , defgrad_av_lab , &
2011-12-04 15:31:32 +05:30
defgradAim = math_I3 , defgradAimOld = math_I3 , defgradAimCorr = math_I3 , &
mask_stress , mask_defgrad , fDot , &
2011-12-06 22:28:17 +05:30
pstress_av_lab , defgradAim_lab ! quantities rotated to other coordinate system
2011-12-04 15:31:32 +05:30
real ( pReal ) , dimension ( 3 , 3 , 3 , 3 ) :: dPdF , c0_reference , c_current = 0.0_pReal , s_prev , c_prev ! stiffness and compliance
real ( pReal ) , dimension ( 6 ) :: cstress ! cauchy stress
real ( pReal ) , dimension ( 6 , 6 ) :: dsde ! small strain stiffness
real ( pReal ) , dimension ( 9 , 9 ) :: s_prev99 , c_prev99 ! compliance and stiffness in matrix notation
real ( pReal ) , dimension ( : , : ) , allocatable :: s_reduced , c_reduced ! reduced compliance and stiffness (only for stress BC)
integer ( pInt ) :: size_reduced = 0.0_pReal ! number of stress BCs
2011-10-18 20:15:32 +05:30
! pointwise data
2012-01-13 21:48:16 +05:30
real ( pReal ) , dimension ( : , : , : , : , : ) , allocatable :: defgrad , defgradold
2011-11-15 23:24:18 +05:30
real ( pReal ) , dimension ( : , : , : , : ) , allocatable :: coordinates
real ( pReal ) , dimension ( : , : , : ) , allocatable :: temperature
2011-10-18 20:15:32 +05:30
2011-10-25 19:08:24 +05:30
! variables storing information for spectral method and FFTW
2011-08-26 19:36:37 +05:30
real ( pReal ) , dimension ( 3 , 3 ) :: xiDyad ! product of wave vectors
real ( pReal ) , dimension ( : , : , : , : , : , : , : ) , allocatable :: gamma_hat ! gamma operator (field) for spectral method
2011-12-23 18:00:35 +05:30
real ( pReal ) , dimension ( : , : , : , : ) , allocatable :: xi ! wave vector field for divergence and for gamma operator
2011-08-26 19:36:37 +05:30
integer ( pInt ) , dimension ( 3 ) :: k_s
2012-01-13 21:48:16 +05:30
type ( C_PTR ) :: data_fftw , fftw_stress , fftw_fluctuation
real ( pReal ) , dimension ( : , : , : , : , : ) , pointer :: data_real
complex ( pReal ) , dimension ( : , : , : , : , : ) , pointer :: data_complex
!debugging (proof of correct transformation)
type ( C_PTR ) :: fftw_debug , fftw_debug_forward , fftw_debug_backward
real ( pReal ) , dimension ( : , : , : ) , pointer :: fftw_debug_real
complex ( pReal ) , dimension ( : , : , : ) , pointer :: fftw_debug_complex
2012-01-04 23:13:26 +05:30
! variables for regriding
real ( pReal ) , dimension ( : , : , : , : ) , allocatable :: deformed_small
real ( pReal ) , dimension ( : , : ) , allocatable :: deformed_large
real ( pReal ) , dimension ( : , : , : , : ) , allocatable :: new_coordinates
type ( kdtree2 ) , pointer :: tree
real ( pReal ) , dimension ( 3 ) :: shift
2011-02-07 20:05:42 +05:30
! loop variables, convergence etc.
2011-11-11 19:47:43 +05:30
real ( pReal ) :: time = 0.0_pReal , time0 = 0.0_pReal , timeinc ! elapsed time, begin of interval, time interval
2011-11-18 03:41:05 +05:30
real ( pReal ) :: guessmode , err_div , err_stress , err_stress_tol , p_hat_avg
2011-12-23 18:00:35 +05:30
complex ( pReal ) :: err_div_avg_complex
2011-11-15 23:24:18 +05:30
complex ( pReal ) , parameter :: img = cmplx ( 0.0_pReal , 1.0_pReal )
real ( pReal ) , dimension ( 3 , 3 ) , parameter :: ones = 1.0_pReal , zeroes = 0.0_pReal
2012-01-13 21:48:16 +05:30
complex ( pReal ) , dimension ( 3 ) :: temp3_Complex
2011-11-15 23:24:18 +05:30
complex ( pReal ) , dimension ( 3 , 3 ) :: temp33_Complex
2012-01-13 21:48:16 +05:30
real ( pReal ) , dimension ( 3 , 3 ) :: temp33_Real
2011-12-04 15:31:32 +05:30
integer ( pInt ) :: i , j , k , l , m , n , p , errorID
2012-01-13 21:48:16 +05:30
integer ( pInt ) :: N_Loadcases , loadcase , inc , iter , ielem , CPFEM_mode , &
ierr , notConvergedCounter = 0_pInt , totalIncsCounter = 0_pInt
logical :: errmatinv
2011-11-11 19:47:43 +05:30
real ( pReal ) :: defgradDet , defgradDetMax , defgradDetMin
2011-11-15 23:24:18 +05:30
real ( pReal ) :: correctionFactor
2011-12-23 18:00:35 +05:30
integer ( pInt ) , dimension ( 3 ) :: cutting_freq
2011-11-15 23:24:18 +05:30
2011-12-04 15:31:32 +05:30
! --- debugging variables
2012-01-13 21:48:16 +05:30
type ( C_PTR ) :: divergence
real ( pReal ) , dimension ( : , : , : , : ) , pointer :: divergence_real
complex ( pReal ) , dimension ( : , : , : , : ) , pointer :: divergence_complex
2011-11-15 23:24:18 +05:30
real ( pReal ) :: p_real_avg , err_div_max , err_real_div_avg , err_real_div_max
2012-01-13 21:48:16 +05:30
logical :: debugGeneral , debugDivergence , debugRestart , debugFFTW
type ( C_PTR ) :: fftw_divergence ! plan for fftw backward transform of divergence
integer ( pInt ) :: row , column
2011-12-04 15:31:32 +05:30
! --- initializing model size independed parameters
2011-12-23 18:00:35 +05:30
!$ call omp_set_num_threads(DAMASK_NumThreadsInt) ! set number of threads for parallel execution set by DAMASK_NUM_THREADS
2011-08-26 19:36:37 +05:30
2011-11-04 01:02:11 +05:30
call DAMASK_interface_init ( )
2011-12-23 18:00:35 +05:30
2011-11-04 01:02:11 +05:30
print '(a)' , ''
2012-01-13 21:48:16 +05:30
print '(a)' , ' <<<+- DAMASK_spectral init -+>>>'
print '(a)' , ' $Id$'
2011-11-04 01:02:11 +05:30
print '(a)' , ''
2011-11-15 23:24:18 +05:30
print '(a,a)' , ' Working Directory: ' , trim ( getSolverWorkingDirectoryName ( ) )
print '(a,a)' , ' Solver Job Name: ' , trim ( getSolverJobName ( ) )
2011-11-04 01:02:11 +05:30
print '(a)' , ''
2011-11-18 03:41:05 +05:30
! Reading the loadcase file and allocate variables for loadcases
2011-11-04 01:02:11 +05:30
path = getLoadcaseName ( )
2011-12-04 15:31:32 +05:30
if ( . not . IO_open_file ( myUnit , path ) ) call IO_error ( error_ID = 30_pInt , ext_msg = trim ( path ) )
2011-10-18 20:15:32 +05:30
rewind ( myUnit )
2010-06-10 20:21:10 +05:30
do
2011-10-18 20:15:32 +05:30
read ( myUnit , '(a1024)' , END = 100 ) line
2011-11-04 01:02:11 +05:30
if ( IO_isBlank ( line ) ) cycle ! skip empty lines
2012-01-12 15:53:05 +05:30
positions = IO_stringPos ( line , maxNchunksLoadcase )
2011-11-15 23:24:18 +05:30
do i = 1_pInt , maxNchunksLoadcase , 1_pInt ! reading compulsory parameters for loadcase
2012-01-12 15:53:05 +05:30
select case ( IO_lc ( IO_stringValue ( line , positions , i ) ) )
2012-01-13 21:48:16 +05:30
case ( 'l' , 'velocitygrad' , 'velgrad' , 'velocitygradient' )
2011-11-15 23:24:18 +05:30
N_l = N_l + 1_pInt
2011-07-13 22:03:12 +05:30
case ( 'fdot' )
2011-11-15 23:24:18 +05:30
N_Fdot = N_Fdot + 1_pInt
2012-01-13 21:48:16 +05:30
case ( 't' , 'time' , 'delta' )
2011-11-15 23:24:18 +05:30
N_t = N_t + 1_pInt
2012-01-13 21:48:16 +05:30
case ( 'n' , 'incs' , 'increments' , 'steps' , 'logincs' , 'logsteps' )
2011-11-15 23:24:18 +05:30
N_n = N_n + 1_pInt
2010-06-10 20:21:10 +05:30
end select
2011-11-04 01:02:11 +05:30
enddo ! count all identifiers to allocate memory and do sanity check
2010-06-10 20:21:10 +05:30
enddo
2010-06-10 14:20:04 +05:30
2011-10-18 20:15:32 +05:30
100 N_Loadcases = N_n
2011-11-04 01:02:11 +05:30
if ( ( N_l + N_Fdot / = N_n ) . or . ( N_n / = N_t ) ) & ! sanity check
2011-11-15 23:24:18 +05:30
call IO_error ( error_ID = 37_pInt , ext_msg = trim ( path ) ) ! error message for incomplete loadcase
allocate ( bc ( N_Loadcases ) )
2010-06-10 20:21:10 +05:30
2011-12-04 15:31:32 +05:30
! --- reading the loadcase and assign values to the allocated data structure
2011-10-18 20:15:32 +05:30
rewind ( myUnit )
2011-07-14 15:07:31 +05:30
loadcase = 0_pInt
2010-06-10 20:21:10 +05:30
do
2011-10-18 20:15:32 +05:30
read ( myUnit , '(a1024)' , END = 101 ) line
2011-11-15 23:24:18 +05:30
if ( IO_isBlank ( line ) ) cycle ! skip empty lines
loadcase = loadcase + 1_pInt
2012-01-12 15:53:05 +05:30
positions = IO_stringPos ( line , maxNchunksLoadcase )
2011-11-15 23:24:18 +05:30
do j = 1_pInt , maxNchunksLoadcase
2012-01-12 15:53:05 +05:30
select case ( IO_lc ( IO_stringValue ( line , positions , j ) ) )
2011-11-21 23:42:40 +05:30
case ( 'fdot' , 'l' , 'velocitygrad' , 'velgrad' , 'velocitygradient' ) ! assign values for the deformation BC matrix
2012-01-12 15:53:05 +05:30
bc ( loadcase ) % velGradApplied = ( IO_lc ( IO_stringValue ( line , positions , j ) ) == 'l' . or . & ! in case of given L, set flag to true
IO_lc ( IO_stringValue ( line , positions , j ) ) == 'velocitygrad' . or . &
IO_lc ( IO_stringValue ( line , positions , j ) ) == 'velgrad' . or . &
IO_lc ( IO_stringValue ( line , positions , j ) ) == 'velocitygradient' )
2011-11-15 23:24:18 +05:30
temp_valueVector = 0.0_pReal
temp_maskVector = . false .
2012-01-12 15:53:05 +05:30
forall ( k = 1_pInt : 9_pInt ) temp_maskVector ( k ) = IO_stringValue ( line , positions , j + k ) / = '*'
2011-11-15 23:24:18 +05:30
do k = 1_pInt , 9_pInt
2012-01-12 15:53:05 +05:30
if ( temp_maskVector ( k ) ) temp_valueVector ( k ) = IO_floatValue ( line , positions , j + k )
2010-06-10 20:21:10 +05:30
enddo
2011-11-15 23:24:18 +05:30
bc ( loadcase ) % maskDeformation = transpose ( reshape ( temp_maskVector , ( / 3 , 3 / ) ) )
bc ( loadcase ) % deformation = math_plain9to33 ( temp_valueVector )
2012-01-13 21:48:16 +05:30
case ( 'p' , 'pk1' , 'piolakirchhoff' , 'stress' )
2011-11-15 23:24:18 +05:30
temp_valueVector = 0.0_pReal
2012-01-12 15:53:05 +05:30
forall ( k = 1_pInt : 9_pInt ) bc ( loadcase ) % maskStressVector ( k ) = IO_stringValue ( line , positions , j + k ) / = '*'
2011-11-15 23:24:18 +05:30
do k = 1_pInt , 9_pInt
2012-01-12 15:53:05 +05:30
if ( bc ( loadcase ) % maskStressVector ( k ) ) temp_valueVector ( k ) = IO_floatValue ( line , positions , j + k ) ! assign values for the bc(loadcase)%stress matrix
2010-06-10 20:21:10 +05:30
enddo
2011-11-15 23:24:18 +05:30
bc ( loadcase ) % maskStress = transpose ( reshape ( bc ( loadcase ) % maskStressVector , ( / 3 , 3 / ) ) )
bc ( loadcase ) % stress = math_plain9to33 ( temp_valueVector )
case ( 't' , 'time' , 'delta' ) ! increment time
2012-01-13 21:48:16 +05:30
bc ( loadcase ) % time = IO_floatValue ( line , positions , j + 1_pInt )
2011-11-15 23:24:18 +05:30
case ( 'temp' , 'temperature' ) ! starting temperature
2012-01-12 15:53:05 +05:30
bc ( loadcase ) % temperature = IO_floatValue ( line , positions , j + 1_pInt )
case ( 'n' , 'incs' , 'increments' , 'steps' ) ! number of increments
2012-01-13 21:48:16 +05:30
bc ( loadcase ) % incs = IO_intValue ( line , positions , j + 1_pInt )
2012-01-12 15:53:05 +05:30
case ( 'logincs' , 'logincrements' , 'logsteps' ) ! number of increments (switch to log time scaling)
2012-01-13 21:48:16 +05:30
bc ( loadcase ) % incs = IO_intValue ( line , positions , j + 1_pInt )
2011-11-15 23:24:18 +05:30
bc ( loadcase ) % logscale = 1_pInt
case ( 'f' , 'freq' , 'frequency' , 'outputfreq' ) ! frequency of result writings
2012-01-12 15:53:05 +05:30
bc ( loadcase ) % outputfrequency = IO_intValue ( line , positions , j + 1_pInt )
2011-11-15 23:24:18 +05:30
case ( 'r' , 'restart' , 'restartwrite' ) ! frequency of writing restart information
2012-01-12 15:53:05 +05:30
bc ( loadcase ) % restartfrequency = max ( 0_pInt , IO_intValue ( line , positions , j + 1_pInt ) )
2011-07-14 15:07:31 +05:30
case ( 'guessreset' , 'dropguessing' )
2011-11-15 23:24:18 +05:30
bc ( loadcase ) % followFormerTrajectory = . false . ! do not continue to predict deformation along former trajectory
case ( 'euler' ) ! rotation of loadcase given in euler angles
p = 0_pInt ! assuming values given in radians
l = 1_pInt ! assuming keyword indicating degree/radians
2012-01-12 15:53:05 +05:30
select case ( IO_lc ( IO_stringValue ( line , positions , j + 1_pInt ) ) )
2011-10-18 20:15:32 +05:30
case ( 'deg' , 'degree' )
2011-11-15 23:24:18 +05:30
p = 1_pInt ! for conversion from degree to radian
2011-10-18 20:15:32 +05:30
case ( 'rad' , 'radian' )
case default
2012-01-12 15:53:05 +05:30
l = 0_pInt ! immediately reading in angles, assuming radians
2011-10-18 20:15:32 +05:30
end select
2012-01-12 15:53:05 +05:30
forall ( k = 1_pInt : 3_pInt ) temp33_Real ( k , 1 ) = IO_floatValue ( line , positions , j + l + k ) * real ( p , pReal ) * inRad
2011-11-15 23:24:18 +05:30
bc ( loadcase ) % rotation = math_EulerToR ( temp33_Real ( : , 1 ) )
case ( 'rotation' , 'rot' ) ! assign values for the rotation of loadcase matrix
temp_valueVector = 0.0_pReal
2012-01-12 15:53:05 +05:30
forall ( k = 1_pInt : 9_pInt ) temp_valueVector ( k ) = IO_floatValue ( line , positions , j + k )
2011-11-15 23:24:18 +05:30
bc ( loadcase ) % rotation = math_plain9to33 ( temp_valueVector )
2010-06-10 20:21:10 +05:30
end select
added fftw3 as fft(library will not versioned, should be in a linkable folder) , did some corrections on the code, splitted main file up (allows use of makefile), added makefile
changes on mpie_spectral.f90:
new structure, changed variable names, now using defgrad instead of disgrad, cleaned up, removed augmented Lagrange.
ToDo: Implement Augmented Lagrange again (but then a working version), implement Large strain, think about complex-to real-transform backwards, try to implement MP-support
2010-08-27 22:09:38 +05:30
enddo ; enddo
2011-10-18 20:15:32 +05:30
101 close ( myUnit )
added fftw3 as fft(library will not versioned, should be in a linkable folder) , did some corrections on the code, splitted main file up (allows use of makefile), added makefile
changes on mpie_spectral.f90:
new structure, changed variable names, now using defgrad instead of disgrad, cleaned up, removed augmented Lagrange.
ToDo: Implement Augmented Lagrange again (but then a working version), implement Large strain, think about complex-to real-transform backwards, try to implement MP-support
2010-08-27 22:09:38 +05:30
2011-12-04 15:31:32 +05:30
! --- read header of geom file to get the information needed before the complete geom file is intepretated by mesh.f90
2011-02-21 20:07:38 +05:30
path = getModelName ( )
2011-11-18 03:41:05 +05:30
2011-10-18 20:15:32 +05:30
if ( . not . IO_open_file ( myUnit , trim ( path ) / / InputFileExtension ) ) &
2011-11-15 23:24:18 +05:30
call IO_error ( error_ID = 101_pInt , ext_msg = trim ( path ) / / InputFileExtension )
2011-10-18 20:15:32 +05:30
rewind ( myUnit )
read ( myUnit , '(a1024)' ) line
2012-01-12 15:53:05 +05:30
positions = IO_stringPos ( line , 2_pInt )
keyword = IO_lc ( IO_StringValue ( line , positions , 2_pInt ) )
2011-10-18 20:15:32 +05:30
if ( keyword ( 1 : 4 ) == 'head' ) then
2012-01-12 15:53:05 +05:30
headerLength = IO_intValue ( line , positions , 1_pInt ) + 1_pInt
2011-10-18 20:15:32 +05:30
else
2011-11-15 23:24:18 +05:30
call IO_error ( error_ID = 42_pInt )
2011-10-18 20:15:32 +05:30
endif
rewind ( myUnit )
2011-11-15 23:24:18 +05:30
do i = 1_pInt , headerLength
2011-10-18 20:15:32 +05:30
read ( myUnit , '(a1024)' ) line
2012-01-12 15:53:05 +05:30
positions = IO_stringPos ( line , maxNchunksGeom )
select case ( IO_lc ( IO_StringValue ( line , positions , 1 ) ) )
2010-06-25 17:01:05 +05:30
case ( 'dimension' )
2010-09-22 17:34:43 +05:30
gotDimension = . true .
2011-11-15 23:24:18 +05:30
do j = 2_pInt , 6_pInt , 2_pInt
2012-01-12 15:53:05 +05:30
select case ( IO_lc ( IO_stringValue ( line , positions , j ) ) )
2010-09-22 17:34:43 +05:30
case ( 'x' )
2012-01-12 15:53:05 +05:30
geomdimension ( 1 ) = IO_floatValue ( line , positions , j + 1_pInt )
2010-09-22 17:34:43 +05:30
case ( 'y' )
2012-01-12 15:53:05 +05:30
geomdimension ( 2 ) = IO_floatValue ( line , positions , j + 1_pInt )
2010-09-22 17:34:43 +05:30
case ( 'z' )
2012-01-12 15:53:05 +05:30
geomdimension ( 3 ) = IO_floatValue ( line , positions , j + 1_pInt )
2010-09-22 17:34:43 +05:30
end select
enddo
2010-06-25 17:01:05 +05:30
case ( 'homogenization' )
2010-09-22 17:34:43 +05:30
gotHomogenization = . true .
2012-01-12 15:53:05 +05:30
homog = IO_intValue ( line , positions , 2_pInt )
2010-06-25 17:01:05 +05:30
case ( 'resolution' )
2010-09-22 17:34:43 +05:30
gotResolution = . true .
2011-11-15 23:24:18 +05:30
do j = 2_pInt , 6_pInt , 2_pInt
2012-01-12 15:53:05 +05:30
select case ( IO_lc ( IO_stringValue ( line , positions , j ) ) )
2010-09-22 17:34:43 +05:30
case ( 'a' )
2012-01-12 15:53:05 +05:30
res ( 1 ) = IO_intValue ( line , positions , j + 1_pInt )
2010-09-22 17:34:43 +05:30
case ( 'b' )
2012-01-12 15:53:05 +05:30
res ( 2 ) = IO_intValue ( line , positions , j + 1_pInt )
2010-09-22 17:34:43 +05:30
case ( 'c' )
2012-01-12 15:53:05 +05:30
res ( 3 ) = IO_intValue ( line , positions , j + 1_pInt )
2010-09-22 17:34:43 +05:30
end select
enddo
2010-06-25 17:01:05 +05:30
end select
enddo
2011-10-18 20:15:32 +05:30
close ( myUnit )
2011-12-04 15:31:32 +05:30
if ( . not . ( gotDimension . and . gotHomogenization . and . gotResolution ) ) call IO_error ( error_ID = 45_pInt )
2012-01-13 21:48:16 +05:30
2011-11-21 23:42:40 +05:30
if ( mod ( res ( 1 ) , 2_pInt ) / = 0_pInt . or . &
mod ( res ( 2 ) , 2_pInt ) / = 0_pInt . or . &
2011-12-04 15:31:32 +05:30
( mod ( res ( 3 ) , 2_pInt ) / = 0_pInt . and . res ( 3 ) / = 1_pInt ) ) call IO_error ( error_ID = 103_pInt )
2012-01-13 21:48:16 +05:30
res1_red = res ( 1 ) / 2_pInt + 1_pInt ! size of complex array in first dimension (c2r, r2c)
2011-12-04 15:31:32 +05:30
Npoints = res ( 1 ) * res ( 2 ) * res ( 3 )
2012-01-13 21:48:16 +05:30
wgt = 1.0_pReal / real ( Npoints , pReal )
2011-12-04 15:31:32 +05:30
! --- initialization of CPFEM_general (= constitutive law)
2011-11-15 23:24:18 +05:30
call CPFEM_initAll ( bc ( 1 ) % temperature , 1_pInt , 1_pInt )
2011-11-11 19:47:43 +05:30
2011-12-04 15:31:32 +05:30
! --- debugging parameters
2012-01-12 15:53:05 +05:30
debugGeneral = iand ( debug_spectral , debug_spectralGeneral ) > 0_pInt
debugDivergence = iand ( debug_spectral , debug_spectralDivergence ) > 0_pInt
debugRestart = iand ( debug_spectral , debug_spectralRestart ) > 0_pInt
2012-01-13 21:48:16 +05:30
debugFFTW = iand ( debug_spectral , debug_spectralFFTW ) > 0_pInt
2011-11-21 23:42:40 +05:30
2011-12-04 15:31:32 +05:30
! --- output of geometry
print '(a)' , ''
print '(a)' , '#############################################################'
print '(a)' , 'DAMASK spectral:'
print '(a)' , 'The spectral method boundary value problem solver for'
print '(a)' , 'the Duesseldorf Advanced Material Simulation Kit'
print '(a)' , '#############################################################'
print '(a,a)' , 'geometry file: ' , trim ( path ) / / '.geom'
print '(a)' , '============================================================='
2011-11-21 23:42:40 +05:30
print '(a,i12,i12,i12)' , 'resolution a b c:' , res
2011-11-15 23:24:18 +05:30
print '(a,f12.5,f12.5,f12.5)' , 'dimension x y z:' , geomdimension
2011-12-04 15:31:32 +05:30
print '(a,i5)' , 'homogenization: ' , homog
print '(a)' , '#############################################################'
print '(a,a)' , 'loadcase file: ' , trim ( getLoadcaseName ( ) )
2012-01-16 20:40:16 +05:30
bc ( 1 ) % followFormerTrajectory = . false . ! cannot guess along trajectory for first inc of first loadcase
2011-11-18 03:41:05 +05:30
2011-12-04 15:31:32 +05:30
! --- consistency checks and output of loadcase
errorID = 0_pInt
2011-11-11 19:47:43 +05:30
do loadcase = 1_pInt , N_Loadcases
2012-01-12 15:53:05 +05:30
write ( loadcase_string , '(i6)' ) loadcase
2011-12-04 15:31:32 +05:30
print '(a)' , '============================================================='
2012-01-12 15:53:05 +05:30
print '(a,i6)' , 'loadcase: ' , loadcase
2011-12-04 15:31:32 +05:30
if ( . not . bc ( loadcase ) % followFormerTrajectory ) print '(a)' , 'drop guessing along trajectory'
2011-11-15 23:24:18 +05:30
if ( bc ( loadcase ) % velGradApplied ) then
do j = 1_pInt , 3_pInt
2011-12-06 22:28:17 +05:30
if ( any ( bc ( loadcase ) % maskDeformation ( j , 1 : 3 ) . eqv . . true . ) . and . &
any ( bc ( loadcase ) % maskDeformation ( j , 1 : 3 ) . eqv . . false . ) ) errorID = 32_pInt ! each row should be either fully or not at all defined
2011-10-18 20:15:32 +05:30
enddo
2011-12-04 15:31:32 +05:30
print '(a)' , 'velocity gradient:'
2011-10-18 20:15:32 +05:30
else
2011-12-04 15:31:32 +05:30
print '(a)' , 'deformation gradient rate:'
2011-10-18 20:15:32 +05:30
endif
2011-12-06 22:28:17 +05:30
print '(3(3(f12.6,x)/)$)' , merge ( math_transpose3x3 ( bc ( loadcase ) % deformation ) , &
2011-12-04 15:31:32 +05:30
reshape ( spread ( DAMASK_NaN , 1 , 9 ) , ( / 3 , 3 / ) ) , transpose ( bc ( loadcase ) % maskDeformation ) )
2011-12-06 22:28:17 +05:30
print '(a,/,3(3(f12.6,x)/)$)' , 'stress / GPa:' , 1e-9 * merge ( math_transpose3x3 ( bc ( loadcase ) % stress ) , &
2011-12-04 15:31:32 +05:30
reshape ( spread ( DAMASK_NaN , 1 , 9 ) , ( / 3 , 3 / ) ) , &
transpose ( bc ( loadcase ) % maskStress ) )
if ( any ( bc ( loadcase ) % rotation / = math_I3 ) ) &
2011-12-06 22:28:17 +05:30
print '(a,3(3(f12.6,x)/)$)' , 'rotation of loadframe:' , math_transpose3x3 ( bc ( loadcase ) % rotation )
2011-12-04 15:31:32 +05:30
print '(a,f12.6)' , 'temperature:' , bc ( loadcase ) % temperature
2012-01-13 21:48:16 +05:30
print '(a,f12.6)' , 'time: ' , bc ( loadcase ) % time
print '(a,i5)' , 'increments: ' , bc ( loadcase ) % incs
2011-12-06 22:28:17 +05:30
print '(a,i5)' , 'output frequency: ' , bc ( loadcase ) % outputfrequency
print '(a,i5)' , 'restart frequency: ' , bc ( loadcase ) % restartfrequency
2011-12-04 15:31:32 +05:30
2011-12-06 22:28:17 +05:30
if ( any ( bc ( loadcase ) % maskStress . eqv . bc ( loadcase ) % maskDeformation ) ) errorID = 31 ! exclusive or masking only
2011-12-04 15:31:32 +05:30
if ( any ( bc ( loadcase ) % maskStress . and . transpose ( bc ( loadcase ) % maskStress ) . and . &
reshape ( ( / . false . , . true . , . true . , . true . , . false . , . true . , . true . , . true . , . false . / ) , ( / 3 , 3 / ) ) ) ) &
2012-01-04 23:13:26 +05:30
errorID = 38_pInt ! no rotation is allowed by stress BC
2011-12-04 15:31:32 +05:30
if ( any ( abs ( math_mul33x33 ( bc ( loadcase ) % rotation , math_transpose3x3 ( bc ( loadcase ) % rotation ) ) - math_I3 ) &
> reshape ( spread ( rotation_tol , 1 , 9 ) , ( / 3 , 3 / ) ) ) &
. or . abs ( math_det3x3 ( bc ( loadcase ) % rotation ) ) > 1.0_pReal + rotation_tol ) &
2012-01-04 23:13:26 +05:30
errorID = 46_pInt ! given rotation matrix contains strain
2012-01-16 20:40:16 +05:30
if ( bc ( loadcase ) % time < 0.0_pReal ) errorID = 34_pInt ! negative time increment
2012-01-13 21:48:16 +05:30
if ( bc ( loadcase ) % incs < 1_pInt ) errorID = 35_pInt ! non-positive incs count
2012-01-04 23:13:26 +05:30
if ( bc ( loadcase ) % outputfrequency < 1_pInt ) errorID = 36_pInt ! non-positive result frequency
2011-12-04 15:31:32 +05:30
if ( errorID > 0_pInt ) call IO_error ( error_ID = errorID , ext_msg = loadcase_string )
2011-10-18 20:15:32 +05:30
enddo
2011-07-25 22:00:21 +05:30
! Initialization of fftw (see manual on fftw.org for more details)
2012-01-13 21:48:16 +05:30
if ( pReal / = C_DOUBLE . or . pInt / = C_INT ) call IO_error ( error_ID = 102 )
2011-10-24 23:56:34 +05:30
#ifdef _OPENMP
2011-12-04 15:31:32 +05:30
if ( DAMASK_NumThreadsInt > 0_pInt ) then
2012-01-13 21:48:16 +05:30
ierr = fftw_init_threads ( )
2011-12-04 15:31:32 +05:30
if ( ierr == 0_pInt ) call IO_error ( error_ID = 104_pInt )
2012-01-13 21:48:16 +05:30
call fftw_plan_with_nthreads ( DAMASK_NumThreadsInt )
endif
2011-10-24 23:56:34 +05:30
#endif
2012-01-13 21:48:16 +05:30
call fftw_set_timelimit ( fftw_timelimit )
2011-12-04 15:31:32 +05:30
!*************************************************************
2011-04-06 15:28:17 +05:30
! Loop over loadcases defined in the loadcase file
2011-11-18 03:41:05 +05:30
do loadcase = 1_pInt , N_Loadcases
added fftw3 as fft(library will not versioned, should be in a linkable folder) , did some corrections on the code, splitted main file up (allows use of makefile), added makefile
changes on mpie_spectral.f90:
new structure, changed variable names, now using defgrad instead of disgrad, cleaned up, removed augmented Lagrange.
ToDo: Implement Augmented Lagrange again (but then a working version), implement Large strain, think about complex-to real-transform backwards, try to implement MP-support
2010-08-27 22:09:38 +05:30
!*************************************************************
2011-07-13 22:03:12 +05:30
time0 = time ! loadcase start time
2011-11-15 23:24:18 +05:30
if ( bc ( loadcase ) % followFormerTrajectory ) then ! continue to guess along former trajectory where applicable
2011-07-13 22:03:12 +05:30
guessmode = 1.0_pReal
else
2012-01-13 21:48:16 +05:30
guessmode = 0.0_pReal ! change of load case, homogeneous guess for the first inc
2011-07-13 22:03:12 +05:30
endif
2011-07-06 18:40:18 +05:30
2012-01-13 21:48:16 +05:30
mask_defgrad = merge ( ones , zeroes , bc ( loadcase ) % maskDeformation )
mask_stress = merge ( ones , zeroes , bc ( loadcase ) % maskStress )
2011-11-15 23:24:18 +05:30
size_reduced = count ( bc ( loadcase ) % maskStressVector )
2011-08-26 19:36:37 +05:30
allocate ( c_reduced ( size_reduced , size_reduced ) ) ; c_reduced = 0.0_pReal
allocate ( s_reduced ( size_reduced , size_reduced ) ) ; s_reduced = 0.0_pReal
2011-08-10 21:32:13 +05:30
2012-01-16 20:40:16 +05:30
timeinc = bc ( loadcase ) % time / bc ( loadcase ) % incs ! only valid for given linear time scale. will be overwritten later in case logarithmic scale is used
2012-01-13 21:48:16 +05:30
2012-01-16 20:40:16 +05:30
fDot = bc ( loadcase ) % deformation ! only valid for given fDot. will be overwritten later in case L is given
2011-11-18 03:41:05 +05:30
added fftw3 as fft(library will not versioned, should be in a linkable folder) , did some corrections on the code, splitted main file up (allows use of makefile), added makefile
changes on mpie_spectral.f90:
new structure, changed variable names, now using defgrad instead of disgrad, cleaned up, removed augmented Lagrange.
ToDo: Implement Augmented Lagrange again (but then a working version), implement Large strain, think about complex-to real-transform backwards, try to implement MP-support
2010-08-27 22:09:38 +05:30
!*************************************************************
2012-01-13 21:48:16 +05:30
! loop oper incs defined in input file for current loadcase
do inc = 1_pInt , bc ( loadcase ) % incs
2011-11-15 23:24:18 +05:30
!*************************************************************
2011-11-18 03:41:05 +05:30
! forwarding time
2012-01-16 20:40:16 +05:30
if ( bc ( loadcase ) % logscale == 1_pInt ) then ! logarithmic scale
if ( loadcase == 1_pInt ) then ! 1st loadcase of logarithmic scale
if ( inc == 1_pInt ) then ! 1st inc of 1st loadcase of logarithmic scale
2012-01-13 21:48:16 +05:30
timeinc = bc ( 1 ) % time * ( 2.0_pReal ** real ( 1_pInt - bc ( 1 ) % incs , pReal ) ) ! assume 1st inc is equal to 2nd
2012-01-16 20:40:16 +05:30
else ! not-1st inc of 1st loadcase of logarithmic scale
2012-01-13 21:48:16 +05:30
timeinc = bc ( 1 ) % time * ( 2.0_pReal ** real ( inc - 1_pInt - bc ( 1 ) % incs , pReal ) )
2011-11-18 03:41:05 +05:30
endif
2012-01-12 15:53:05 +05:30
else ! not-1st loadcase of logarithmic scale
2012-01-16 20:40:16 +05:30
timeinc = time0 * ( ( 1.0_pReal + bc ( loadcase ) % time / time0 ) ** ( real ( inc , pReal ) / real ( bc ( loadcase ) % incs , pReal ) ) &
- ( 1.0_pReal + bc ( loadcase ) % time / time0 ) ** ( real ( ( inc - 1_pInt ) , pReal ) / real ( bc ( loadcase ) % incs , pReal ) ) )
2011-11-11 19:47:43 +05:30
endif
2011-11-07 16:34:57 +05:30
endif
2011-11-18 03:41:05 +05:30
time = time + timeinc
2012-01-13 21:48:16 +05:30
totalIncsCounter = totalIncsCounter + 1_pInt
2011-11-15 23:24:18 +05:30
!*************************************************************
2011-11-18 03:41:05 +05:30
! Initialization Start
2011-11-15 23:24:18 +05:30
!*************************************************************
2011-12-06 22:28:17 +05:30
2012-01-13 21:48:16 +05:30
if ( totalIncsCounter == restartReadInc ) then ! Initialize values
guessmode = 0.0_pReal ! no old values
allocate ( defgrad ( res ( 1 ) , res ( 2 ) , res ( 3 ) , 3 , 3 ) ) ; defgrad = 0.0_pReal
allocate ( defgradold ( res ( 1 ) , res ( 2 ) , res ( 3 ) , 3 , 3 ) ) ; defgradold = 0.0_pReal
allocate ( coordinates ( 3 , res ( 1 ) , res ( 2 ) , res ( 3 ) ) ) ; coordinates = 0.0_pReal
allocate ( temperature ( res ( 1 ) , res ( 2 ) , res ( 3 ) ) ) ; temperature = bc ( 1 ) % temperature ! start out isothermally
allocate ( xi ( 3 , res1_red , res ( 2 ) , res ( 3 ) ) ) ; xi = 0.0_pReal
data_fftw = fftw_alloc_complex ( int ( res1_red * res ( 2 ) * res ( 3 ) * 9_pInt , C_SIZE_T ) ) !C_SIZE_T is of type integer(8)
call c_f_pointer ( data_fftw , data_real , [ res ( 1 ) + 2_pInt , res ( 2 ) , res ( 3 ) , 3 , 3 ] )
call c_f_pointer ( data_fftw , data_complex , [ res1_red , res ( 2 ) , res ( 3 ) , 3 , 3 ] )
if ( debugDivergence ) then
divergence = fftw_alloc_complex ( int ( res1_red * res ( 2 ) * res ( 3 ) * 3_pInt , C_SIZE_T ) ) !C_SIZE_T is of type integer(8)
call c_f_pointer ( divergence , divergence_real , [ res ( 1 ) + 2_pInt , res ( 2 ) , res ( 3 ) , 3 ] )
call c_f_pointer ( divergence , divergence_complex , [ res1_red , res ( 2 ) , res ( 3 ) , 3 ] )
endif
if ( debugFFTW ) then
fftw_debug = fftw_alloc_complex ( int ( res1_red * res ( 2 ) * res ( 3 ) , C_SIZE_T ) ) !C_SIZE_T is of type integer(8)
call c_f_pointer ( fftw_debug , fftw_debug_real , [ res ( 1 ) + 2_pInt , res ( 2 ) , res ( 3 ) ] )
call c_f_pointer ( fftw_debug , fftw_debug_complex , [ res1_red , res ( 2 ) , res ( 3 ) ] )
2011-11-18 03:41:05 +05:30
endif
2011-11-21 23:42:40 +05:30
2012-01-13 21:48:16 +05:30
fftw_stress = fftw_plan_many_dft_r2c ( 3 , ( / res ( 3 ) , res ( 2 ) , res ( 1 ) / ) , 9 , & ! dimensions , length in each dimension in reversed order
data_real , ( / res ( 3 ) , res ( 2 ) , res ( 1 ) + 2_pInt / ) , & ! input data , physical length in each dimension in reversed order
1 , res ( 3 ) * res ( 2 ) * ( res ( 1 ) + 2_pInt ) , & ! striding , product of physical lenght in the 3 dimensions
data_complex , ( / res ( 3 ) , res ( 2 ) , res1_red / ) , &
1 , res ( 3 ) * res ( 2 ) * res1_red , fftw_planner_flag )
fftw_fluctuation = fftw_plan_many_dft_c2r ( 3 , ( / res ( 3 ) , res ( 2 ) , res ( 1 ) / ) , 9 , &
data_complex , ( / res ( 3 ) , res ( 2 ) , res1_red / ) , &
1 , res ( 3 ) * res ( 2 ) * res1_red , &
data_real , ( / res ( 3 ) , res ( 2 ) , res ( 1 ) + 2_pInt / ) , &
1 , res ( 3 ) * res ( 2 ) * ( res ( 1 ) + 2_pInt ) , fftw_planner_flag )
2011-12-06 22:28:17 +05:30
if ( debugDivergence ) &
2012-01-13 21:48:16 +05:30
fftw_divergence = fftw_plan_many_dft_c2r ( 3 , ( / res ( 3 ) , res ( 2 ) , res ( 1 ) / ) , 3 , &
divergence_complex , ( / res ( 3 ) , res ( 2 ) , res1_red / ) , &
1 , res ( 3 ) * res ( 2 ) * res1_red , &
divergence_real , ( / res ( 3 ) , res ( 2 ) , res ( 1 ) + 2_pInt / ) , &
1 , res ( 3 ) * res ( 2 ) * ( res ( 1 ) + 2_pInt ) , fftw_planner_flag )
if ( debugFFTW ) fftw_debug_forward = fftw_plan_dft_r2c_3d ( res ( 3 ) , res ( 2 ) , res ( 1 ) , fftw_debug_real , fftw_debug_complex , fftw_planner_flag ) !reversed order
if ( debugFFTW ) fftw_debug_backward = fftw_plan_dft_c2r_3d ( res ( 3 ) , res ( 2 ) , res ( 1 ) , fftw_debug_complex , fftw_debug_real , fftw_planner_flag ) !reversed order
2011-12-06 22:28:17 +05:30
if ( debugGeneral ) then
write ( 6 , * ) 'FFTW initialized'
endif
2011-11-21 23:42:40 +05:30
2012-01-13 21:48:16 +05:30
if ( restartReadInc == 1_pInt ) then ! not restarting, no deformation at the beginning
2011-11-21 23:42:40 +05:30
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res ( 1 )
2011-12-06 22:28:17 +05:30
defgrad ( i , j , k , 1 : 3 , 1 : 3 ) = math_I3
defgradold ( i , j , k , 1 : 3 , 1 : 3 ) = math_I3
2011-11-18 03:41:05 +05:30
enddo ; enddo ; enddo
2011-12-06 22:28:17 +05:30
else ! using old values
if ( IO_read_jobBinaryFile ( 777 , 'convergedSpectralDefgrad' , trim ( getSolverJobName ( ) ) , size ( defgrad ) ) ) then
read ( 777 , rec = 1 ) defgrad
close ( 777 )
2011-11-18 03:41:05 +05:30
endif
2011-12-06 22:28:17 +05:30
defgradold = defgrad
defgradAim = 0.0_pReal
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res ( 1 )
defgradAim = defgradAim + defgrad ( i , j , k , 1 : 3 , 1 : 3 ) ! calculating old average deformation
2011-11-18 03:41:05 +05:30
enddo ; enddo ; enddo
2011-12-06 22:28:17 +05:30
defgradAim = defgradAim * wgt
defgradAimOld = defgradAim
guessmode = 0.0_pInt
endif
ielem = 0_pInt
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res ( 1 )
ielem = ielem + 1_pInt
2012-01-04 23:13:26 +05:30
coordinates ( 1 : 3 , i , j , k ) = mesh_ipCenterOfGravity ( 1 : 3 , 1 , ielem ) ! set to initial coordinates ToDo: SHOULD BE UPDATED TO CURRENT POSITION IN FUTURE REVISIONS!!! But do we know them? I don't think so. Otherwise we don't need geometry reconstruction
2011-12-06 22:28:17 +05:30
call CPFEM_general ( 2_pInt , coordinates ( 1 : 3 , i , j , k ) , math_I3 , math_I3 , temperature ( i , j , k ) , &
0.0_pReal , ielem , 1_pInt , cstress , dsde , pstress , dPdF )
c_current = c_current + dPdF
enddo ; enddo ; enddo
c0_reference = c_current * wgt ! linear reference material stiffness
if ( debugGeneral ) then
write ( 6 , * ) 'first call to CPFEM_general finished'
endif
do k = 1_pInt , res ( 3 ) ! calculation of discrete angular frequencies, ordered as in FFTW (wrap around)
k_s ( 3 ) = k - 1_pInt
if ( k > res ( 3 ) / 2_pInt + 1_pInt ) k_s ( 3 ) = k_s ( 3 ) - res ( 3 )
do j = 1_pInt , res ( 2 )
k_s ( 2 ) = j - 1_pInt
if ( j > res ( 2 ) / 2_pInt + 1_pInt ) k_s ( 2 ) = k_s ( 2 ) - res ( 2 )
2012-01-13 21:48:16 +05:30
do i = 1 , res1_red
2011-12-06 22:28:17 +05:30
k_s ( 1 ) = i - 1_pInt
2011-12-23 18:00:35 +05:30
xi ( 3 , i , j , k ) = 0.0_pReal ! 2D case
if ( res ( 3 ) > 1_pInt ) xi ( 3 , i , j , k ) = real ( k_s ( 3 ) , pReal ) / geomdimension ( 3 ) ! 3D case
xi ( 2 , i , j , k ) = real ( k_s ( 2 ) , pReal ) / geomdimension ( 2 ) ! 2D and 3D case
xi ( 1 , i , j , k ) = real ( k_s ( 1 ) , pReal ) / geomdimension ( 1 ) ! 2D and 3D case
2011-12-06 22:28:17 +05:30
enddo ; enddo ; enddo
2011-12-23 18:00:35 +05:30
!remove the given highest frequencies for calculation of the gamma operator
cutting_freq = ( / 0_pInt , 0_pInt , 0_pInt / ) ! for 0,0,0, just the highest freq. is removed
2012-01-13 21:48:16 +05:30
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res1_red
2012-01-16 20:40:16 +05:30
if ( ( k > res ( 3 ) / 2_pInt - cutting_freq ( 3 ) ) . and . ( k < = res ( 3 ) / 2_pInt + 1_pInt + cutting_freq ( 3 ) ) ) xi ( 3 , i , j , k ) = 0.0_pReal
if ( ( j > res ( 2 ) / 2_pInt - cutting_freq ( 2 ) ) . and . ( j < = res ( 2 ) / 2_pInt + 1_pInt + cutting_freq ( 2 ) ) ) xi ( 2 , i , j , k ) = 0.0_pReal
if ( ( i > res ( 1 ) / 2_pInt - cutting_freq ( 1 ) ) . and . ( i < = res ( 1 ) / 2_pInt + 1_pInt + cutting_freq ( 1 ) ) ) xi ( 1 , i , j , k ) = 0.0_pReal
2011-12-06 22:28:17 +05:30
enddo ; enddo ; enddo
2011-12-23 18:00:35 +05:30
2011-12-06 22:28:17 +05:30
if ( memory_efficient ) then ! allocate just single fourth order tensor
allocate ( gamma_hat ( 1 , 1 , 1 , 3 , 3 , 3 , 3 ) ) ; gamma_hat = 0.0_pReal
else ! precalculation of gamma_hat field
2012-01-13 21:48:16 +05:30
allocate ( gamma_hat ( res1_red , res ( 2 ) , res ( 3 ) , 3 , 3 , 3 , 3 ) ) ; gamma_hat = 0.0_pReal
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res1_red
2011-12-23 18:00:35 +05:30
if ( any ( xi ( 1 : 3 , i , j , k ) / = 0.0_pReal ) ) then
2011-12-06 22:28:17 +05:30
do l = 1_pInt , 3_pInt ; do m = 1_pInt , 3_pInt
xiDyad ( l , m ) = xi ( l , i , j , k ) * xi ( m , i , j , k )
enddo ; enddo
temp33_Real = math_inv3x3 ( math_mul3333xx33 ( c0_reference , xiDyad ) )
else
xiDyad = 0.0_pReal
temp33_Real = 0.0_pReal
endif
do l = 1_pInt , 3_pInt ; do m = 1_pInt , 3_pInt ; do n = 1_pInt , 3_pInt ; do p = 1_pInt , 3_pInt
gamma_hat ( i , j , k , l , m , n , p ) = - 0.25 * ( temp33_Real ( l , n ) + temp33_Real ( n , l ) ) * &
( xiDyad ( m , p ) + xiDyad ( p , m ) )
enddo ; enddo ; enddo ; enddo
2011-11-18 03:41:05 +05:30
enddo ; enddo ; enddo
2011-12-06 22:28:17 +05:30
endif
if ( divergence_correction ) then
if ( res ( 3 ) == 1_pInt ) then
correctionFactor = minval ( geomdimension ( 1 : 2 ) ) * wgt ** ( - 1.0_pReal / 4.0_pReal ) ! 2D case, ToDo: correct?
else
correctionFactor = minval ( geomdimension ( 1 : 3 ) ) * wgt ** ( - 1.0_pReal / 4.0_pReal ) ! multiplying by minimum dimension to get rid of dimension dependency and phenomenologigal factor wgt**(-1/4) to get rid of resolution dependency
2011-11-18 03:41:05 +05:30
endif
2011-12-06 22:28:17 +05:30
else
correctionFactor = 1.0_pReal
2011-11-15 23:24:18 +05:30
endif
2011-12-06 22:28:17 +05:30
! write header of output file
!$OMP CRITICAL (write2out)
open ( 538 , file = trim ( getSolverWorkingDirectoryName ( ) ) / / trim ( getSolverJobName ( ) ) &
/ / '.spectralOut' , form = 'UNFORMATTED' , status = 'REPLACE' )
2012-01-12 15:53:05 +05:30
write ( 538 ) , 'load' , trim ( getLoadcaseName ( ) )
2011-12-06 22:28:17 +05:30
write ( 538 ) , 'workingdir' , trim ( getSolverWorkingDirectoryName ( ) )
2012-01-12 15:53:05 +05:30
write ( 538 ) , 'geometry' , trim ( getSolverJobName ( ) ) / / InputFileExtension
2011-12-06 22:28:17 +05:30
write ( 538 ) , 'resolution' , res
2012-01-12 15:53:05 +05:30
write ( 538 ) , 'dimension' , geomdimension
2011-12-06 22:28:17 +05:30
write ( 538 ) , 'materialpoint_sizeResults' , materialpoint_sizeResults
2012-01-12 15:53:05 +05:30
write ( 538 ) , 'loadcases' , N_Loadcases
2011-12-06 22:28:17 +05:30
write ( 538 ) , 'frequencies' , bc ( 1 : N_Loadcases ) % outputfrequency ! one entry per loadcase
2012-01-13 21:48:16 +05:30
write ( 538 ) , 'times' , bc ( 1 : N_Loadcases ) % time ! one entry per loadcase
write ( 538 ) , 'logscales' , bc ( 1 : N_Loadcases ) % logscale
bc ( 1 ) % incs = bc ( 1 ) % incs + 1_pInt
write ( 538 ) , 'increments' , bc ( 1 : N_Loadcases ) % incs ! one entry per loadcase
bc ( 1 ) % incs = bc ( 1 ) % incs - 1_pInt
write ( 538 ) , 'startingIncrement' , restartReadInc - 1_pInt ! start with writing out the previous inc
2011-12-06 22:28:17 +05:30
write ( 538 ) , 'eoh' ! end of header
write ( 538 ) , materialpoint_results ( 1_pInt : materialpoint_sizeResults , 1 , 1_pInt : Npoints ) ! initial (non-deformed) results
!$OMP END CRITICAL (write2out)
endif
2011-11-18 03:41:05 +05:30
!*************************************************************
! Initialization End
!*************************************************************
2011-12-06 22:28:17 +05:30
2012-01-13 21:48:16 +05:30
if ( totalIncsCounter > = restartReadInc ) then ! Do calculations (otherwise just forwarding)
2011-12-06 22:28:17 +05:30
if ( bc ( loadcase ) % restartFrequency > 0_pInt ) &
2012-01-13 21:48:16 +05:30
restartWrite = ( mod ( inc - 1_pInt , bc ( loadcase ) % restartFrequency ) == 0_pInt ) ! at frequency of writing restart information
2011-12-06 22:28:17 +05:30
! setting restart parameter for FEsolving (first call to CPFEM_general will write ToDo: true?)
if ( bc ( loadcase ) % velGradApplied ) & ! calculate fDot from given L and current F
fDot = math_mul33x33 ( bc ( loadcase ) % deformation , defgradAim )
2011-11-18 03:41:05 +05:30
!winding forward of deformation aim in loadcase system
temp33_Real = defgradAim
defgradAim = defgradAim &
+ guessmode * mask_stress * ( defgradAim - defgradAimOld ) &
+ mask_defgrad * fDot * timeinc
defgradAimOld = temp33_Real
! update local deformation gradient
if ( any ( bc ( loadcase ) % rotation / = math_I3 ) ) then ! lab and loadcase coordinate system are NOT the same
2011-11-21 23:42:40 +05:30
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res ( 1 )
2011-11-18 03:41:05 +05:30
temp33_Real = defgrad ( i , j , k , 1 : 3 , 1 : 3 )
if ( bc ( loadcase ) % velGradApplied ) & ! use velocity gradient to calculate new deformation gradient (if not guessing)
fDot = math_mul33x33 ( bc ( loadcase ) % deformation , &
math_rotate_forward3x3 ( defgradold ( i , j , k , 1 : 3 , 1 : 3 ) , bc ( loadcase ) % rotation ) )
defgrad ( i , j , k , 1 : 3 , 1 : 3 ) = defgrad ( i , j , k , 1 : 3 , 1 : 3 ) & ! decide if guessing along former trajectory or apply homogeneous addon
+ guessmode * ( defgrad ( i , j , k , 1 : 3 , 1 : 3 ) - defgradold ( i , j , k , 1 : 3 , 1 : 3 ) ) & ! guessing...
+ math_rotate_backward3x3 ( ( 1.0_pReal - guessmode ) * mask_defgrad * fDot , &
bc ( loadcase ) % rotation ) * timeinc ! apply the prescribed value where deformation is given if not guessing
defgradold ( i , j , k , 1 : 3 , 1 : 3 ) = temp33_Real
enddo ; enddo ; enddo
else ! one coordinate system for lab and loadcase, save some multiplications
2011-11-21 23:42:40 +05:30
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res ( 1 )
2011-11-18 03:41:05 +05:30
temp33_Real = defgrad ( i , j , k , 1 : 3 , 1 : 3 )
if ( bc ( loadcase ) % velGradApplied ) & ! use velocity gradient to calculate new deformation gradient (if not guessing)
fDot = math_mul33x33 ( bc ( loadcase ) % deformation , defgradold ( i , j , k , 1 : 3 , 1 : 3 ) )
defgrad ( i , j , k , 1 : 3 , 1 : 3 ) = defgrad ( i , j , k , 1 : 3 , 1 : 3 ) & ! decide if guessing along former trajectory or apply homogeneous addon
+ guessmode * ( defgrad ( i , j , k , 1 : 3 , 1 : 3 ) - defgradold ( i , j , k , 1 : 3 , 1 : 3 ) ) & ! guessing...
+ ( 1.0_pReal - guessmode ) * mask_defgrad * fDot * timeinc ! apply the prescribed value where deformation is given if not guessing
defgradold ( i , j , k , 1 : 3 , 1 : 3 ) = temp33_Real
enddo ; enddo ; enddo
endif
guessmode = 1.0_pReal ! keep guessing along former trajectory during same loadcase
CPFEM_mode = 1_pInt ! winding forward
iter = 0_pInt
err_div = 2.0_pReal * err_div_tol ! go into loop
2011-12-06 22:28:17 +05:30
2012-01-16 20:40:16 +05:30
c_prev = math_rotate_forward3x3x3x3 ( c_current * wgt , bc ( loadcase ) % rotation ) ! calculate stiffness from former inc
2011-11-18 03:41:05 +05:30
if ( size_reduced > 0_pInt ) then ! calculate compliance in case stress BC is applied
c_prev99 = math_Plain3333to99 ( c_prev )
k = 0_pInt ! build reduced stiffness
do n = 1_pInt , 9_pInt
if ( bc ( loadcase ) % maskStressVector ( n ) ) then
k = k + 1_pInt
j = 0_pInt
do m = 1_pInt , 9_pInt
if ( bc ( loadcase ) % maskStressVector ( m ) ) then
2011-08-26 19:36:37 +05:30
j = j + 1_pInt
2011-11-18 03:41:05 +05:30
c_reduced ( k , j ) = c_prev99 ( n , m )
endif ; enddo ; endif ; enddo
call math_invert ( size_reduced , c_reduced , s_reduced , i , errmatinv ) ! invert reduced stiffness
if ( errmatinv ) call IO_error ( error_ID = 800 )
s_prev99 = 0.0_pReal ! build full compliance
k = 0_pInt
do n = 1_pInt , 9_pInt
if ( bc ( loadcase ) % maskStressVector ( n ) ) then
k = k + 1_pInt
j = 0_pInt
do m = 1_pInt , 9_pInt
if ( bc ( loadcase ) % maskStressVector ( m ) ) then
j = j + 1_pInt
s_prev99 ( n , m ) = s_reduced ( k , j )
endif ; enddo ; endif ; enddo
s_prev = ( math_Plain99to3333 ( s_prev99 ) )
endif
2011-11-15 23:24:18 +05:30
2011-12-06 22:28:17 +05:30
2011-11-18 03:41:05 +05:30
print '(a)' , '#############################################################'
2012-01-13 21:48:16 +05:30
print '(A,I5.5,A,es12.6)' , 'Increment ' , totalIncsCounter , ' Time ' , time
2011-11-18 03:41:05 +05:30
if ( restartWrite ) then
2012-01-16 20:40:16 +05:30
print '(A)' , 'writing converged results of previous increment for restart'
2011-12-06 22:28:17 +05:30
if ( IO_write_jobBinaryFile ( 777 , 'convergedSpectralDefgrad' , size ( defgrad ) ) ) then ! and writing deformation gradient field to file
write ( 777 , rec = 1 ) defgrad
close ( 777 )
endif
endif
2011-11-18 03:41:05 +05:30
!*************************************************************
! convergence loop
do while ( iter < itmax . and . &
( err_div > err_div_tol . or . &
err_stress > err_stress_tol ) )
iter = iter + 1_pInt
!*************************************************************
2011-12-06 22:28:17 +05:30
2011-12-04 15:31:32 +05:30
print '(a)' , ''
2011-11-18 03:41:05 +05:30
print '(a)' , '============================================================='
2012-01-16 20:40:16 +05:30
print '(5(a,i6.6))' , 'Loadcase ' , loadcase , ' Increment ' , inc , '/' , bc ( loadcase ) % incs , ' @ Iteration ' , iter , '/' , itmax
2011-11-18 03:41:05 +05:30
do n = 1_pInt , 3_pInt ; do m = 1_pInt , 3_pInt
2011-12-06 22:28:17 +05:30
defgrad_av_lab ( m , n ) = sum ( defgrad ( 1 : res ( 1 ) , 1 : res ( 2 ) , 1 : res ( 3 ) , m , n ) ) * wgt
2011-11-18 03:41:05 +05:30
enddo ; enddo
2011-12-06 22:28:17 +05:30
print '(a,/,3(3(f12.7,x)/)$)' , 'deformation gradient:' , &
math_transpose3x3 ( math_rotate_forward3x3 ( defgrad_av_lab , bc ( loadcase ) % rotation ) )
print '(a)' , ''
2011-12-04 15:31:32 +05:30
print '(a)' , '... update stress field P(F) ................................'
2011-12-06 22:28:17 +05:30
2011-11-18 03:41:05 +05:30
ielem = 0_pInt
2011-11-21 23:42:40 +05:30
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res ( 1 )
2011-11-18 03:41:05 +05:30
ielem = ielem + 1_pInt
2011-12-06 22:28:17 +05:30
call CPFEM_general ( 3_pInt , & ! collect cycle
2011-11-18 03:41:05 +05:30
coordinates ( 1 : 3 , i , j , k ) , defgradold ( i , j , k , 1 : 3 , 1 : 3 ) , defgrad ( i , j , k , 1 : 3 , 1 : 3 ) , &
temperature ( i , j , k ) , timeinc , ielem , 1_pInt , &
cstress , dsde , pstress , dPdF )
2011-08-26 19:36:37 +05:30
enddo ; enddo ; enddo
2011-11-18 03:41:05 +05:30
2012-01-13 21:48:16 +05:30
data_real = 0.0_pReal ! needed because of the padding for FFTW
2011-11-18 03:41:05 +05:30
c_current = 0.0_pReal
2012-01-13 21:48:16 +05:30
ielem = 0_pInt
if ( debugFFTW ) then
2012-01-16 20:40:16 +05:30
row = ( mod ( totalIncsCounter + iter - 2_pInt , 9_pInt ) ) / 3_pInt + 1_pInt ! go through the elements of the tensors, controlled by totalIncsCounter and iter, starting at 1
column = ( mod ( totalIncsCounter + iter - 2_pInt , 3_pInt ) ) + 1_pInt
2012-01-13 21:48:16 +05:30
endif
2011-11-21 23:42:40 +05:30
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res ( 1 )
2011-11-18 03:41:05 +05:30
ielem = ielem + 1_pInt
call CPFEM_general ( CPFEM_mode , & ! first element in first iteration retains CPFEM_mode 1,
coordinates ( 1 : 3 , i , j , k ) , &
defgradold ( i , j , k , 1 : 3 , 1 : 3 ) , defgrad ( i , j , k , 1 : 3 , 1 : 3 ) , & ! others get 2 (saves winding forward effort)
temperature ( i , j , k ) , timeinc , ielem , 1_pInt , &
cstress , dsde , pstress , dPdF )
CPFEM_mode = 2_pInt
2012-01-13 21:48:16 +05:30
data_real ( i , j , k , 1 : 3 , 1 : 3 ) = pstress
if ( debugFFTW ) fftw_debug_real ( i , j , k ) = pstress ( row , column ) ! choose an arbitrary component
2011-11-18 03:41:05 +05:30
c_current = c_current + dPdF
2011-08-26 19:36:37 +05:30
enddo ; enddo ; enddo
2011-12-06 22:28:17 +05:30
2011-11-18 03:41:05 +05:30
do n = 1_pInt , 3_pInt ; do m = 1_pInt , 3_pInt
2012-01-13 21:48:16 +05:30
pstress_av_lab ( m , n ) = sum ( data_real ( 1 : res ( 1 ) , 1 : res ( 2 ) , 1 : res ( 3 ) , m , n ) ) * wgt
2011-11-18 03:41:05 +05:30
enddo ; enddo
2011-12-04 15:31:32 +05:30
print '(a)' , ''
print '(a)' , '... calculating equilibrium with spectral method ............'
2012-01-13 21:48:16 +05:30
call fftw_execute_dft_r2c ( fftw_stress , data_real , data_complex ) ! FFT of pstress
if ( debugFFTW ) then
call fftw_execute_dft_r2c ( fftw_debug_forward , fftw_debug_real , fftw_debug_complex )
print '(a,i1,x,i1)' , 'checking FT results of compontent ' , row , column
print '(a,2(es10.4,x))' , 'max FT relative error ' , &
maxval ( real ( ( fftw_debug_complex ( 1 : res1_red , 1 : res ( 2 ) , 1 : res ( 3 ) ) - data_complex ( 1 : res1_red , 1 : res ( 2 ) , 1 : res ( 3 ) , row , column ) ) / fftw_debug_real ( 1 : res1_red , 1 : res ( 2 ) , 1 : res ( 3 ) ) ) ) , &
maxval ( aimag ( ( fftw_debug_complex ( 1 : res1_red , 1 : res ( 2 ) , 1 : res ( 3 ) ) - data_complex ( 1 : res1_red , 1 : res ( 2 ) , 1 : res ( 3 ) , row , column ) ) / fftw_debug_real ( 1 : res1_red , 1 : res ( 2 ) , 1 : res ( 3 ) ) ) )
fftw_debug_complex = 0.0_pReal
endif
p_hat_avg = sqrt ( maxval ( math_eigenvalues3x3 ( math_mul33x33 ( real ( data_complex ( 1 , 1 , 1 , 1 : 3 , 1 : 3 ) ) , & ! L_2 norm of average stress (freq 0,0,0) in fourier space,
math_transpose3x3 ( real ( data_complex ( 1 , 1 , 1 , 1 : 3 , 1 : 3 ) ) ) ) ) ) ) ! ignore imaginary part as it is always zero for real only input
2011-12-23 18:00:35 +05:30
err_div_avg_complex = 0.0_pReal
2012-01-04 23:13:26 +05:30
err_div_max = 0.0_pReal ! only important if debugDivergence == .true.
2012-01-13 21:48:16 +05:30
divergence_complex = 0.0_pReal ! - '' -
2011-12-23 18:00:35 +05:30
2012-01-13 21:48:16 +05:30
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res1_red
temp3_Complex = math_mul33x3_complex ( data_complex ( i , j , k , 1 : 3 , 1 : 3 ) , xi ( 1 : 3 , i , j , k ) ) ! calculate divergence without factor of 2*pi*img
2012-01-04 23:13:26 +05:30
if ( debugDivergence ) then ! need divergence NOT squared
2012-01-13 21:48:16 +05:30
divergence_complex ( i , j , k , 1 : 3 ) = temp3_Complex * img !ToDo negativ img?
2012-01-04 23:13:26 +05:30
endif
2012-01-13 21:48:16 +05:30
temp3_Complex = temp3_Complex ** 2.0_pReal ! all criteria need divergence squared
if ( i == 1_pInt . or . i == res1_red ) then ! We are on one of the two slides without conjg. complex counterpart
err_div_avg_complex = err_div_avg_complex + sum ( temp3_Complex ) ! RMS of L_2 norm of div(stress) in fourier space (Suquet small strain)
2011-12-23 18:00:35 +05:30
else ! Has somewhere a conj. complex counterpart. Therefore count it twice.
2012-01-13 21:48:16 +05:30
err_div_avg_complex = err_div_avg_complex + 2.0 * real ( sum ( temp3_Complex ) ) ! Ignore img part (conjg. complex sum will end up 0). This and the different order
2011-12-23 18:00:35 +05:30
endif ! compared to c2c transform results in slight numerical deviations.
if ( debugDivergence ) then
2012-01-13 21:48:16 +05:30
err_div_max = max ( err_div_max , abs ( sqrt ( sum ( temp3_Complex ) ) ) ) ! maximum of L two norm of div(stress) in fourier space (Suquet large strain)
2012-01-04 23:13:26 +05:30
endif
2011-11-15 23:24:18 +05:30
enddo ; enddo ; enddo
2011-12-06 22:28:17 +05:30
2012-01-04 23:13:26 +05:30
err_div = abs ( sqrt ( err_div_avg_complex * wgt ) ) ! weighting by and taking square root (RMS). abs(...) because result is a complex number
2011-12-23 18:00:35 +05:30
err_div = err_div * correctionFactor / p_hat_avg ! weighting by average stress and multiplying with correction factor
err_div_max = err_div_max * correctionFactor / p_hat_avg ! - '' - only if debugDivergence == .true. of importance
! calculate additional divergence criteria and report -------------
if ( debugDivergence ) then
2012-01-13 21:48:16 +05:30
call fftw_execute_dft_c2r ( fftw_divergence , divergence_complex , divergence_real )
divergence_real = divergence_real * pi * 2.0_pReal * wgt !pointwise factor 2*pi from differentation and weighting from FT
2011-12-23 18:00:35 +05:30
err_real_div_avg = 0.0_pReal
err_real_div_max = 0.0_pReal
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res ( 1 )
2012-01-13 21:48:16 +05:30
err_real_div_avg = err_real_div_avg + sum ( divergence_real ( i , j , k , 1 : 3 ) ** 2.0_pReal ) ! avg of L_2 norm of div(stress) in real space
err_real_div_max = max ( err_real_div_max , sqrt ( sum ( divergence_real ( i , j , k , 1 : 3 ) ** 2.0_pReal ) ) ) ! maximum of L two norm of div(stress) in real space
2011-12-23 18:00:35 +05:30
enddo ; enddo ; enddo
p_real_avg = sqrt ( maxval ( math_eigenvalues3x3 ( math_mul33x33 ( pstress_av_lab , & ! L_2 norm of average stress in real space,
math_transpose3x3 ( pstress_av_lab ) ) ) ) )
2012-01-04 23:13:26 +05:30
err_real_div_avg = sqrt ( wgt * err_real_div_avg ) * correctionFactor / p_real_avg ! RMS in real space
err_real_div_max = err_real_div_max * correctionFactor / p_real_avg
2011-11-18 03:41:05 +05:30
2011-12-23 18:00:35 +05:30
print '(a,es10.4,a,f6.2)' , 'error divergence FT avg = ' , err_div , ', ' , err_div / err_div_tol
print '(a,es10.4)' , 'error divergence FT max = ' , err_div_max
print '(a,es10.4)' , 'error divergence Real avg = ' , err_real_div_avg
print '(a,es10.4)' , 'error divergence Real max = ' , err_real_div_max
else
print '(a,es10.4,a,f6.2)' , 'error divergence = ' , err_div , ', ' , err_div / err_div_tol
endif
! --------------------------
2012-01-04 23:13:26 +05:30
if ( memory_efficient ) then ! memory saving version, on-the-fly calculation of gamma_hat
2012-01-13 21:48:16 +05:30
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res1_red
2011-12-23 18:00:35 +05:30
if ( any ( xi ( 1 : 3 , i , j , k ) / = 0.0_pReal ) ) then
2011-11-18 03:41:05 +05:30
do l = 1_pInt , 3_pInt ; do m = 1_pInt , 3_pInt
xiDyad ( l , m ) = xi ( l , i , j , k ) * xi ( m , i , j , k )
enddo ; enddo
temp33_Real = math_inv3x3 ( math_mul3333xx33 ( c0_reference , xiDyad ) )
else
xiDyad = 0.0_pReal
temp33_Real = 0.0_pReal
endif
do l = 1_pInt , 3_pInt ; do m = 1_pInt , 3_pInt ; do n = 1_pInt , 3_pInt ; do p = 1_pInt , 3_pInt
gamma_hat ( 1 , 1 , 1 , l , m , n , p ) = - 0.25_pReal * ( temp33_Real ( l , n ) + temp33_Real ( n , l ) ) * &
( xiDyad ( m , p ) + xiDyad ( p , m ) )
enddo ; enddo ; enddo ; enddo
do m = 1_pInt , 3_pInt ; do n = 1_pInt , 3_pInt
2012-01-13 21:48:16 +05:30
temp33_Complex ( m , n ) = sum ( gamma_hat ( 1 , 1 , 1 , m , n , 1 : 3 , 1 : 3 ) * data_complex ( i , j , k , 1 : 3 , 1 : 3 ) )
2011-11-18 03:41:05 +05:30
enddo ; enddo
2012-01-13 21:48:16 +05:30
data_complex ( i , j , k , 1 : 3 , 1 : 3 ) = temp33_Complex
if ( debugFFTW ) fftw_debug_complex ( i , j , k ) = temp33_Complex ( row , column )
2011-11-18 03:41:05 +05:30
enddo ; enddo ; enddo
else ! use precalculated gamma-operator
2012-01-13 21:48:16 +05:30
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res1_red
2011-11-18 03:41:05 +05:30
do m = 1_pInt , 3_pInt ; do n = 1_pInt , 3_pInt
2012-01-13 21:48:16 +05:30
temp33_Complex ( m , n ) = sum ( gamma_hat ( i , j , k , m , n , 1 : 3 , 1 : 3 ) * data_complex ( i , j , k , 1 : 3 , 1 : 3 ) )
2011-11-18 03:41:05 +05:30
enddo ; enddo
2012-01-13 21:48:16 +05:30
data_complex ( i , j , k , 1 : 3 , 1 : 3 ) = temp33_Complex
if ( debugFFTW ) fftw_debug_complex ( i , j , k ) = temp33_Complex ( row , column )
2011-11-18 03:41:05 +05:30
enddo ; enddo ; enddo
endif
2011-12-06 22:28:17 +05:30
2012-01-13 21:48:16 +05:30
data_complex ( 1 , 1 , 1 , 1 : 3 , 1 : 3 ) = defgrad_av_lab - math_I3 ! assign zero frequency (real part) with average displacement gradient
if ( debugFFTW ) fftw_debug_complex ( 1 , 1 , 1 ) = data_complex ( 1 , 1 , 1 , row , column )
2011-12-06 22:28:17 +05:30
2012-01-13 21:48:16 +05:30
call fftw_execute_dft_c2r ( fftw_fluctuation , data_complex , data_real ) ! back transform of fluct deformation gradient
if ( debugFFTW ) then
print '(a,i1,x,i1)' , 'checking iFT results of compontent ' , row , column
call fftw_execute_dft_c2r ( fftw_debug_backward , fftw_debug_complex , fftw_debug_real )
print '(a,es10.4)' , 'max iFT relative error ' , &
maxval ( ( fftw_debug_real ( 1 : res ( 1 ) , 1 : res ( 2 ) , 1 : res ( 3 ) ) - data_real ( 1 : res ( 1 ) , 1 : res ( 2 ) , 1 : res ( 3 ) , row , column ) ) / fftw_debug_real ( 1 : res ( 1 ) , 1 : res ( 2 ) , 1 : res ( 3 ) ) )
endif
2011-12-06 22:28:17 +05:30
2012-01-13 21:48:16 +05:30
defgrad = defgrad + data_real ( 1 : res ( 1 ) , 1 : res ( 2 ) , 1 : res ( 3 ) , 1 : 3 , 1 : 3 ) * wgt ! F(x)^(n+1) = F(x)^(n) + correction; *wgt: correcting for missing normalization
2011-12-06 22:28:17 +05:30
do m = 1_pInt , 3_pInt ; do n = 1_pInt , 3_pInt
2011-12-23 18:00:35 +05:30
defgrad_av_lab ( m , n ) = sum ( defgrad ( 1 : res ( 1 ) , 1 : res ( 2 ) , 1 : res ( 3 ) , m , n ) ) * wgt ! ToDo: check whether this needs recalculation or is equivalent to former defgrad_av
2011-12-06 22:28:17 +05:30
enddo ; enddo
! stress boundary condition check -------------
pstress_av = math_rotate_forward3x3 ( pstress_av_lab , bc ( loadcase ) % rotation )
print '(a,/,3(3(f12.7,x)/)$)' , 'Piola-Kirchhoff stress / MPa: ' , math_transpose3x3 ( pstress_av ) / 1.e6
if ( size_reduced > 0_pInt ) then ! calculate stress BC if applied
err_stress = maxval ( abs ( mask_stress * ( pstress_av - bc ( loadcase ) % stress ) ) ) ! maximum deviaton (tensor norm not applicable)
2012-01-04 23:13:26 +05:30
err_stress_tol = maxval ( abs ( pstress_av ) ) * err_stress_tolrel ! don't use any tensor norm because the comparison should be coherent
2011-12-06 22:28:17 +05:30
print '(a)' , ''
print '(a,es10.4,a,f6.2)' , 'error stress = ' , err_stress , ', ' , err_stress / err_stress_tol
print '(a)' , '... correcting deformation gradient to fulfill BCs ..........'
defgradAimCorr = - math_mul3333xx33 ( s_prev , ( ( pstress_av - bc ( loadcase ) % stress ) ) ) ! residual on given stress components
defgradAim = defgradAim + defgradAimCorr
print '(a,/,3(3(f12.7,x)/)$)' , 'new deformation aim: ' , math_transpose3x3 ( defgradAim )
print '(a,x,es10.4)' , 'with determinant: ' , math_det3x3 ( defgradAim )
else
err_stress_tol = 0.0_pReal
endif
! ------------------------------
! homogeneous correction towards avg deformation gradient -------------
2011-12-23 18:00:35 +05:30
defgradAim_lab = math_rotate_backward3x3 ( defgradAim , bc ( loadcase ) % rotation ) ! boundary conditions from load frame into lab (Fourier) frame
2011-12-06 22:28:17 +05:30
do m = 1_pInt , 3_pInt ; do n = 1_pInt , 3_pInt
defgrad ( 1 : res ( 1 ) , 1 : res ( 2 ) , 1 : res ( 3 ) , m , n ) = &
2011-12-23 18:00:35 +05:30
defgrad ( 1 : res ( 1 ) , 1 : res ( 2 ) , 1 : res ( 3 ) , m , n ) + ( defgradAim_lab ( m , n ) - defgrad_av_lab ( m , n ) ) ! anticipated target minus current state
2011-12-06 22:28:17 +05:30
enddo ; enddo
! ------------------------------
! bounds of det(F) -------------
defgradDetMax = - huge ( 1.0_pReal )
defgradDetMin = + huge ( 1.0_pReal )
do k = 1_pInt , res ( 3 ) ; do j = 1_pInt , res ( 2 ) ; do i = 1_pInt , res ( 1 )
defgradDet = math_det3x3 ( defgrad ( i , j , k , 1 : 3 , 1 : 3 ) )
defgradDetMax = max ( defgradDetMax , defgradDet )
defgradDetMin = min ( defgradDetMin , defgradDet )
enddo ; enddo ; enddo
print '(a,x,es10.4)' , 'max determinant of deformation:' , defgradDetMax
print '(a,x,es10.4)' , 'min determinant of deformation:' , defgradDetMin
! ------------------------------
2011-11-18 03:41:05 +05:30
enddo ! end looping when convergency is achieved
2012-01-04 23:13:26 +05:30
2011-11-02 20:08:42 +05:30
!$OMP CRITICAL (write2out)
2011-12-04 15:31:32 +05:30
print '(a)' , ''
2011-11-18 03:41:05 +05:30
print '(a)' , '============================================================='
2011-12-04 15:31:32 +05:30
if ( err_div > err_div_tol . or . err_stress > err_stress_tol ) then
2012-01-13 21:48:16 +05:30
print '(A,I5.5,A)' , 'increment ' , totalIncsCounter , ' NOT converged'
2011-12-04 15:31:32 +05:30
notConvergedCounter = notConvergedCounter + 1_pInt
2011-11-18 03:41:05 +05:30
else
2012-01-13 21:48:16 +05:30
print '(A,I5.5,A)' , 'increment ' , totalIncsCounter , ' converged'
2011-11-18 03:41:05 +05:30
endif
2012-01-13 21:48:16 +05:30
if ( mod ( totalIncsCounter - 1_pInt , bc ( loadcase ) % outputfrequency ) == 0_pInt ) then ! at output frequency
2011-12-04 15:31:32 +05:30
print '(a)' , ''
print '(a)' , '... writing results to file .................................'
write ( 538 ) , materialpoint_results ( 1_pInt : materialpoint_sizeResults , 1 , 1_pInt : Npoints ) ! write result to file
2011-11-18 03:41:05 +05:30
endif
2011-11-02 20:08:42 +05:30
!$OMP END CRITICAL (write2out)
2012-01-04 23:13:26 +05:30
! ##################################################
! # test of regridding
! allocate(deformed_small(res(1) ,res(2) ,res(3) ,3)); deformed_small = 0.0_pReal
! allocate(deformed_large(3,Npoints*27_pInt)); deformed_large = 0.0_pReal !ToDo: make it smaller (small corona only)
! call deformed_fft(res,geomdimension,defgrad_av_lab,1.0_pReal,defgrad,deformed_small) ! calculate deformed coordinates
! shift = math_mul33x3(defgrad_av_lab,geomdimension)
! print*, 'defgrad'
! do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1)
! print*, defgrad(i,j,k,1:3,1:3)
! enddo; enddo; enddo
! print*, 'deformed_small'
! do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1)
! print*, deformed_small(i,j,k,1:3)
! enddo; enddo; enddo
! print*, 'shift', shift
! ielem = 0_pInt
! do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1)
! do n = -1, 1
! do m = -1, 1
! do l = -1, 1
! ielem = ielem +1_pInt
! deformed_large(1:3,ielem) = deformed_small(i,j,k,1:3)+ real((/l,m,n/),pReal)*shift
! enddo; enddo; enddo
! enddo; enddo; enddo
! print*, 'deformed_large'
! print*, deformed_large
! tree => kdtree2_create(deformed_large,sort=.true.,rearrange=.true.)
! allocate(new_coordinates(res(1),res(2),res(3),3)); new_coordinates = 0.0_pReal !fluctuation free new coordinates
! do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1)
! new_coordinates(i,j,k,1:3) = math_mul33x3(defgrad_av_lab,coordinates(1:3,i,j,k))
! enddo; enddo; enddo
! pause
! ##################################################
! # end test of regridding
2011-12-06 22:28:17 +05:30
endif ! end calculation/forwarding
2012-01-13 21:48:16 +05:30
enddo ! end looping over incs in current loadcase
2011-08-26 19:36:37 +05:30
deallocate ( c_reduced )
deallocate ( s_reduced )
enddo ! end looping over loadcases
2011-11-02 20:08:42 +05:30
!$OMP CRITICAL (write2out)
2011-12-04 15:31:32 +05:30
print '(a)' , ''
2011-11-15 23:24:18 +05:30
print '(a)' , '#############################################################'
2012-01-16 20:40:16 +05:30
print '(i6.6,a,i6.6,a)' , notConvergedCounter , ' out of ' , &
totalIncsCounter - restartReadInc + 1_pInt , ' increments did not converge!'
2011-11-02 20:08:42 +05:30
!$OMP END CRITICAL (write2out)
2011-01-07 18:26:45 +05:30
close ( 538 )
2012-01-13 21:48:16 +05:30
call fftw_destroy_plan ( fftw_stress ) ; call fftw_destroy_plan ( fftw_fluctuation )
if ( debugDivergence ) call fftw_destroy_plan ( fftw_divergence )
if ( debugFFTW ) then
call fftw_destroy_plan ( fftw_debug_forward )
call fftw_destroy_plan ( fftw_debug_backward )
endif
2011-05-11 22:08:45 +05:30
end program DAMASK_spectral
2010-06-10 20:21:10 +05:30
!********************************************************************
! quit subroutine to satisfy IO_error
!
!********************************************************************
2010-06-08 15:38:15 +05:30
subroutine quit ( id )
use prec
implicit none
integer ( pInt ) id
stop
2011-05-24 21:27:59 +05:30
end subroutine