From bd9667bd4b7939cd243f53578ded4a003815c6a2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 8 Mar 2012 20:25:28 +0000 Subject: [PATCH] added new, flexible debugging scheme. now all modules have their own debug specification. compiles and runs, I hope nothing is broken did a lot of polishing --- code/CPFEM.f90 | 215 ++--- code/DAMASK_marc.f90 | 51 +- code/DAMASK_spectral_interface.f90 | 30 +- code/FEsolving.f90 | 89 +- code/config/debug.config | 30 +- code/constitutive.f90 | 147 ++-- code/constitutive_j2.f90 | 248 +++--- code/constitutive_nonlocal.f90 | 63 +- code/constitutive_phenopowerlaw.f90 | 335 ++++---- code/constitutive_titanmod.f90 | 330 +++---- code/crystallite.f90 | 448 +++++----- code/debug.f90 | 702 ++++++++------- code/homogenization.f90 | 34 +- code/homogenization_RGC.f90 | 121 +-- code/homogenization_isostrain.f90 | 90 +- code/lattice.f90 | 130 +-- code/makefile | 355 -------- code/material.f90 | 345 ++++---- code/math.f90 | 525 +++++++----- code/mesh.f90 | 1229 +++++++++++++++------------ 20 files changed, 2790 insertions(+), 2727 deletions(-) delete mode 100644 code/makefile diff --git a/code/CPFEM.f90 b/code/CPFEM.f90 index 27c0d04ce..6c2b69c7f 100644 --- a/code/CPFEM.f90 +++ b/code/CPFEM.f90 @@ -23,8 +23,7 @@ MODULE CPFEM !############################################################## ! *** CPFEM engine *** ! -use prec, only: pReal, & - pInt +use prec, only: pReal implicit none real(pReal), parameter :: CPFEM_odd_stress = 1e15_pReal, & @@ -47,8 +46,8 @@ CONTAINS subroutine CPFEM_initAll(Temperature,element,IP) - use prec, only: pReal, & - prec_init + use prec, only: prec_init, & + pInt use numerics, only: numerics_init use debug, only: debug_init use FEsolving, only: FE_init @@ -61,8 +60,8 @@ subroutine CPFEM_initAll(Temperature,element,IP) use homogenization, only: homogenization_init use IO, only: IO_init use DAMASK_interface - implicit none + implicit none integer(pInt), intent(in) :: element, & ! FE element number IP ! FE integration point number real(pReal), intent(in) :: Temperature ! temperature @@ -79,19 +78,19 @@ subroutine CPFEM_initAll(Temperature,element,IP) n = n+1_pInt if (.not. CPFEM_init_inProgress) then ! yes my thread won! CPFEM_init_inProgress = .true. - call prec_init() - call IO_init() - call numerics_init() - call debug_init() - call math_init() - call FE_init() + call prec_init + call IO_init + call numerics_init + call debug_init + call math_init + call FE_init call mesh_init(IP, element) ! pass on coordinates to alter calcMode of first ip - call lattice_init() - call material_init() - call constitutive_init() + call lattice_init + call material_init + call constitutive_init call crystallite_init(Temperature) ! (have to) use temperature of first IP for whole model call homogenization_init(Temperature) - call CPFEM_init() + call CPFEM_init if (trim(FEsolver)/='Spectral') call DAMASK_interface_init() ! Spectral solver is doing initialization earlier CPFEM_init_done = .true. CPFEM_init_inProgress = .false. @@ -101,18 +100,20 @@ subroutine CPFEM_initAll(Temperature,element,IP) endif endif -end subroutine +end subroutine CPFEM_initAll !********************************************************* !*** allocate the arrays defined in module CPFEM *** !*** and initialize them *** !********************************************************* -subroutine CPFEM_init() +subroutine CPFEM_init use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) use prec, only: pInt - use debug, only: debug_verbosity + use debug, only: debug_what, & + debug_CPFEM, & + debug_levelBasic use IO, only: IO_read_jobBinaryFile use FEsolving, only: parallelExecution, & symmetricSolver, & @@ -133,7 +134,6 @@ subroutine CPFEM_init() implicit none - integer(pInt) i,j,k,l,m ! initialize stress and jacobian to zero @@ -143,7 +143,7 @@ subroutine CPFEM_init() ! *** restore the last converged values of each essential variable from the binary file if (restartRead) then - if (debug_verbosity > 0) then + if (iand(debug_what(debug_CPFEM), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a)') '<< CPFEM >> Restored state variables of last converged step from binary files' !$OMP END CRITICAL (write2out) @@ -205,7 +205,7 @@ subroutine CPFEM_init() write(6,*) '<<<+- cpfem init -+>>>' write(6,*) '$Id$' #include "compilation_info.f90" - if (debug_verbosity > 0) then + if (iand(debug_what(debug_CPFEM), debug_levelBasic) /= 0) then write(6,'(a32,1x,6(i8,1x))') 'CPFEM_cs: ', shape(CPFEM_cs) write(6,'(a32,1x,6(i8,1x))') 'CPFEM_dcsdE: ', shape(CPFEM_dcsdE) write(6,'(a32,1x,6(i8,1x))') 'CPFEM_dcsdE_knownGood: ', shape(CPFEM_dcsdE_knownGood) @@ -216,7 +216,7 @@ subroutine CPFEM_init() call flush(6) !$OMP END CRITICAL (write2out) -endsubroutine +end subroutine CPFEM_init !*********************************************************************** @@ -228,81 +228,82 @@ subroutine CPFEM_general(mode, coords, ffn, ffn1, Temperature, dt, element, IP, ! note: cauchyStress = Cauchy stress cs(6) and jacobian = Consistent tangent dcs/dE !*** variables and functions from other modules ***! - use prec, only: pReal, & - pInt - use numerics, only: defgradTolerance, & - iJacoStiffness - use debug, only: debug_e, & - debug_i, & - debug_selectiveDebugger, & - debug_verbosity, & - debug_stressMaxLocation, & - debug_stressMinLocation, & - debug_jacobianMaxLocation, & - debug_jacobianMinLocation, & - debug_stressMax, & - debug_stressMin, & - debug_jacobianMax, & - debug_jacobianMin - use FEsolving, only: parallelExecution, & - outdatedFFN1, & - terminallyIll, & - cycleCounter, & - theInc, & - theTime, & - theDelta, & - FEsolving_execElem, & - FEsolving_execIP, & - restartWrite - use math, only: math_identity2nd, & - math_mul33x33, & - math_det33, & - math_transpose33, & - math_I3, & - math_Mandel3333to66, & - math_Mandel66to3333, & - math_Mandel33to6, & - math_Mandel6to33 - use mesh, only: mesh_FEasCP, & - mesh_NcpElems, & - mesh_maxNips, & - mesh_element, & - mesh_node0, & - mesh_node, & - mesh_ipCenterOfGravity, & - mesh_build_subNodeCoords, & - mesh_build_ipVolumes, & - mesh_build_ipCoordinates, & - FE_Nips, & - FE_Nnodes - use material, only: homogenization_maxNgrains, & - microstructure_elemhomo, & - material_phase - use constitutive, only: constitutive_state0,constitutive_state - use crystallite, only: crystallite_partionedF,& - crystallite_F0, & - crystallite_Fp0, & - crystallite_Fp, & - crystallite_Lp0, & - crystallite_Lp, & - crystallite_dPdF0, & - crystallite_dPdF, & - crystallite_Tstar0_v, & - crystallite_Tstar_v - use homogenization, only: homogenization_sizeState, & - homogenization_state, & - homogenization_state0, & - materialpoint_F, & - materialpoint_F0, & - materialpoint_P, & - materialpoint_dPdF, & - materialpoint_results, & - materialpoint_sizeResults, & - materialpoint_Temperature, & - materialpoint_stressAndItsTangent, & - materialpoint_postResults - use IO, only: IO_write_jobBinaryFile, & - IO_warning + use prec, only: pInt + use numerics, only: defgradTolerance, & + iJacoStiffness + use debug, only: debug_what, & + debug_CPFEM, & + debug_levelBasic, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_stressMaxLocation, & + debug_stressMinLocation, & + debug_jacobianMaxLocation, & + debug_jacobianMinLocation, & + debug_stressMax, & + debug_stressMin, & + debug_jacobianMax, & + debug_jacobianMin + use FEsolving, only: parallelExecution, & + outdatedFFN1, & + terminallyIll, & + cycleCounter, & + theInc, & + theTime, & + theDelta, & + FEsolving_execElem, & + FEsolving_execIP, & + restartWrite + use math, only: math_identity2nd, & + math_mul33x33, & + math_det33, & + math_transpose33, & + math_I3, & + math_Mandel3333to66, & + math_Mandel66to3333, & + math_Mandel33to6, & + math_Mandel6to33 + use mesh, only: mesh_FEasCP, & + mesh_NcpElems, & + mesh_maxNips, & + mesh_element, & + mesh_node0, & + mesh_node, & + mesh_ipCenterOfGravity, & + mesh_build_subNodeCoords, & + mesh_build_ipVolumes, & + mesh_build_ipCoordinates, & + FE_Nips, & + FE_Nnodes + use material, only: homogenization_maxNgrains, & + microstructure_elemhomo, & + material_phase + use constitutive, only: constitutive_state0,constitutive_state + use crystallite, only: crystallite_partionedF,& + crystallite_F0, & + crystallite_Fp0, & + crystallite_Fp, & + crystallite_Lp0, & + crystallite_Lp, & + crystallite_dPdF0, & + crystallite_dPdF, & + crystallite_Tstar0_v, & + crystallite_Tstar_v + use homogenization, only: homogenization_sizeState, & + homogenization_state, & + homogenization_state0, & + materialpoint_F, & + materialpoint_F0, & + materialpoint_P, & + materialpoint_dPdF, & + materialpoint_results, & + materialpoint_sizeResults, & + materialpoint_Temperature, & + materialpoint_stressAndItsTangent, & + materialpoint_postResults + use IO, only: IO_write_jobBinaryFile, & + IO_warning use DAMASK_interface implicit none @@ -359,7 +360,7 @@ subroutine CPFEM_general(mode, coords, ffn, ffn1, Temperature, dt, element, IP, cp_en = mesh_FEasCP('elem',element) - if (debug_verbosity > 0 .and. cp_en == 1 .and. IP == 1) then + if (iand(debug_what(debug_CPFEM), debug_levelBasic) /= 0_pInt .and. cp_en == 1 .and. IP == 1) then !$OMP CRITICAL (write2out) write(6,*) write(6,'(a)') '#############################################' @@ -396,7 +397,7 @@ subroutine CPFEM_general(mode, coords, ffn, ffn1, Temperature, dt, element, IP, j = 1:mesh_maxNips, & k = 1:mesh_NcpElems ) & constitutive_state0(i,j,k)%p = constitutive_state(i,j,k)%p ! microstructure of crystallites - if (debug_verbosity > 0) then + if (iand(debug_what(debug_CPFEM), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a)') '<< CPFEM >> Aging states' if (debug_e == cp_en .and. debug_i == IP) then @@ -418,7 +419,7 @@ subroutine CPFEM_general(mode, coords, ffn, ffn1, Temperature, dt, element, IP, ! * dump the last converged values of each essential variable to a binary file if (restartWrite) then - if (debug_verbosity > 0) then + if (iand(debug_what(debug_CPFEM), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a)') '<< CPFEM >> Writing state variables of last converged step to binary files' !$OMP END CRITICAL (write2out) @@ -487,7 +488,7 @@ subroutine CPFEM_general(mode, coords, ffn, ffn1, Temperature, dt, element, IP, if (terminallyIll .or. outdatedFFN1 .or. any(abs(ffn1 - materialpoint_F(1:3,1:3,IP,cp_en)) > defgradTolerance)) then if (.not. terminallyIll .and. .not. outdatedFFN1) then - if (debug_verbosity > 0) then + if (iand(debug_what(debug_CPFEM), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a,1x,i8,1x,i2)') '<< CPFEM >> OUTDATED at element ip',cp_en,IP write(6,'(a,/,3(12x,3(f10.6,1x),/))') '<< CPFEM >> FFN1 old:',math_transpose33(materialpoint_F(1:3,1:3,IP,cp_en)) @@ -514,7 +515,7 @@ subroutine CPFEM_general(mode, coords, ffn, ffn1, Temperature, dt, element, IP, FEsolving_execElem(2) = cp_en FEsolving_execIP(1,cp_en) = IP FEsolving_execIP(2,cp_en) = IP - if (debug_verbosity > 0) then + if (iand(debug_what(debug_CPFEM), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a,i8,1x,i2)') '<< CPFEM >> Calculation for element ip ',cp_en,IP !$OMP END CRITICAL (write2out) @@ -525,7 +526,7 @@ subroutine CPFEM_general(mode, coords, ffn, ffn1, Temperature, dt, element, IP, !* parallel computation and calulation not yet done elseif (.not. CPFEM_calc_done) then - if (debug_verbosity > 0) then + if (iand(debug_what(debug_CPFEM), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a,i8,a,i8)') '<< CPFEM >> Calculation for elements ',FEsolving_execElem(1),' to ',FEsolving_execElem(2) !$OMP END CRITICAL (write2out) @@ -534,7 +535,7 @@ subroutine CPFEM_general(mode, coords, ffn, ffn1, Temperature, dt, element, IP, call mesh_build_subNodeCoords() ! update subnodal coordinates call mesh_build_ipCoordinates() ! update ip coordinates endif - if (debug_verbosity > 0) then + if (iand(debug_what(debug_CPFEM), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a,i8,a,i8)') '<< CPFEM >> Start stress and tangent ',FEsolving_execElem(1),' to ',FEsolving_execElem(2) !$OMP END CRITICAL (write2out) @@ -640,7 +641,9 @@ subroutine CPFEM_general(mode, coords, ffn, ffn1, Temperature, dt, element, IP, Temperature = materialpoint_Temperature(IP,cp_en) ! homogenized result except for potentially non-isothermal starting condition. endif - if (mode < 3 .and. debug_verbosity > 0 .and. ((debug_e == cp_en .and. debug_i == IP) .or. .not. debug_selectiveDebugger)) then + if (mode < 3 .and. iand(debug_what(debug_CPFEM), debug_levelBasic) /= 0_pInt & + .and. ((debug_e == cp_en .and. debug_i == IP) & + .or. .not. iand(debug_what(debug_CPFEM), debug_levelSelective) /= 0_pInt)) then !$OMP CRITICAL (write2out) write(6,'(a,i8,1x,i2,/,12x,6(f10.3,1x)/)') '<< CPFEM >> stress/MPa at el ip ', cp_en, IP, cauchyStress/1.0e6_pReal write(6,'(a,i8,1x,i2,/,6(12x,6(f10.3,1x)/))') '<< CPFEM >> jacobian/GPa at el ip ', cp_en, IP, transpose(jacobian)/1.0e9_pReal @@ -679,6 +682,6 @@ subroutine CPFEM_general(mode, coords, ffn, ffn1, Temperature, dt, element, IP, endif endif -end subroutine +end subroutine CPFEM_general END MODULE CPFEM diff --git a/code/DAMASK_marc.f90 b/code/DAMASK_marc.f90 index 0b13b7a87..bfec56a8f 100644 --- a/code/DAMASK_marc.f90 +++ b/code/DAMASK_marc.f90 @@ -58,16 +58,17 @@ #include "prec.f90" -MODULE DAMASK_interface +module DAMASK_interface -character(len=64), parameter :: FEsolver = 'Marc' -character(len=4), parameter :: InputFileExtension = '.dat' -character(len=4), parameter :: LogFileExtension = '.log' + character(len=64), parameter :: FEsolver = 'Marc' + character(len=4), parameter :: InputFileExtension = '.dat' + character(len=4), parameter :: LogFileExtension = '.log' -CONTAINS +contains -subroutine DAMASK_interface_init() +subroutine DAMASK_interface_init +implicit none !$OMP CRITICAL (write2out) write(6,*) @@ -75,11 +76,14 @@ subroutine DAMASK_interface_init() write(6,*) '$Id$' #include "compilation_info.f90" !$OMP END CRITICAL (write2out) - return -end subroutine + +end subroutine DAMASK_interface_init + function getSolverWorkingDirectoryName() + implicit none + character(1024) getSolverWorkingDirectoryName, outName character(len=*), parameter :: pathSep = achar(47)//achar(92) ! forward and backward slash @@ -88,26 +92,27 @@ function getSolverWorkingDirectoryName() inquire(6, name=outName) ! determine outputfile getSolverWorkingDirectoryName=outName(1:scan(outName,pathSep,back=.true.)) ! write(6,*) 'getSolverWorkingDirectoryName', getSolverWorkingDirectoryName -end function + +end function getSolverWorkingDirectoryName function getModelName() - use prec implicit none - - character(1024) getModelName + character(1024) :: getModelName getModelName = getSolverJobName() -end function + +end function getModelName function getSolverJobName() - use prec + + use prec, only: pInt implicit none - character(1024) getSolverJobName, outName + character(1024) :: getSolverJobName, outName character(len=*), parameter :: pathSep = achar(47)//achar(92) ! forward and backward slash - integer(pInt) extPos + integer(pInt) :: extPos getSolverJobName='' outName='' @@ -115,9 +120,10 @@ function getSolverJobName() extPos = len_trim(outName)-4 getSolverJobName=outName(scan(outName,pathSep,back=.true.)+1:extPos) ! write(6,*) 'getSolverJobName', getSolverJobName -end function -END MODULE +end function getSolverJobName + +end module DAMASK_interface #include "IO.f90" #include "numerics.f90" @@ -234,8 +240,8 @@ subroutine hypela2(& use CPFEM, only: CPFEM_initAll,CPFEM_general,CPFEM_init_done !$ use OMP_LIB ! the openMP function library !$ use numerics, only: DAMASK_NumThreadsInt ! number of threads set by DAMASK_NUM_THREADS - implicit none + implicit none ! ** Start of generated type statements ** real(pReal) coord, d, de, disp, dispt, dt, e, eigvn, eigvn1, ffn, ffn1 real(pReal) frotn, frotn1, g @@ -365,7 +371,7 @@ subroutine hypela2(& !$ call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value -end subroutine +end subroutine hypela2 !******************************************************************** @@ -394,8 +400,8 @@ subroutine plotv(& use mesh, only: mesh_FEasCP use IO, only: IO_error use homogenization, only: materialpoint_results,materialpoint_sizeResults + implicit none - real(pReal) s(*),etot(*),eplas(*),ecreep(*),sp(*) real(pReal) v, t(*) integer(pInt) m, nn, layer, ndi, nshear, jpltcd @@ -403,6 +409,5 @@ subroutine plotv(& if (jpltcd > materialpoint_sizeResults) call IO_error(700_pInt,jpltcd) ! complain about out of bounds error v = materialpoint_results(jpltcd,nn,mesh_FEasCP('elem', m)) - return -end subroutine +end subroutine plotv diff --git a/code/DAMASK_spectral_interface.f90 b/code/DAMASK_spectral_interface.f90 index c89b51804..a1d34f012 100644 --- a/code/DAMASK_spectral_interface.f90 +++ b/code/DAMASK_spectral_interface.f90 @@ -27,13 +27,13 @@ module DAMASK_interface implicit none private - character(len=64), parameter, public :: FEsolver = 'Spectral' !> Keyword for spectral solver - character(len=5), parameter, public :: inputFileExtension = '.geom' !> File extension for geometry description - character(len=4), parameter, public :: logFileExtension = '.log' !> Dummy variable as the spectral solver has no log - character(len=1024), private :: geometryParameter, & - loadcaseParameter + character(len=64), parameter, public :: FEsolver = 'Spectral' !< Keyword for spectral solver + character(len=5), parameter, public :: inputFileExtension = '.geom' !< File extension for geometry description + character(len=4), parameter, public :: logFileExtension = '.log' !< Dummy variable as the spectral solver has no log + character(len=1024), private :: geometryParameter, & !< Interpretated parameter given at command line + loadcaseParameter !< Interpretated parameter given at command line - public :: getSolverWorkingDirectoryName, & + public :: getSolverWorkingDirectoryName, & !< Interpretated parameter given at command line getSolverJobName, & getLoadCase, & getLoadCaseName, & @@ -46,7 +46,7 @@ module DAMASK_interface contains !-------------------------------------------------------------------------------------------------- -!> @brief Initializes the solver by interpreting the command line arguments. Also writes +!> @brief initializes the solver by interpreting the command line arguments. Also writes !! information on computation on screen !-------------------------------------------------------------------------------------------------- subroutine DAMASK_interface_init @@ -54,12 +54,12 @@ subroutine DAMASK_interface_init use prec, only: pInt implicit none - character(len=1024) :: commandLine, & !> command line call as string - hostName, & !> name of computer - userName !> name of user calling the executable + character(len=1024) :: commandLine, & !< command line call as string + hostName, & !< name of computer + userName !< name of user calling the executable integer :: i, & - start = 0,& - length=0 + start ,& + length integer, dimension(8) :: dateAndTime ! type default integer call get_command(commandLine) @@ -186,11 +186,11 @@ end subroutine DAMASK_interface_init !-------------------------------------------------------------------------------------------------- !> @brief extract working directory from loadcase file possibly based on current working dir !-------------------------------------------------------------------------------------------------- -function getSolverWorkingDirectoryName() + character(len=1024) function getSolverWorkingDirectoryName() implicit none - character(len=1024) :: cwd, getSolverWorkingDirectoryName - character :: pathSep + character(len=1024) :: cwd + character :: pathSep pathSep = getPathSep() diff --git a/code/FEsolving.f90 b/code/FEsolving.f90 index 876e70dc5..2733f1ec4 100644 --- a/code/FEsolving.f90 +++ b/code/FEsolving.f90 @@ -19,50 +19,81 @@ !############################################################## !* $Id$ !############################################################## - MODULE FEsolving +module FEsolving !############################################################## use prec, only: pInt,pReal + implicit none + integer(pInt) :: & + cycleCounter = 0_pInt, & + theInc = -1_pInt, & + restartInc = 1_pInt + + real(pReal) :: & + theTime = 0.0_pReal, & + theDelta = 0.0_pReal + + logical :: & + lastIncConverged = .false., & + outdatedByNewInc = .false., & + outdatedFFN1 = .false., & + terminallyIll = .false., & + symmetricSolver = .false., & + parallelExecution = .true., & + restartWrite = .false., & + restartRead = .false., & + lastMode = .true., & + cutBack = .false. + + integer(pInt), dimension(:,:), allocatable :: & + FEsolving_execIP + + integer(pInt), dimension(2) :: & + FEsolving_execElem + + character(len=1024) :: & + FEmodelGeometry + + logical, dimension(:,:), allocatable :: & + calcMode + + public :: FE_init - integer(pInt) :: cycleCounter = 0_pInt, theInc = -1_pInt, restartInc = 1_pInt - real(pReal) :: theTime = 0.0_pReal, theDelta = 0.0_pReal - logical :: lastIncConverged = .false.,outdatedByNewInc = .false.,outdatedFFN1 = .false.,terminallyIll = .false. - logical :: symmetricSolver = .false. - logical :: parallelExecution = .true. - logical :: restartWrite = .false. - logical :: restartRead = .false. - logical :: lastMode = .true., cutBack = .false. - logical, dimension(:,:), allocatable :: calcMode - integer(pInt), dimension(:,:), allocatable :: FEsolving_execIP - integer(pInt), dimension(2) :: FEsolving_execElem - character(len=1024) FEmodelGeometry - - CONTAINS +contains !*********************************************************** ! determine whether a symmetric solver is used ! and whether restart is requested !*********************************************************** - subroutine FE_init() +subroutine FE_init use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) - use prec, only: pInt - use debug, only: debug_verbosity + use debug, only: debug_what, & + debug_FEsolving, & + debug_levelBasic + use IO, only: IO_open_inputFile, & + IO_stringPos, & + IO_stringValue, & + IO_intValue, & + IO_lc, & + IO_open_logFile, & + IO_warning use DAMASK_interface - use IO - implicit none + implicit none integer(pInt), parameter :: fileunit = 222_pInt integer(pInt), parameter :: maxNchunks = 6_pInt - integer :: i, start = 0, length=0 + + integer :: i, start = 0, length ! is save for FE_init (only called once) integer(pInt) :: j integer(pInt), dimension(1_pInt+2_pInt*maxNchunks) :: positions - character(len=64) tag - character(len=1024) line, commandLine - + character(len=64) :: tag + character(len=1024) :: line, & + commandLine + FEmodelGeometry = getModelName() - call IO_open_inputFile(fileunit,FEmodelGeometry) + if (trim(FEsolver) == 'Spectral') then call get_command(commandLine) ! may contain uppercase do i=1,len(commandLine) @@ -73,7 +104,7 @@ start = index(commandLine,'-r ',.true.) + 3 ! set to position after trailing space if (index(commandLine,'--restart ',.true.)>0) & ! look for --restart start = index(commandLine,'--restart ',.true.) + 10 ! set to position after trailing space - if(start /= 0_pInt) then ! found something + if(start /= 0) then ! found something length = verify(commandLine(start:len(commandLine)),'0123456789',.false.) ! where is first non number after argument? read(commandLine(start:start+length),'(I12)') restartInc ! read argument restartRead = restartInc > 0_pInt @@ -148,7 +179,7 @@ write(6,*) '<<<+- FEsolving init -+>>>' write(6,*) '$Id$' #include "compilation_info.f90" - if (debug_verbosity > 0) then + if (iand(debug_what(debug_FEsolving),debug_levelBasic) /= 0_pInt) then write(6,*) 'restart writing: ', restartWrite write(6,*) 'restart reading: ', restartRead if (restartRead) write(6,*) 'restart Job: ', trim(FEmodelGeometry) @@ -156,6 +187,6 @@ endif !$OMP END CRITICAL (write2out) - end subroutine +end subroutine FE_init - END MODULE FEsolving +end module FEsolving diff --git a/code/config/debug.config b/code/config/debug.config index 87698a6a2..f51ac54d0 100644 --- a/code/config/debug.config +++ b/code/config/debug.config @@ -1,21 +1,19 @@ ### $Id$ ### ### debugging parameters ### -verbosity 1 # level of detail of the debugging output (0-8) - # 0 : only version infos and all from "hypela2"/"umat" - # 1 : basic outputs from "CPFEM.f90", basic output from initialization routines, debug_info - # 2 : extensive outputs from "CPFEM.f90", extensive output from initialization routines - # 3 : basic outputs from "homogenization.f90" - # 4 : extensive outputs from "homogenization.f90" - # 5 : basic outputs from "crystallite.f90" - # 6 : extensive outputs from "crystallite.f90" - # 7 : basic outputs from the constitutive files - # 8 : extensive outputs from the constitutive files -selective 1 # >0 true to switch on e,i,g selective debugging +debug # debug.f90, possible keys: basic, extensive +math # math.f90, possible key: basic +FEsolving # FEsolving.f90, possible key: basic +math # math.f90, possible key: basic +material # material.f90, possible keys: basic, extensive +lattice # lattice.f90, possible key: basic +constitutive # constitutive_*.f90 possible keys: basic, extensive, selective +crystallite # crystallite.f90 possible keys: basic, extensive, selective +homogenization # homogenization_*.f90 possible keys: basic, extensive, selective +CPFEM # CPFEM.f90 possible keys: basic, selective +spectral # DAMASK_spectral.f90 possible keys: basic, fft, restart, divergence +# +# Parameters for selective element 1 # selected element for debugging (synonymous: "el", "e") ip 1 # selected integration point for debugging (synonymous: "integrationpoint", "i") -grain 1 # selected grain at ip for debugging (synonymous: "gr", "g") - -### spectral solver debugging parameters ### -generalDebugSpectral 0 # > 0: general (algorithmical) debug outputs -divergenceDebugSpectral 0 # > 0: calculate more divergence measures and print them out \ No newline at end of file +grain 1 # selected grain at ip for debugging (synonymous: "gr", "g") \ No newline at end of file diff --git a/code/constitutive.f90 b/code/constitutive.f90 index d64b44f6d..c570b3342 100644 --- a/code/constitutive.f90 +++ b/code/constitutive.f90 @@ -28,30 +28,36 @@ MODULE constitutive -!*** Include other modules *** -use prec +use prec, only: pInt, p_vec + implicit none +type(p_vec), dimension(:,:,:), allocatable :: & + constitutive_state0, & ! pointer array to microstructure at start of FE inc + constitutive_partionedState0, & ! pointer array to microstructure at start of homogenization inc + constitutive_subState0, & ! pointer array to microstructure at start of crystallite inc + constitutive_state, & ! pointer array to current microstructure (end of converged time step) + constitutive_state_backup, & ! pointer array to backed up microstructure (end of converged time step) + constitutive_dotState, & ! pointer array to evolution of current microstructure + constitutive_previousDotState,& ! pointer array to previous evolution of current microstructure + constitutive_previousDotState2,& ! pointer array to 2nd previous evolution of current microstructure + constitutive_dotState_backup, & ! pointer array to backed up evolution of current microstructure + constitutive_RK4dotState, & ! pointer array to evolution of microstructure defined by classical Runge-Kutta method + constitutive_aTolState ! pointer array to absolute state tolerance -type(p_vec), dimension(:,:,:), allocatable :: constitutive_state0, & ! pointer array to microstructure at start of FE inc - constitutive_partionedState0, & ! pointer array to microstructure at start of homogenization inc - constitutive_subState0, & ! pointer array to microstructure at start of crystallite inc - constitutive_state, & ! pointer array to current microstructure (end of converged time step) - constitutive_state_backup, & ! pointer array to backed up microstructure (end of converged time step) - constitutive_dotState, & ! pointer array to evolution of current microstructure - constitutive_previousDotState,& ! pointer array to previous evolution of current microstructure - constitutive_previousDotState2,&! pointer array to 2nd previous evolution of current microstructure - constitutive_dotState_backup, & ! pointer array to backed up evolution of current microstructure - constitutive_RK4dotState, & ! pointer array to evolution of microstructure defined by classical Runge-Kutta method - constitutive_aTolState ! pointer array to absolute state tolerance -type(p_vec), dimension(:,:,:,:), allocatable :: constitutive_RKCK45dotState ! pointer array to evolution of microstructure used by Cash-Karp Runge-Kutta method -integer(pInt), dimension(:,:,:), allocatable :: constitutive_sizeDotState, & ! size of dotState array - constitutive_sizeState, & ! size of state array per grain - constitutive_sizePostResults ! size of postResults array per grain -integer(pInt) constitutive_maxSizeDotState, & - constitutive_maxSizeState, & - constitutive_maxSizePostResults + type(p_vec), dimension(:,:,:,:), allocatable :: & + constitutive_RKCK45dotState ! pointer array to evolution of microstructure used by Cash-Karp Runge-Kutta method -CONTAINS + integer(pInt), dimension(:,:,:), allocatable :: & + constitutive_sizeDotState, & ! size of dotState array + constitutive_sizeState, & ! size of state array per grain + constitutive_sizePostResults ! size of postResults array per grain + +integer(pInt) :: & + constitutive_maxSizeDotState, & + constitutive_maxSizeState, & + constitutive_maxSizePostResults + +contains !**************************************** !* - constitutive_init !* - constitutive_homogenizedC @@ -67,22 +73,36 @@ CONTAINS !************************************** !* Module initialization * !************************************** -subroutine constitutive_init() -use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) -use prec, only: pInt -use debug, only: debug_verbosity -use numerics, only: numerics_integrator -use IO, only: IO_error, IO_open_file, IO_open_jobFile_stat, IO_write_jobFile -use mesh, only: mesh_maxNips,mesh_NcpElems,mesh_element,FE_Nips -use material -use constitutive_j2 -use constitutive_phenopowerlaw -use constitutive_titanmod -use constitutive_dislotwin -use constitutive_nonlocal +subroutine constitutive_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: debug_what, & + debug_constitutive, & + debug_levelBasic + use numerics, only: numerics_integrator + use IO, only: IO_error, & + IO_open_file, & + IO_open_jobFile_stat, & + IO_write_jobFile + use mesh, only: mesh_maxNips, & + mesh_NcpElems, & + mesh_element,FE_Nips + use material, only: material_phase, & + material_Nphase, & + material_localFileExt, & + material_configFile, & + phase_name, & + phase_constitution, & + phase_constitutionInstance, & + phase_Noutput, & + homogenization_Ngrains, & + homogenization_maxNgrains + use constitutive_j2 + use constitutive_phenopowerlaw + use constitutive_titanmod + use constitutive_dislotwin + use constitutive_nonlocal implicit none - integer(pInt), parameter :: fileunit = 200_pInt integer(pInt) g, & ! grain number i, & ! integration point number @@ -96,7 +116,7 @@ integer(pInt) g, & ! grain number myNgrains integer(pInt), dimension(:,:), pointer :: thisSize character(len=64), dimension(:,:), pointer :: thisOutput -logical knownConstitution +logical :: knownConstitution ! --- PARSE CONSTITUTIONS FROM CONFIG FILE --- @@ -341,7 +361,7 @@ constitutive_maxSizePostResults = maxval(constitutive_sizePostResults) write(6,*) '<<<+- constitutive init -+>>>' write(6,*) '$Id$' #include "compilation_info.f90" - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt) then write(6,'(a32,1x,7(i8,1x))') 'constitutive_state0: ', shape(constitutive_state0) write(6,'(a32,1x,7(i8,1x))') 'constitutive_partionedState0: ', shape(constitutive_partionedState0) write(6,'(a32,1x,7(i8,1x))') 'constitutive_subState0: ', shape(constitutive_subState0) @@ -371,17 +391,16 @@ function constitutive_homogenizedC(ipc,ip,el) !* - ip : current integration point * !* - el : current element * !********************************************************************* - use prec, only: pReal,pInt + use prec, only: pReal use material, only: phase_constitution,material_phase use constitutive_j2 use constitutive_phenopowerlaw use constitutive_titanmod use constitutive_dislotwin use constitutive_nonlocal + implicit none - - !* Definition of variables - integer(pInt) ipc,ip,el + integer(pInt) :: ipc,ip,el real(pReal), dimension(6,6) :: constitutive_homogenizedC select case (phase_constitution(material_phase(ipc,ip,el))) @@ -415,17 +434,16 @@ function constitutive_averageBurgers(ipc,ip,el) !* - ip : current integration point * !* - el : current element * !********************************************************************* - use prec, only: pReal,pInt + use prec, only: pReal use material, only: phase_constitution,material_phase use constitutive_j2 use constitutive_phenopowerlaw use constitutive_titanmod use constitutive_dislotwin use constitutive_nonlocal + implicit none - - !* Definition of variables - integer(pInt) ipc,ip,el + integer(pInt) :: ipc,ip,el real(pReal) :: constitutive_averageBurgers select case (phase_constitution(material_phase(ipc,ip,el))) @@ -456,7 +474,7 @@ endfunction !* This function calculates from state needed variables * !********************************************************************* subroutine constitutive_microstructure(Temperature, Fe, Fp, ipc, ip, el) -use prec, only: pReal,pInt +use prec, only: pReal use material, only: phase_constitution, & material_phase use constitutive_j2, only: constitutive_j2_label, & @@ -469,8 +487,8 @@ use constitutive_dislotwin, only: constitutive_dislotwin_label, & constitutive_dislotwin_microstructure use constitutive_nonlocal, only: constitutive_nonlocal_label, & constitutive_nonlocal_microstructure -implicit none +implicit none !*** input variables ***! integer(pInt), intent(in):: ipc, & ! component-ID of current integration point ip, & ! current integration point @@ -513,7 +531,7 @@ endsubroutine !********************************************************************* subroutine constitutive_LpAndItsTangent(Lp, dLp_dTstar, Tstar_v, Temperature, ipc, ip, el) -use prec, only: pReal,pInt +use prec, only: pReal use material, only: phase_constitution, & material_phase use constitutive_j2, only: constitutive_j2_label, & @@ -526,9 +544,8 @@ use constitutive_dislotwin, only: constitutive_dislotwin_label, & constitutive_dislotwin_LpAndItsTangent use constitutive_nonlocal, only: constitutive_nonlocal_label, & constitutive_nonlocal_LpAndItsTangent + implicit none - - !*** input variables ***! integer(pInt), intent(in):: ipc, & ! component-ID of current integration point ip, & ! current integration point @@ -573,10 +590,12 @@ endsubroutine !********************************************************************* subroutine constitutive_collectDotState(Tstar_v, Fe, Fp, Temperature, subdt, orientation, ipc, ip, el) -use prec, only: pReal, pInt +use prec, only: pReal, pLongInt use debug, only: debug_cumDotStateCalls, & debug_cumDotStateTicks, & - debug_verbosity + debug_what, & + debug_constitutive, & + debug_levelBasic use mesh, only: mesh_NcpElems, & mesh_maxNips use material, only: phase_constitution, & @@ -594,7 +613,6 @@ use constitutive_nonlocal, only: constitutive_nonlocal_dotState, & constitutive_nonlocal_label implicit none - !*** input variables integer(pInt), intent(in) :: ipc, & ! component-ID of current integration point ip, & ! current integration point @@ -608,15 +626,12 @@ real(pReal), dimension(4,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), orientation ! crystal orientation (quaternion) real(pReal), dimension(6), intent(in) :: & Tstar_v ! 2nd Piola Kirchhoff stress tensor (Mandel) - -!*** output variables ***! - !*** local variables integer(pLongInt) tick, tock, & tickrate, & maxticks -if (debug_verbosity > 0_pInt) then +if (iand(debug_what(debug_constitutive), debug_levelBasic) /= 0_pInt) then call system_clock(count=tick,count_rate=tickrate,count_max=maxticks) endif @@ -640,7 +655,7 @@ select case (phase_constitution(material_phase(ipc,ip,el))) end select -if (debug_verbosity > 6_pInt) then +if (iand(debug_what(debug_constitutive), debug_levelBasic) /= 0_pInt) then call system_clock(count=tock,count_rate=tickrate,count_max=maxticks) !$OMP CRITICAL (debugTimingDotState) debug_cumDotStateCalls = debug_cumDotStateCalls + 1_pInt @@ -660,10 +675,12 @@ endsubroutine !********************************************************************* function constitutive_dotTemperature(Tstar_v,Temperature,ipc,ip,el) -use prec, only: pReal,pInt +use prec, only: pReal, pLongInt use debug, only: debug_cumDotTemperatureCalls, & debug_cumDotTemperatureTicks, & - debug_verbosity + debug_what, & + debug_constitutive, & + debug_levelBasic use material, only: phase_constitution, & material_phase use constitutive_j2, only: constitutive_j2_dotTemperature, & @@ -676,8 +693,8 @@ use constitutive_dislotwin, only: constitutive_dislotwin_dotTemperature, & constitutive_dislotwin_label use constitutive_nonlocal, only: constitutive_nonlocal_dotTemperature, & constitutive_nonlocal_label -implicit none +implicit none !*** input variables integer(pInt), intent(in) :: ipc, & ! component-ID of current integration point ip, & ! current integration point @@ -695,7 +712,7 @@ integer(pLongInt) tick, tock, & maxticks -if (debug_verbosity > 0_pInt) then +if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt) then call system_clock(count=tick,count_rate=tickrate,count_max=maxticks) endif @@ -718,7 +735,7 @@ select case (phase_constitution(material_phase(ipc,ip,el))) end select -if (debug_verbosity > 6_pInt) then +if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt) then call system_clock(count=tock,count_rate=tickrate,count_max=maxticks) !$OMP CRITICAL (debugTimingDotTemperature) debug_cumDotTemperatureCalls = debug_cumDotTemperatureCalls + 1_pInt @@ -742,7 +759,7 @@ function constitutive_postResults(Tstar_v, Fe, Temperature, dt, ipc, ip, el) !* - ip : current integration point * !* - el : current element * !********************************************************************* -use prec, only: pReal,pInt +use prec, only: pReal use mesh, only: mesh_NcpElems, & mesh_maxNips use material, only: phase_constitution, & @@ -758,8 +775,8 @@ use constitutive_dislotwin, only: constitutive_dislotwin_postResults, & constitutive_dislotwin_label use constitutive_nonlocal, only: constitutive_nonlocal_postResults, & constitutive_nonlocal_label -implicit none +implicit none !*** input variables integer(pInt), intent(in) :: ipc, & ! component-ID of current integration point ip, & ! current integration point diff --git a/code/constitutive_j2.f90 b/code/constitutive_j2.f90 index 33dca8f5b..fc770b43d 100644 --- a/code/constitutive_j2.f90 +++ b/code/constitutive_j2.f90 @@ -40,62 +40,79 @@ ! tausat 63e6 ! a 2.25 -MODULE constitutive_j2 +module constitutive_j2 -!*** Include other modules *** use prec, only: pReal,pInt - implicit none - - character (len=*), parameter :: constitutive_j2_label = 'j2' - integer(pInt), dimension(:), allocatable :: constitutive_j2_sizeDotState, & - constitutive_j2_sizeState, & - constitutive_j2_sizePostResults - integer(pInt), dimension(:,:), allocatable,target :: constitutive_j2_sizePostResult ! size of each post result output - character(len=64), dimension(:,:), allocatable,target :: constitutive_j2_output ! name of each post result output - integer(pInt), dimension(:), allocatable :: constitutive_j2_Noutput - real(pReal), dimension(:), allocatable :: constitutive_j2_C11 - real(pReal), dimension(:), allocatable :: constitutive_j2_C12 - real(pReal), dimension(:,:,:), allocatable :: constitutive_j2_Cslip_66 + implicit none + private + character (len=*), parameter, public :: constitutive_j2_label = 'j2' + + integer(pInt), dimension(:), allocatable, public :: & + constitutive_j2_sizeDotState, & + constitutive_j2_sizeState, & + constitutive_j2_sizePostResults + + integer(pInt), dimension(:,:), allocatable, target, public :: & + constitutive_j2_sizePostResult ! size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + constitutive_j2_output ! name of each post result output + + integer(pInt), dimension(:), allocatable, private :: & + constitutive_j2_Noutput + + real(pReal), dimension(:), allocatable, private ::& + constitutive_j2_C11, & + constitutive_j2_C12 + + real(pReal), dimension(:,:,:), allocatable, private :: & + constitutive_j2_Cslip_66 + !* Visco-plastic constitutive_j2 parameters - real(pReal), dimension(:), allocatable :: constitutive_j2_fTaylor - real(pReal), dimension(:), allocatable :: constitutive_j2_tau0 - real(pReal), dimension(:), allocatable :: constitutive_j2_gdot0 - real(pReal), dimension(:), allocatable :: constitutive_j2_n - real(pReal), dimension(:), allocatable :: constitutive_j2_h0 - real(pReal), dimension(:), allocatable :: constitutive_j2_tausat - real(pReal), dimension(:), allocatable :: constitutive_j2_a - real(pReal), dimension(:), allocatable :: constitutive_j2_aTolResistance + real(pReal), dimension(:), allocatable, private :: & + constitutive_j2_fTaylor, & + constitutive_j2_tau0, & + constitutive_j2_gdot0, & + constitutive_j2_n, & + constitutive_j2_h0, & + constitutive_j2_tausat, & + constitutive_j2_a, & + constitutive_j2_aTolResistance + + public :: constitutive_j2_init, & + constitutive_j2_stateInit, & + constitutive_j2_aTolState, & + constitutive_j2_homogenizedC, & + constitutive_j2_microstructure, & + constitutive_j2_LpAndItsTangent, & + constitutive_j2_dotState, & + constitutive_j2_dotTemperature, & + constitutive_j2_postResults +contains -CONTAINS -!**************************************** -!* - constitutive_j2_init -!* - constitutive_j2_stateInit -!* - constitutive_j2_homogenizedC -!* - constitutive_j2_microstructure -!* - constitutive_j2_LpAndItsTangent -!* - consistutive_j2_dotState -!* - consistutive_j2_postResults -!**************************************** - - -subroutine constitutive_j2_init(file) +subroutine constitutive_j2_init(myFile) !************************************** !* Module initialization * !************************************** use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) - use prec, only: pInt, pReal use math, only: math_Mandel3333to66, math_Voigt66to3333 use IO use material - use debug, only: debug_verbosity - integer(pInt), intent(in) :: file + use debug, only: debug_what, & + debug_constitutive, & + debug_levelBasic + + implicit none + integer(pInt), intent(in) :: myFile + integer(pInt), parameter :: maxNchunks = 7_pInt + integer(pInt), dimension(1_pInt+2_pInt*maxNchunks) :: positions - integer(pInt) section, maxNinstance, i,j,k, mySize - character(len=64) tag - character(len=1024) line + integer(pInt) :: section = 0_pInt, maxNinstance, i,j,k, mySize + character(len=64) :: tag + character(len=1024) :: line !$OMP CRITICAL (write2out) write(6,*) @@ -107,41 +124,56 @@ subroutine constitutive_j2_init(file) maxNinstance = int(count(phase_constitution == constitutive_j2_label),pInt) if (maxNinstance == 0_pInt) return - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a16,1x,i5)') '# instances:',maxNinstance write(6,*) !$OMP END CRITICAL (write2out) endif - allocate(constitutive_j2_sizeDotState(maxNinstance)) ; constitutive_j2_sizeDotState = 0_pInt - allocate(constitutive_j2_sizeState(maxNinstance)) ; constitutive_j2_sizeState = 0_pInt - allocate(constitutive_j2_sizePostResults(maxNinstance)); constitutive_j2_sizePostResults = 0_pInt - allocate(constitutive_j2_sizePostResult(maxval(phase_Noutput), maxNinstance)); constitutive_j2_sizePostResult = 0_pInt - allocate(constitutive_j2_output(maxval(phase_Noutput), maxNinstance)) ; constitutive_j2_output = '' - allocate(constitutive_j2_Noutput(maxNinstance)) ; constitutive_j2_Noutput = 0_pInt - allocate(constitutive_j2_C11(maxNinstance)) ; constitutive_j2_C11 = 0.0_pReal - allocate(constitutive_j2_C12(maxNinstance)) ; constitutive_j2_C12 = 0.0_pReal - allocate(constitutive_j2_Cslip_66(6,6,maxNinstance)) ; constitutive_j2_Cslip_66 = 0.0_pReal - allocate(constitutive_j2_fTaylor(maxNinstance)) ; constitutive_j2_fTaylor = 0.0_pReal - allocate(constitutive_j2_tau0(maxNinstance)) ; constitutive_j2_tau0 = 0.0_pReal - allocate(constitutive_j2_gdot0(maxNinstance)) ; constitutive_j2_gdot0 = 0.0_pReal - allocate(constitutive_j2_n(maxNinstance)) ; constitutive_j2_n = 0.0_pReal - allocate(constitutive_j2_h0(maxNinstance)) ; constitutive_j2_h0 = 0.0_pReal - allocate(constitutive_j2_tausat(maxNinstance)) ; constitutive_j2_tausat = 0.0_pReal - allocate(constitutive_j2_a(maxNinstance)) ; constitutive_j2_a = 0.0_pReal - allocate(constitutive_j2_aTolResistance(maxNinstance)) ; constitutive_j2_aTolResistance = 0.0_pReal + allocate(constitutive_j2_sizeDotState(maxNinstance)) + constitutive_j2_sizeDotState = 0_pInt + allocate(constitutive_j2_sizeState(maxNinstance)) + constitutive_j2_sizeState = 0_pInt + allocate(constitutive_j2_sizePostResults(maxNinstance)) + constitutive_j2_sizePostResults = 0_pInt + allocate(constitutive_j2_sizePostResult(maxval(phase_Noutput), maxNinstance)) + constitutive_j2_sizePostResult = 0_pInt + allocate(constitutive_j2_output(maxval(phase_Noutput), maxNinstance)) + constitutive_j2_output = '' + allocate(constitutive_j2_Noutput(maxNinstance)) + constitutive_j2_Noutput = 0_pInt + allocate(constitutive_j2_C11(maxNinstance)) + constitutive_j2_C11 = 0.0_pReal + allocate(constitutive_j2_C12(maxNinstance)) + constitutive_j2_C12 = 0.0_pReal + allocate(constitutive_j2_Cslip_66(6,6,maxNinstance)) + constitutive_j2_Cslip_66 = 0.0_pReal + allocate(constitutive_j2_fTaylor(maxNinstance)) + constitutive_j2_fTaylor = 0.0_pReal + allocate(constitutive_j2_tau0(maxNinstance)) + constitutive_j2_tau0 = 0.0_pReal + allocate(constitutive_j2_gdot0(maxNinstance)) + constitutive_j2_gdot0 = 0.0_pReal + allocate(constitutive_j2_n(maxNinstance)) + constitutive_j2_n = 0.0_pReal + allocate(constitutive_j2_h0(maxNinstance)) + constitutive_j2_h0 = 0.0_pReal + allocate(constitutive_j2_tausat(maxNinstance)) + constitutive_j2_tausat = 0.0_pReal + allocate(constitutive_j2_a(maxNinstance)) + constitutive_j2_a = 0.0_pReal + allocate(constitutive_j2_aTolResistance(maxNinstance)) + constitutive_j2_aTolResistance = 0.0_pReal - rewind(file) - line = '' - section = 0_pInt + rewind(myFile) do while (IO_lc(IO_getTag(line,'<','>')) /= 'phase') ! wind forward to - read(file,'(a1024)',END=100) line + read(myFile,'(a1024)',END=100) line enddo do ! read thru sections of phase part - read(file,'(a1024)',END=100) line + read(myFile,'(a1024)',END=100) line if (IO_isBlank(line)) cycle ! skip empty lines if (IO_getTag(line,'<','>') /= '') exit ! stop at next part if (IO_getTag(line,'[',']') /= '') then ! next section @@ -227,9 +259,7 @@ subroutine constitutive_j2_init(file) enddo - return - -endsubroutine +end subroutine constitutive_j2_init !********************************************************************* @@ -237,16 +267,13 @@ endsubroutine !********************************************************************* pure function constitutive_j2_stateInit(myInstance) - use prec, only: pReal,pInt - implicit none + implicit none + integer(pInt), intent(in) :: myInstance + real(pReal), dimension(1) :: constitutive_j2_stateInit - integer(pInt), intent(in) :: myInstance - real(pReal), dimension(1) :: constitutive_j2_stateInit - - constitutive_j2_stateInit = constitutive_j2_tau0(myInstance) + constitutive_j2_stateInit = constitutive_j2_tau0(myInstance) - return -endfunction +end function constitutive_j2_stateInit !********************************************************************* @@ -254,22 +281,17 @@ endfunction !********************************************************************* pure function constitutive_j2_aTolState(myInstance) -use prec, only: pReal, & - pInt -implicit none + implicit none + !*** input variables + integer(pInt), intent(in) :: myInstance ! number specifying the current instance of the constitution -!*** input variables -integer(pInt), intent(in) :: myInstance ! number specifying the current instance of the constitution - -!*** output variables -real(pReal), dimension(constitutive_j2_sizeState(myInstance)) :: & + !*** output variables + real(pReal), dimension(constitutive_j2_sizeState(myInstance)) :: & constitutive_j2_aTolState ! relevant state values for the current instance of this constitution -!*** local variables + constitutive_j2_aTolState = constitutive_j2_aTolResistance(myInstance) -constitutive_j2_aTolState = constitutive_j2_aTolResistance(myInstance) - -endfunction +end function constitutive_j2_aTolState function constitutive_j2_homogenizedC(state,ipc,ip,el) @@ -281,22 +303,20 @@ function constitutive_j2_homogenizedC(state,ipc,ip,el) !* - ip : current integration point * !* - el : current element * !********************************************************************* - use prec, only: pReal,pInt,p_vec + use prec, only: p_vec use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance + implicit none - integer(pInt), intent(in) :: ipc,ip,el - integer(pInt) matID + integer(pInt) :: matID real(pReal), dimension(6,6) :: constitutive_j2_homogenizedC type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state matID = phase_constitutionInstance(material_phase(ipc,ip,el)) constitutive_j2_homogenizedC = constitutive_j2_Cslip_66(1:6,1:6,matID) - return - -endfunction +end function constitutive_j2_homogenizedC subroutine constitutive_j2_microstructure(Temperature,state,ipc,ip,el) @@ -308,11 +328,11 @@ subroutine constitutive_j2_microstructure(Temperature,state,ipc,ip,el) !* - ip : current integration point * !* - el : current element * !********************************************************************* - use prec, only: pReal,pInt,p_vec + use prec, only: p_vec use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance + implicit none - !* Definition of variables integer(pInt) ipc,ip,el, matID real(pReal) Temperature @@ -320,7 +340,7 @@ subroutine constitutive_j2_microstructure(Temperature,state,ipc,ip,el) matID = phase_constitutionInstance(material_phase(ipc,ip,el)) -endsubroutine +end subroutine constitutive_j2_microstructure !**************************************************************** @@ -329,9 +349,7 @@ endsubroutine pure subroutine constitutive_j2_LpAndItsTangent(Lp, dLp_dTstar_99, Tstar_dev_v, Temperature, state, g, ip, el) !*** variables and functions from other modules ***! - use prec, only: pReal, & - pInt, & - p_vec + use prec, only: p_vec use math, only: math_mul6x6, & math_Mandel6to33, & math_Plain3333to99 @@ -342,7 +360,6 @@ pure subroutine constitutive_j2_LpAndItsTangent(Lp, dLp_dTstar_99, Tstar_dev_v, phase_constitutionInstance implicit none - !*** input variables ***! real(pReal), dimension(6), intent(in):: Tstar_dev_v ! deviatoric part of the 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal), intent(in):: Temperature @@ -397,9 +414,7 @@ pure subroutine constitutive_j2_LpAndItsTangent(Lp, dLp_dTstar_99, Tstar_dev_v, dLp_dTstar_99 = math_Plain3333to99(gamma_dot / constitutive_j2_fTaylor(matID) * dLp_dTstar_3333 / norm_Tstar_dev) end if - return - -endsubroutine +end subroutine constitutive_j2_LpAndItsTangent !**************************************************************** @@ -408,9 +423,7 @@ endsubroutine pure function constitutive_j2_dotState(Tstar_v, Temperature, state, g, ip, el) !*** variables and functions from other modules ***! - use prec, only: pReal, & - pInt, & - p_vec + use prec, only: p_vec use math, only: math_mul6x6 use mesh, only: mesh_NcpElems, & mesh_maxNips @@ -419,7 +432,6 @@ pure function constitutive_j2_dotState(Tstar_v, Temperature, state, g, ip, el) phase_constitutionInstance implicit none - !*** input variables ***! real(pReal), dimension(6), intent(in) :: Tstar_v ! 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal), intent(in) :: Temperature @@ -458,9 +470,7 @@ pure function constitutive_j2_dotState(Tstar_v, Temperature, state, g, ip, el) ! dotState constitutive_j2_dotState = hardening * gamma_dot - return - -endfunction +end function constitutive_j2_dotState !**************************************************************** @@ -469,11 +479,11 @@ endfunction pure function constitutive_j2_dotTemperature(Tstar_v, Temperature, state, g, ip, el) !*** variables and functions from other modules ***! - use prec, only: pReal,pInt,p_vec + use prec, only: p_vec use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains + implicit none - !*** input variables ***! real(pReal), dimension(6), intent(in) :: Tstar_v ! 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal), intent(in) :: Temperature @@ -488,8 +498,7 @@ pure function constitutive_j2_dotTemperature(Tstar_v, Temperature, state, g, ip, ! calculate dotTemperature constitutive_j2_dotTemperature = 0.0_pReal - return -endfunction +end function constitutive_j2_dotTemperature !********************************************************************* @@ -498,9 +507,7 @@ endfunction pure function constitutive_j2_postResults(Tstar_v, Temperature, dt, state, g, ip, el) !*** variables and functions from other modules ***! - use prec, only: pReal, & - pInt, & - p_vec + use prec, only: p_vec use math, only: math_mul6x6 use mesh, only: mesh_NcpElems, & mesh_maxNips @@ -510,7 +517,6 @@ pure function constitutive_j2_postResults(Tstar_v, Temperature, dt, state, g, ip phase_Noutput implicit none - !*** input variables ***! real(pReal), dimension(6), intent(in):: Tstar_v ! 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal), intent(in):: Temperature, & @@ -560,9 +566,7 @@ pure function constitutive_j2_postResults(Tstar_v, Temperature, dt, state, g, ip c = c + 1_pInt end select enddo - - return -endfunction +end function constitutive_j2_postResults -END MODULE +end module constitutive_j2 diff --git a/code/constitutive_nonlocal.f90 b/code/constitutive_nonlocal.f90 index 1acdf5334..442210abe 100644 --- a/code/constitutive_nonlocal.f90 +++ b/code/constitutive_nonlocal.f90 @@ -155,7 +155,9 @@ use IO, only: IO_lc, & IO_floatValue, & IO_intValue, & IO_error -use debug, only: debug_verbosity +use debug, only: debug_what, & + debug_constitutive, & + debug_levelBasic use mesh, only: mesh_NcpElems, & mesh_maxNips, & FE_maxNipNeighbors @@ -212,7 +214,7 @@ character(len=1024) line maxNinstance = int(count(phase_constitution == constitutive_nonlocal_label),pInt) if (maxNinstance == 0) return ! we don't have to do anything if there's no instance for this constitutive law -if (debug_verbosity > 0) then +if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a16,1x,i5)') '# instances:',maxNinstance !$OMP END CRITICAL (write2out) @@ -894,8 +896,10 @@ use math, only: math_Mandel33to6, & math_invert33, & math_transpose33, & pi -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & +use debug, only: debug_what, & + debug_constitutive, & + debug_levelBasic, & + debug_levelSelective, & debug_g, & debug_i, & debug_e @@ -1189,8 +1193,9 @@ state(g,ip,el)%p(12_pInt*ns+1:13_pInt*ns) = tauBack #ifndef _OPENMP - if (debug_verbosity > 6_pInt .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g)& - .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g)& + .or. .not. iand(debug_what(debug_constitutive),debug_levelSelective) /= 0_pInt)) then write(6,*) write(6,'(a,i8,1x,i2,1x,i1)') '<< CONST >> nonlocal_microstructure at el ip g',el,ip,g write(6,*) @@ -1212,8 +1217,10 @@ subroutine constitutive_nonlocal_kinetics(v, tau, c, Temperature, state, g, ip, use prec, only: pReal, & pInt, & p_vec -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & +use debug, only: debug_what, & + debug_constitutive, & + debug_levelBasic, & + debug_levelSelective, & debug_g, & debug_i, & debug_e @@ -1349,7 +1356,9 @@ endif #ifndef _OPENMP - if (debug_verbosity > 6 .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g) .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g)& + .or. .not. iand(debug_what(debug_constitutive),debug_levelSelective) /= 0_pInt)) then write(6,*) write(6,'(a,i8,1x,i2,1x,i1)') '<< CONST >> nonlocal_kinetics at el ip g',el,ip,g write(6,*) @@ -1372,8 +1381,10 @@ use prec, only: pReal, & p_vec use math, only: math_Plain3333to99, & math_mul6x6 -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & +use debug, only: debug_what, & + debug_constitutive, & + debug_levelBasic, & + debug_levelSelective, & debug_g, & debug_i, & debug_e @@ -1491,8 +1502,9 @@ dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) #ifndef _OPENMP - if (debug_verbosity > 6_pInt .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g)& - .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g)& + .or. .not. iand(debug_what(debug_constitutive),debug_levelSelective) /= 0_pInt )) then write(6,*) write(6,'(a,i8,1x,i2,1x,i1)') '<< CONST >> nonlocal_LpandItsTangent at el ip g ',el,ip,g write(6,*) @@ -1516,8 +1528,10 @@ use prec, only: pReal, & DAMASK_NaN use numerics, only: numerics_integrationMode use IO, only: IO_error -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & +use debug, only: debug_what, & + debug_constitutive, & + debug_levelBasic, & + debug_levelSelective, & debug_g, & debug_i, & debug_e @@ -1628,8 +1642,9 @@ logical considerEnteringFlux, & considerLeavingFlux #ifndef _OPENMP - if (debug_verbosity > 6_pInt .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g) & - .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g)& + .or. .not. iand(debug_what(debug_constitutive),debug_levelSelective) /= 0_pInt)) then write(6,*) write(6,'(a,i8,1x,i2,1x,i1)') '<< CONST >> nonlocal_dotState at el ip g ',el,ip,g write(6,*) @@ -1686,8 +1701,9 @@ forall (s = 1_pInt:ns, t = 1_pInt:4_pInt, rhoSgl(s,t+4_pInt) * v(s,t) < 0.0_pRea gdot(s,t) = gdot(s,t) + abs(rhoSgl(s,t+4)) * constitutive_nonlocal_burgers(s,myInstance) * v(s,t) #ifndef _OPENMP - if (debug_verbosity > 6_pInt .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g) & - .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g)& + .or. .not. iand(debug_what(debug_constitutive),debug_levelSelective) /= 0_pInt )) then write(6,'(a,/,10(12x,12(e12.5,1x),/))') '<< CONST >> rho / 1/m^2', rhoSgl, rhoDip write(6,'(a,/,4(12x,12(e12.5,1x),/))') '<< CONST >> gdot / 1/s',gdot endif @@ -1700,7 +1716,7 @@ forall (s = 1_pInt:ns, t = 1_pInt:4_pInt, rhoSgl(s,t+4_pInt) * v(s,t) < 0.0_pRea if (any(abs(gdot) > 0.0_pReal .and. 2.0_pReal * abs(v) * timestep > mesh_ipVolume(ip,el) / maxval(mesh_ipArea(:,ip,el)))) then ! safety factor 2.0 (we use the reference volume and are for simplicity here) #ifndef _OPENMP - if (debug_verbosity > 6_pInt) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt) then write(6,'(a,i5,a,i2)') '<< CONST >> CFL condition not fullfilled at el ',el,' ip ',ip write(6,'(a,e10.3,a,e10.3)') '<< CONST >> velocity is at ',maxval(abs(v)),' at a timestep of ',timestep write(6,'(a)') '<< CONST >> enforcing cutback !!!' @@ -1966,7 +1982,7 @@ rhoDot = rhoDotFlux & if ( any(rhoSgl(1:ns,1:4) + rhoDot(1:ns,1:4) * timestep < - constitutive_nonlocal_aTolRho(myInstance)) & .or. any(rhoDip(1:ns,1:2) + rhoDot(1:ns,9:10) * timestep < - constitutive_nonlocal_aTolRho(myInstance))) then #ifndef _OPENMP - if (debug_verbosity > 6_pInt) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt) then write(6,'(a,i5,a,i2)') '<< CONST >> evolution rate leads to negative density at el ',el,' ip ',ip write(6,'(a)') '<< CONST >> enforcing cutback !!!' endif @@ -1980,8 +1996,9 @@ endif #ifndef _OPENMP - if (debug_verbosity > 6_pInt .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g)& - .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip .and. debug_g == g)& + .or. .not. iand(debug_what(debug_constitutive),debug_levelSelective) /= 0_pInt )) then write(6,'(a,/,8(12x,12(e12.5,1x),/))') '<< CONST >> dislocation remobilization', rhoDotRemobilization(1:ns,1:8) * timestep write(6,'(a,/,4(12x,12(e12.5,1x),/))') '<< CONST >> dislocation multiplication', rhoDotMultiplication(1:ns,1:4) * timestep write(6,'(a,/,8(12x,12(e12.5,1x),/))') '<< CONST >> dislocation flux', rhoDotFlux(1:ns,1:8) * timestep diff --git a/code/constitutive_phenopowerlaw.f90 b/code/constitutive_phenopowerlaw.f90 index 697df4dc0..09ca090d6 100644 --- a/code/constitutive_phenopowerlaw.f90 +++ b/code/constitutive_phenopowerlaw.f90 @@ -70,92 +70,95 @@ !interaction_twintwin 1 1 1 1 1 1 1 1 10 10 10 10 10 10 10 10 10 10 10 10 !relevantResistance 1 -MODULE constitutive_phenopowerlaw +module constitutive_phenopowerlaw -!*** Include other modules *** use prec, only: pReal,pInt + implicit none - - character (len=*), parameter :: constitutive_phenopowerlaw_label = 'phenopowerlaw' + character (len=*), parameter :: & + constitutive_phenopowerlaw_label = 'phenopowerlaw' - integer(pInt), dimension(:), allocatable :: constitutive_phenopowerlaw_sizeDotState, & - constitutive_phenopowerlaw_sizeState, & - constitutive_phenopowerlaw_sizePostResults ! cumulative size of post results - integer(pInt), dimension(:,:), allocatable,target :: constitutive_phenopowerlaw_sizePostResult ! size of each post result output - character(len=64), dimension(:,:), allocatable,target :: constitutive_phenopowerlaw_output ! name of each post result output - integer(pInt), dimension(:), allocatable :: constitutive_phenopowerlaw_Noutput ! number of outputs per instance of this constitution + integer(pInt), dimension(:), allocatable :: & + constitutive_phenopowerlaw_sizeDotState, & + constitutive_phenopowerlaw_sizeState, & + constitutive_phenopowerlaw_sizePostResults, & ! cumulative size of post results + constitutive_phenopowerlaw_Noutput, & ! number of outputs per instance of this constitution + constitutive_phenopowerlaw_totalNslip, & ! no. of slip system used in simulation + constitutive_phenopowerlaw_totalNtwin, & ! no. of twin system used in simulation + constitutive_phenopowerlaw_structure - character(len=32), dimension(:), allocatable :: constitutive_phenopowerlaw_structureName - integer(pInt), dimension(:), allocatable :: constitutive_phenopowerlaw_structure - integer(pInt), dimension(:,:), allocatable :: constitutive_phenopowerlaw_Nslip ! active number of slip systems per family - integer(pInt), dimension(:,:), allocatable :: constitutive_phenopowerlaw_Ntwin ! active number of twin systems per family - integer(pInt), dimension(:), allocatable :: constitutive_phenopowerlaw_totalNslip ! no. of slip system used in simulation - integer(pInt), dimension(:), allocatable :: constitutive_phenopowerlaw_totalNtwin ! no. of twin system used in simulation + integer(pInt), dimension(:,:), allocatable,target :: & + constitutive_phenopowerlaw_sizePostResult ! size of each post result output - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_CoverA - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_C11 - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_C12 - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_C13 - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_C33 - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_C44 - real(pReal), dimension(:,:,:), allocatable :: constitutive_phenopowerlaw_Cslip_66 -!* Visco-plastic constitutive_phenomenological parameters - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_gdot0_slip - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_n_slip - real(pReal), dimension(:,:), allocatable :: constitutive_phenopowerlaw_tau0_slip - real(pReal), dimension(:,:), allocatable :: constitutive_phenopowerlaw_tausat_slip - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_gdot0_twin - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_n_twin - real(pReal), dimension(:,:), allocatable :: constitutive_phenopowerlaw_tau0_twin + integer(pInt), dimension(:,:), allocatable :: & + constitutive_phenopowerlaw_Nslip, & ! active number of slip systems per family + constitutive_phenopowerlaw_Ntwin ! active number of twin systems per family - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_spr - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_twinB - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_twinC - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_twinD - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_twinE + character(len=64), dimension(:,:), allocatable,target :: & + constitutive_phenopowerlaw_output ! name of each post result output - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_h0_slipslip - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_h0_sliptwin - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_h0_twinslip - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_h0_twintwin + character(len=32), dimension(:), allocatable :: & + constitutive_phenopowerlaw_structureName - real(pReal), dimension(:,:), allocatable :: constitutive_phenopowerlaw_interaction_slipslip - real(pReal), dimension(:,:), allocatable :: constitutive_phenopowerlaw_interaction_sliptwin - real(pReal), dimension(:,:), allocatable :: constitutive_phenopowerlaw_interaction_twinslip - real(pReal), dimension(:,:), allocatable :: constitutive_phenopowerlaw_interaction_twintwin + real(pReal), dimension(:), allocatable :: & + constitutive_phenopowerlaw_CoverA, & + constitutive_phenopowerlaw_C11, & + constitutive_phenopowerlaw_C12, & + constitutive_phenopowerlaw_C13, & + constitutive_phenopowerlaw_C33, & + constitutive_phenopowerlaw_C44, & + constitutive_phenopowerlaw_gdot0_slip, & + constitutive_phenopowerlaw_n_slip, & + constitutive_phenopowerlaw_n_twin, & + constitutive_phenopowerlaw_gdot0_twin - real(pReal), dimension(:,:,:), allocatable :: constitutive_phenopowerlaw_hardeningMatrix_slipslip - real(pReal), dimension(:,:,:), allocatable :: constitutive_phenopowerlaw_hardeningMatrix_sliptwin - real(pReal), dimension(:,:,:), allocatable :: constitutive_phenopowerlaw_hardeningMatrix_twinslip - real(pReal), dimension(:,:,:), allocatable :: constitutive_phenopowerlaw_hardeningMatrix_twintwin + real(pReal), dimension(:,:), allocatable :: & + constitutive_phenopowerlaw_tau0_slip, & + constitutive_phenopowerlaw_tausat_slip, & + constitutive_phenopowerlaw_tau0_twin + + real(pReal), dimension(:), allocatable :: & + constitutive_phenopowerlaw_spr, & + constitutive_phenopowerlaw_twinB, & + constitutive_phenopowerlaw_twinC, & + constitutive_phenopowerlaw_twinD, & + constitutive_phenopowerlaw_twinE, & + constitutive_phenopowerlaw_h0_slipslip, & + constitutive_phenopowerlaw_h0_sliptwin, & + constitutive_phenopowerlaw_h0_twinslip, & + constitutive_phenopowerlaw_h0_twintwin, & + constitutive_phenopowerlaw_a_slip, & + constitutive_phenopowerlaw_aTolResistance + + real(pReal), dimension(:,:), allocatable :: & + constitutive_phenopowerlaw_interaction_slipslip, & + constitutive_phenopowerlaw_interaction_sliptwin, & + constitutive_phenopowerlaw_interaction_twinslip, & + constitutive_phenopowerlaw_interaction_twintwin + + real(pReal), dimension(:,:,:), allocatable :: & + constitutive_phenopowerlaw_hardeningMatrix_slipslip, & + constitutive_phenopowerlaw_hardeningMatrix_sliptwin, & + constitutive_phenopowerlaw_hardeningMatrix_twinslip, & + constitutive_phenopowerlaw_hardeningMatrix_twintwin, & + constitutive_phenopowerlaw_Cslip_66 + + public :: constitutive_phenopowerlaw_init - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_a_slip - - real(pReal), dimension(:), allocatable :: constitutive_phenopowerlaw_aTolResistance - -CONTAINS -!**************************************** -!* - constitutive_init -!* - constitutive_stateInit -!* - constitutive_homogenizedC -!* - constitutive_microstructure -!* - constitutive_LpAndItsTangent -!* - consistutive_dotState -!* - consistutive_postResults -!**************************************** - +contains subroutine constitutive_phenopowerlaw_init(myFile) !************************************** !* Module initialization * !************************************** use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) - use prec, only: pInt, pReal - use math, only: math_Mandel3333to66, math_Voigt66to3333 + use math, only: math_Mandel3333to66, & + math_Voigt66to3333 use IO use material - use debug, only: debug_verbosity - + use debug, only: debug_what,& + debug_constitutive,& + debug_levelBasic use lattice, only: lattice_initializeStructure, lattice_symmetryType, & lattice_maxNslipFamily, lattice_maxNtwinFamily, & lattice_maxNinteraction, lattice_NslipSystem, lattice_NtwinSystem, & @@ -164,13 +167,14 @@ subroutine constitutive_phenopowerlaw_init(myFile) lattice_interactionTwinSlip, & lattice_interactionTwinTwin + implicit none integer(pInt), intent(in) :: myFile integer(pInt), parameter :: maxNchunks = lattice_maxNinteraction + 1_pInt integer(pInt), dimension(1+2*maxNchunks) :: positions integer(pInt) section, maxNinstance, i,j,k, f,o, & mySize, myStructure, index_myFamily, index_otherFamily - character(len=64) tag - character(len=1024) line + character(len=64) :: tag + character(len=1024) :: line !$OMP CRITICAL (write2out) write(6,*) @@ -182,79 +186,96 @@ subroutine constitutive_phenopowerlaw_init(myFile) maxNinstance = int(count(phase_constitution == constitutive_phenopowerlaw_label),pInt) if (maxNinstance == 0) return - if (debug_verbosity > 0) then + if (iand(debug_what(debug_constitutive),debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a16,1x,i5)') '# instances:',maxNinstance write(6,*) !$OMP END CRITICAL (write2out) endif - allocate(constitutive_phenopowerlaw_sizeDotState(maxNinstance)) ; constitutive_phenopowerlaw_sizeDotState = 0_pInt - allocate(constitutive_phenopowerlaw_sizeState(maxNinstance)) ; constitutive_phenopowerlaw_sizeState = 0_pInt - allocate(constitutive_phenopowerlaw_sizePostResults(maxNinstance)); constitutive_phenopowerlaw_sizePostResults = 0_pInt - allocate(constitutive_phenopowerlaw_sizePostResult(maxval(phase_Noutput), & - maxNinstance)) ; constitutive_phenopowerlaw_sizePostResult = 0_pInt - allocate(constitutive_phenopowerlaw_output(maxval(phase_Noutput), & - maxNinstance)) ; constitutive_phenopowerlaw_output = '' - allocate(constitutive_phenopowerlaw_Noutput(maxNinstance)) ; constitutive_phenopowerlaw_Noutput = 0_pInt - - allocate(constitutive_phenopowerlaw_structureName(maxNinstance)) ; constitutive_phenopowerlaw_structureName = '' - allocate(constitutive_phenopowerlaw_structure(maxNinstance)) ; constitutive_phenopowerlaw_structure = 0_pInt - allocate(constitutive_phenopowerlaw_Nslip(lattice_maxNslipFamily,& - maxNinstance)) ; constitutive_phenopowerlaw_Nslip = 0_pInt - allocate(constitutive_phenopowerlaw_Ntwin(lattice_maxNtwinFamily,& - maxNinstance)) ; constitutive_phenopowerlaw_Ntwin = 0_pInt - - allocate(constitutive_phenopowerlaw_totalNslip(maxNinstance)) ; constitutive_phenopowerlaw_totalNslip = 0_pInt !no. of slip system used in simulation (YJ.RO) - allocate(constitutive_phenopowerlaw_totalNtwin(maxNinstance)) ; constitutive_phenopowerlaw_totalNtwin = 0_pInt !no. of twin system used in simulation (YJ.RO) - - allocate(constitutive_phenopowerlaw_CoverA(maxNinstance)) ; constitutive_phenopowerlaw_CoverA = 0.0_pReal - allocate(constitutive_phenopowerlaw_C11(maxNinstance)) ; constitutive_phenopowerlaw_C11 = 0.0_pReal - allocate(constitutive_phenopowerlaw_C12(maxNinstance)) ; constitutive_phenopowerlaw_C12 = 0.0_pReal - allocate(constitutive_phenopowerlaw_C13(maxNinstance)) ; constitutive_phenopowerlaw_C13 = 0.0_pReal - allocate(constitutive_phenopowerlaw_C33(maxNinstance)) ; constitutive_phenopowerlaw_C33 = 0.0_pReal - allocate(constitutive_phenopowerlaw_C44(maxNinstance)) ; constitutive_phenopowerlaw_C44 = 0.0_pReal - allocate(constitutive_phenopowerlaw_Cslip_66(6,6,maxNinstance)) ; constitutive_phenopowerlaw_Cslip_66 = 0.0_pReal - - allocate(constitutive_phenopowerlaw_gdot0_slip(maxNinstance)) ; constitutive_phenopowerlaw_gdot0_slip = 0.0_pReal - allocate(constitutive_phenopowerlaw_n_slip(maxNinstance)) ; constitutive_phenopowerlaw_n_slip = 0.0_pReal - allocate(constitutive_phenopowerlaw_tau0_slip(lattice_maxNslipFamily,& - maxNinstance)) ; constitutive_phenopowerlaw_tau0_slip = 0.0_pReal - allocate(constitutive_phenopowerlaw_tausat_slip(lattice_maxNslipFamily,& - maxNinstance)) ; constitutive_phenopowerlaw_tausat_slip = 0.0_pReal - - allocate(constitutive_phenopowerlaw_gdot0_twin(maxNinstance)) ; constitutive_phenopowerlaw_gdot0_twin = 0.0_pReal - allocate(constitutive_phenopowerlaw_n_twin(maxNinstance)) ; constitutive_phenopowerlaw_n_twin = 0.0_pReal - allocate(constitutive_phenopowerlaw_tau0_twin(lattice_maxNtwinFamily,& - maxNinstance)) ; constitutive_phenopowerlaw_tau0_twin = 0.0_pReal - - allocate(constitutive_phenopowerlaw_spr(maxNinstance)) ; constitutive_phenopowerlaw_spr = 0.0_pReal - allocate(constitutive_phenopowerlaw_twinB(maxNinstance)) ; constitutive_phenopowerlaw_twinB = 0.0_pReal - allocate(constitutive_phenopowerlaw_twinC(maxNinstance)) ; constitutive_phenopowerlaw_twinC = 0.0_pReal - allocate(constitutive_phenopowerlaw_twinD(maxNinstance)) ; constitutive_phenopowerlaw_twinD = 0.0_pReal - allocate(constitutive_phenopowerlaw_twinE(maxNinstance)) ; constitutive_phenopowerlaw_twinE = 0.0_pReal - - allocate(constitutive_phenopowerlaw_h0_slipslip(maxNinstance)) ; constitutive_phenopowerlaw_h0_slipslip = 0.0_pReal - allocate(constitutive_phenopowerlaw_h0_sliptwin(maxNinstance)) ; constitutive_phenopowerlaw_h0_sliptwin = 0.0_pReal - allocate(constitutive_phenopowerlaw_h0_twinslip(maxNinstance)) ; constitutive_phenopowerlaw_h0_twinslip = 0.0_pReal - allocate(constitutive_phenopowerlaw_h0_twintwin(maxNinstance)) ; constitutive_phenopowerlaw_h0_twintwin = 0.0_pReal - + allocate(constitutive_phenopowerlaw_sizeDotState(maxNinstance)) + constitutive_phenopowerlaw_sizeDotState = 0_pInt + allocate(constitutive_phenopowerlaw_sizeState(maxNinstance)) + constitutive_phenopowerlaw_sizeState = 0_pInt + allocate(constitutive_phenopowerlaw_sizePostResults(maxNinstance)) + constitutive_phenopowerlaw_sizePostResults = 0_pInt + allocate(constitutive_phenopowerlaw_sizePostResult(maxval(phase_Noutput),maxNinstance)) + constitutive_phenopowerlaw_sizePostResult = 0_pInt + allocate(constitutive_phenopowerlaw_output(maxval(phase_Noutput),maxNinstance)) + constitutive_phenopowerlaw_output = '' + allocate(constitutive_phenopowerlaw_Noutput(maxNinstance)) + constitutive_phenopowerlaw_Noutput = 0_pInt + allocate(constitutive_phenopowerlaw_structureName(maxNinstance)) + constitutive_phenopowerlaw_structureName = '' + allocate(constitutive_phenopowerlaw_structure(maxNinstance)) + constitutive_phenopowerlaw_structure = 0_pInt + allocate(constitutive_phenopowerlaw_Nslip(lattice_maxNslipFamily,maxNinstance)) + constitutive_phenopowerlaw_Nslip = 0_pInt + allocate(constitutive_phenopowerlaw_Ntwin(lattice_maxNtwinFamily,maxNinstance)) + constitutive_phenopowerlaw_Ntwin = 0_pInt + allocate(constitutive_phenopowerlaw_totalNslip(maxNinstance)) + constitutive_phenopowerlaw_totalNslip = 0_pInt + allocate(constitutive_phenopowerlaw_totalNtwin(maxNinstance)) + constitutive_phenopowerlaw_totalNtwin = 0_pInt + allocate(constitutive_phenopowerlaw_CoverA(maxNinstance)) + constitutive_phenopowerlaw_CoverA = 0.0_pReal + allocate(constitutive_phenopowerlaw_C11(maxNinstance)) + constitutive_phenopowerlaw_C11 = 0.0_pReal + allocate(constitutive_phenopowerlaw_C12(maxNinstance)) + constitutive_phenopowerlaw_C12 = 0.0_pReal + allocate(constitutive_phenopowerlaw_C13(maxNinstance)) + constitutive_phenopowerlaw_C13 = 0.0_pReal + allocate(constitutive_phenopowerlaw_C33(maxNinstance)) + constitutive_phenopowerlaw_C33 = 0.0_pReal + allocate(constitutive_phenopowerlaw_C44(maxNinstance)) + constitutive_phenopowerlaw_C44 = 0.0_pReal + allocate(constitutive_phenopowerlaw_Cslip_66(6,6,maxNinstance)) + constitutive_phenopowerlaw_Cslip_66 = 0.0_pReal + allocate(constitutive_phenopowerlaw_gdot0_slip(maxNinstance)) + constitutive_phenopowerlaw_gdot0_slip = 0.0_pReal + allocate(constitutive_phenopowerlaw_n_slip(maxNinstance)) + constitutive_phenopowerlaw_n_slip = 0.0_pReal + allocate(constitutive_phenopowerlaw_tau0_slip(lattice_maxNslipFamily,maxNinstance)) + constitutive_phenopowerlaw_tau0_slip = 0.0_pReal + allocate(constitutive_phenopowerlaw_tausat_slip(lattice_maxNslipFamily,maxNinstance)) + constitutive_phenopowerlaw_tausat_slip = 0.0_pReal + allocate(constitutive_phenopowerlaw_gdot0_twin(maxNinstance)) + constitutive_phenopowerlaw_gdot0_twin = 0.0_pReal + allocate(constitutive_phenopowerlaw_n_twin(maxNinstance)) + constitutive_phenopowerlaw_n_twin = 0.0_pReal + allocate(constitutive_phenopowerlaw_tau0_twin(lattice_maxNtwinFamily,maxNinstance)) + constitutive_phenopowerlaw_tau0_twin = 0.0_pReal + allocate(constitutive_phenopowerlaw_spr(maxNinstance)) + constitutive_phenopowerlaw_spr = 0.0_pReal + allocate(constitutive_phenopowerlaw_twinB(maxNinstance)) + constitutive_phenopowerlaw_twinB = 0.0_pReal + allocate(constitutive_phenopowerlaw_twinC(maxNinstance)) + constitutive_phenopowerlaw_twinC = 0.0_pReal + allocate(constitutive_phenopowerlaw_twinD(maxNinstance)) + constitutive_phenopowerlaw_twinD = 0.0_pReal + allocate(constitutive_phenopowerlaw_twinE(maxNinstance)) + constitutive_phenopowerlaw_twinE = 0.0_pReal + allocate(constitutive_phenopowerlaw_h0_slipslip(maxNinstance)) + constitutive_phenopowerlaw_h0_slipslip = 0.0_pReal + allocate(constitutive_phenopowerlaw_h0_sliptwin(maxNinstance)) + constitutive_phenopowerlaw_h0_sliptwin = 0.0_pReal + allocate(constitutive_phenopowerlaw_h0_twinslip(maxNinstance)) + constitutive_phenopowerlaw_h0_twinslip = 0.0_pReal + allocate(constitutive_phenopowerlaw_h0_twintwin(maxNinstance)) + constitutive_phenopowerlaw_h0_twintwin = 0.0_pReal allocate(constitutive_phenopowerlaw_interaction_slipslip(lattice_maxNinteraction,maxNinstance)) + constitutive_phenopowerlaw_interaction_slipslip = 0.0_pReal allocate(constitutive_phenopowerlaw_interaction_sliptwin(lattice_maxNinteraction,maxNinstance)) + constitutive_phenopowerlaw_interaction_sliptwin = 0.0_pReal allocate(constitutive_phenopowerlaw_interaction_twinslip(lattice_maxNinteraction,maxNinstance)) + constitutive_phenopowerlaw_interaction_twinslip = 0.0_pReal allocate(constitutive_phenopowerlaw_interaction_twintwin(lattice_maxNinteraction,maxNinstance)) - constitutive_phenopowerlaw_interaction_slipslip = 0.0_pReal - constitutive_phenopowerlaw_interaction_sliptwin = 0.0_pReal - constitutive_phenopowerlaw_interaction_twinslip = 0.0_pReal - constitutive_phenopowerlaw_interaction_twintwin = 0.0_pReal - + constitutive_phenopowerlaw_interaction_twintwin = 0.0_pReal allocate(constitutive_phenopowerlaw_a_slip(maxNinstance)) - constitutive_phenopowerlaw_a_slip = 0.0_pReal - + constitutive_phenopowerlaw_a_slip = 0.0_pReal allocate(constitutive_phenopowerlaw_aTolResistance(maxNinstance)) - constitutive_phenopowerlaw_aTolResistance = 0.0_pReal + constitutive_phenopowerlaw_aTolResistance = 0.0_pReal rewind(myFile) - line = '' section = 0_pInt do while (IO_lc(IO_getTag(line,'<','>')) /= 'phase') ! wind forward to @@ -525,20 +546,18 @@ subroutine constitutive_phenopowerlaw_init(myFile) return -endsubroutine +end subroutine constitutive_phenopowerlaw_init function constitutive_phenopowerlaw_stateInit(myInstance) !********************************************************************* !* initial microstructural state * !********************************************************************* - use prec, only: pReal,pInt use lattice, only: lattice_maxNslipFamily, lattice_maxNtwinFamily + implicit none - -!* Definition of variables integer(pInt), intent(in) :: myInstance - integer(pInt) i + integer(pInt) :: i real(pReal), dimension(constitutive_phenopowerlaw_sizeDotState(myInstance)) :: constitutive_phenopowerlaw_stateInit constitutive_phenopowerlaw_stateInit = 0.0_pReal @@ -559,7 +578,7 @@ function constitutive_phenopowerlaw_stateInit(myInstance) enddo return -endfunction +end function constitutive_phenopowerlaw_stateInit !********************************************************************* @@ -567,10 +586,7 @@ endfunction !********************************************************************* pure function constitutive_phenopowerlaw_aTolState(myInstance) -use prec, only: pReal, & - pInt implicit none - !*** input variables integer(pInt), intent(in) :: myInstance ! number specifying the current instance of the constitution @@ -582,7 +598,7 @@ real(pReal), dimension(constitutive_phenopowerlaw_sizeState(myInstance)) :: & constitutive_phenopowerlaw_aTolState = constitutive_phenopowerlaw_aTolResistance(myInstance) -endfunction +end function constitutive_phenopowerlaw_aTolState function constitutive_phenopowerlaw_homogenizedC(state,ipc,ip,el) @@ -594,12 +610,11 @@ function constitutive_phenopowerlaw_homogenizedC(state,ipc,ip,el) !* - ip : current integration point * !* - el : current element * !********************************************************************* - use prec, only: pReal,pInt,p_vec + use prec, only: p_vec use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance + implicit none - -!* Definition of variables integer(pInt), intent(in) :: ipc,ip,el integer(pInt) matID real(pReal), dimension(6,6) :: constitutive_phenopowerlaw_homogenizedC @@ -610,7 +625,7 @@ function constitutive_phenopowerlaw_homogenizedC(state,ipc,ip,el) return -endfunction +end function constitutive_phenopowerlaw_homogenizedC subroutine constitutive_phenopowerlaw_microstructure(Temperature,state,ipc,ip,el) @@ -625,16 +640,15 @@ subroutine constitutive_phenopowerlaw_microstructure(Temperature,state,ipc,ip,el use prec, only: pReal,pInt,p_vec use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance + implicit none - -!* Definition of variables integer(pInt) ipc,ip,el, matID real(pReal) Temperature type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state matID = phase_constitutionInstance(material_phase(ipc,ip,el)) -endsubroutine +end subroutine constitutive_phenopowerlaw_microstructure subroutine constitutive_phenopowerlaw_LpAndItsTangent(Lp,dLp_dTstar,Tstar_v,Temperature,state,ipc,ip,el) @@ -649,7 +663,7 @@ subroutine constitutive_phenopowerlaw_LpAndItsTangent(Lp,dLp_dTstar,Tstar_v,Temp !* - Lp : plastic velocity gradient * !* - dLp_dTstar : derivative of Lp (4th-rank tensor) * !********************************************************************* - use prec, only: pReal,pInt,p_vec + use prec, only: p_vec use math, only: math_Plain3333to99 use lattice, only: lattice_Sslip,lattice_Sslip_v,lattice_Stwin,lattice_Stwin_v, lattice_maxNslipFamily, lattice_maxNtwinFamily, & lattice_NslipSystem,lattice_NtwinSystem @@ -657,8 +671,6 @@ subroutine constitutive_phenopowerlaw_LpAndItsTangent(Lp,dLp_dTstar,Tstar_v,Temp use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance implicit none - -!* Definition of variables integer(pInt) ipc,ip,el integer(pInt) matID,nSlip,nTwin,f,i,j,k,l,m,n, structID,index_Gamma,index_F,index_myFamily real(pReal) Temperature @@ -741,7 +753,7 @@ subroutine constitutive_phenopowerlaw_LpAndItsTangent(Lp,dLp_dTstar,Tstar_v,Temp dLp_dTstar = math_Plain3333to99(dLp_dTstar3333) return -endsubroutine +end subroutine constitutive_phenopowerlaw_LpAndItsTangent function constitutive_phenopowerlaw_dotState(Tstar_v,Temperature,state,ipc,ip,el) @@ -755,14 +767,13 @@ function constitutive_phenopowerlaw_dotState(Tstar_v,Temperature,state,ipc,ip,el !* OUTPUT: * !* - constitutive_dotState : evolution of state variable * !********************************************************************* - use prec, only: pReal,pInt,p_vec + use prec, only: p_vec use lattice, only: lattice_Sslip_v, lattice_Stwin_v, lattice_maxNslipFamily, lattice_maxNtwinFamily, & lattice_NslipSystem,lattice_NtwinSystem,lattice_shearTwin use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance + implicit none - -!* Definition of variables integer(pInt) ipc,ip,el integer(pInt) matID,nSlip,nTwin,f,i,j, structID,index_Gamma,index_F,index_myFamily real(pReal) Temperature,c_slipslip,c_sliptwin,c_twinslip,c_twintwin, ssat_offset @@ -864,9 +875,7 @@ function constitutive_phenopowerlaw_dotState(Tstar_v,Temperature,state,ipc,ip,el enddo enddo - return - -endfunction +end function constitutive_phenopowerlaw_dotState !**************************************************************** @@ -878,8 +887,8 @@ pure function constitutive_phenopowerlaw_dotTemperature(Tstar_v,Temperature,stat use prec, only: pReal,pInt,p_vec use mesh, only: mesh_NcpElems, mesh_maxNips use material, only: homogenization_maxNgrains + implicit none - !*** input variables ***! real(pReal), dimension(6), intent(in) :: Tstar_v ! 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal), intent(in) :: Temperature @@ -894,8 +903,7 @@ pure function constitutive_phenopowerlaw_dotTemperature(Tstar_v,Temperature,stat ! calculate dotTemperature constitutive_phenopowerlaw_dotTemperature = 0.0_pReal - return -endfunction +end function constitutive_phenopowerlaw_dotTemperature @@ -914,9 +922,8 @@ pure function constitutive_phenopowerlaw_postResults(Tstar_v,Temperature,dt,stat lattice_NslipSystem,lattice_NtwinSystem use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase,phase_constitutionInstance,phase_Noutput + implicit none - -!* Definition of variables integer(pInt), intent(in) :: ipc,ip,el real(pReal), intent(in) :: dt,Temperature real(pReal), dimension(6), intent(in) :: Tstar_v @@ -1005,9 +1012,7 @@ pure function constitutive_phenopowerlaw_postResults(Tstar_v,Temperature,dt,stat end select enddo - - return -endfunction +end function constitutive_phenopowerlaw_postResults -END MODULE +end module constitutive_phenopowerlaw diff --git a/code/constitutive_titanmod.f90 b/code/constitutive_titanmod.f90 index a1990fff6..a7ddef528 100644 --- a/code/constitutive_titanmod.f90 +++ b/code/constitutive_titanmod.f90 @@ -48,143 +48,175 @@ MODULE constitutive_titanmod !* Include other modules use prec, only: pReal,pInt + implicit none - !* Lists of states and physical parameters -character(len=*), parameter :: constitutive_titanmod_label = 'titanmod' -character(len=18), dimension(3), parameter:: constitutive_titanmod_listBasicSlipStates = (/'rho_edge ', & - 'rho_screw ', & - 'shear_system'/) +character(len=*), parameter :: & + constitutive_titanmod_label = 'titanmod' +character(len=18), dimension(3), parameter :: & + constitutive_titanmod_listBasicSlipStates = (/'rho_edge ', & + 'rho_screw ', & + 'shear_system'/) -character(len=18), dimension(1), parameter:: constitutive_titanmod_listBasicTwinStates = (/'gdot_twin'/) +character(len=18), dimension(1), parameter :: & + constitutive_titanmod_listBasicTwinStates = (/'gdot_twin'/) -character(len=19), dimension(11), parameter:: constitutive_titanmod_listDependentSlipStates =(/'segment_edge ', & - 'segment_screw ', & - 'resistance_edge ', & - 'resistance_screw ', & - 'tau_slip ', & - 'velocity_edge ', & - 'velocity_screw ', & - 'gdot_slip_edge ', & - 'gdot_slip_screw ', & - 'stressratio_edge_p ', & - 'stressratio_screw_p' & - /) +character(len=19), dimension(11), parameter :: & + constitutive_titanmod_listDependentSlipStates =(/'segment_edge ', & + 'segment_screw ', & + 'resistance_edge ', & + 'resistance_screw ', & + 'tau_slip ', & + 'velocity_edge ', & + 'velocity_screw ', & + 'gdot_slip_edge ', & + 'gdot_slip_screw ', & + 'stressratio_edge_p ', & + 'stressratio_screw_p' & + /) -character(len=18), dimension(2), parameter:: constitutive_titanmod_listDependentTwinStates =(/'twin_fraction', & - 'tau_twin ' & - /) +character(len=18), dimension(2), parameter :: & + constitutive_titanmod_listDependentTwinStates =(/'twin_fraction', & + 'tau_twin ' & + /) real(pReal), parameter :: kB = 1.38e-23_pReal ! Boltzmann constant in J/Kelvin !* Definition of global variables -integer(pInt), dimension(:), allocatable :: constitutive_titanmod_sizeDotState, & ! number of dotStates - constitutive_titanmod_sizeState, & ! total number of microstructural state variables - constitutive_titanmod_sizePostResults ! cumulative size of post results -integer(pInt), dimension(:,:), allocatable, target :: constitutive_titanmod_sizePostResult ! size of each post result output -character(len=64), dimension(:,:), allocatable, target :: constitutive_titanmod_output ! name of each post result output -integer(pInt), dimension(:), allocatable :: constitutive_titanmod_Noutput ! number of outputs per instance of this constitution -character(len=32), dimension(:), allocatable :: constitutive_titanmod_structureName ! name of the lattice structure -integer(pInt), dimension(:), allocatable :: constitutive_titanmod_structure, & ! number representing the kind of lattice structure - constitutive_titanmod_totalNslip, & ! total number of active slip systems for each instance - constitutive_titanmod_totalNtwin ! total number of active twin systems for each instance -integer(pInt), dimension(:,:), allocatable :: constitutive_titanmod_Nslip, & ! number of active slip systems for each family and instance - constitutive_titanmod_Ntwin, & ! number of active twin systems for each family and instance - constitutive_titanmod_slipFamily, & ! lookup table relating active slip system to slip family for each instance - constitutive_titanmod_twinFamily, & ! lookup table relating active twin system to twin family for each instance - constitutive_titanmod_slipSystemLattice, & ! lookup table relating active slip system index to lattice slip system index for each instance - constitutive_titanmod_twinSystemLattice ! lookup table relating active twin system index to lattice twin system index for each instance -real(pReal), dimension(:), allocatable :: constitutive_titanmod_CoverA, & ! c/a ratio for hex type lattice - constitutive_titanmod_C11, & ! C11 element in elasticity matrix - constitutive_titanmod_C12, & ! C12 element in elasticity matrix - constitutive_titanmod_C13, & ! C13 element in elasticity matrix - constitutive_titanmod_C33, & ! C33 element in elasticity matrix - constitutive_titanmod_C44, & ! C44 element in elasticity matrix - constitutive_titanmod_debyefrequency, & !Debye frequency - constitutive_titanmod_kinkf0, & !Debye frequency - constitutive_titanmod_Gmod, & ! shear modulus - constitutive_titanmod_CAtomicVolume, & ! atomic volume in Bugers vector unit - constitutive_titanmod_dc, & ! prefactor for self-diffusion coefficient - constitutive_titanmod_twinhpconstant, & ! activation energy for dislocation climb - constitutive_titanmod_GrainSize, & ! grain size - Not being used - constitutive_titanmod_MaxTwinFraction, & ! maximum allowed total twin volume fraction - constitutive_titanmod_r, & ! r-exponent in twin nucleation rate - constitutive_titanmod_CEdgeDipMinDistance, & ! Not being used - constitutive_titanmod_Cmfptwin, & ! Not being used - constitutive_titanmod_Cthresholdtwin, & ! Not being used - constitutive_titanmod_aTolRho ! absolute tolerance for integration of dislocation density -real(pReal), dimension(:,:,:), allocatable :: constitutive_titanmod_Cslip_66 ! elasticity matrix in Mandel notation for each instance -real(pReal), dimension(:,:,:,:), allocatable :: constitutive_titanmod_Ctwin_66 ! twin elasticity matrix in Mandel notation for each instance -real(pReal), dimension(:,:,:,:,:), allocatable :: constitutive_titanmod_Cslip_3333 ! elasticity matrix for each instance -real(pReal), dimension(:,:,:,:,:,:), allocatable :: constitutive_titanmod_Ctwin_3333 ! twin elasticity matrix for each instance -real(pReal), dimension(:,:), allocatable :: constitutive_titanmod_rho_edge0, & ! initial edge dislocation density per slip system for each family and instance - constitutive_titanmod_rho_screw0, & ! initial screw dislocation density per slip system for each family and instance - constitutive_titanmod_shear_system0, & ! accumulated shear on each system - constitutive_titanmod_burgersPerSlipFamily, & ! absolute length of burgers vector [m] for each slip family and instance - constitutive_titanmod_burgersPerSlipSystem, & ! absolute length of burgers vector [m] for each slip system and instance - constitutive_titanmod_burgersPerTwinFamily, & ! absolute length of burgers vector [m] for each twin family and instance - constitutive_titanmod_burgersPerTwinSystem, & ! absolute length of burgers vector [m] for each twin system and instance - constitutive_titanmod_f0_PerSlipFamily, & ! activation energy for glide [J] for each slip family and instance - constitutive_titanmod_f0_PerSlipSystem, & ! activation energy for glide [J] for each slip system and instance - constitutive_titanmod_twinf0_PerTwinFamily, & ! activation energy for glide [J] for each twin family and instance - constitutive_titanmod_twinf0_PerTwinSystem, & ! activation energy for glide [J] for each twin system and instance - constitutive_titanmod_twinshearconstant_PerTwinFamily, & ! activation energy for glide [J] for each twin family and instance - constitutive_titanmod_twinshearconstant_PerTwinSystem, & ! activation energy for glide [J] for each twin system and instance - constitutive_titanmod_tau0e_PerSlipFamily, & ! Initial yield stress for edge dislocations per slip family - constitutive_titanmod_tau0e_PerSlipSystem, & ! Initial yield stress for edge dislocations per slip system - constitutive_titanmod_tau0s_PerSlipFamily, & ! Initial yield stress for screw dislocations per slip family - constitutive_titanmod_tau0s_PerSlipSystem, & ! Initial yield stress for screw dislocations per slip system - constitutive_titanmod_twintau0_PerTwinFamily, & ! Initial yield stress for edge dislocations per twin family - constitutive_titanmod_twintau0_PerTwinSystem, & ! Initial yield stress for edge dislocations per twin system - constitutive_titanmod_capre_PerSlipFamily, & ! Capture radii for edge dislocations per slip family - constitutive_titanmod_capre_PerSlipSystem, & ! Capture radii for edge dislocations per slip system - constitutive_titanmod_caprs_PerSlipFamily, & ! Capture radii for screw dislocations per slip family - constitutive_titanmod_caprs_PerSlipSystem, & ! Capture radii for screw dislocations per slip system - constitutive_titanmod_pe_PerSlipFamily, & ! p-exponent in glide velocity - constitutive_titanmod_ps_PerSlipFamily, & ! p-exponent in glide velocity - constitutive_titanmod_qe_PerSlipFamily, & ! q-exponent in glide velocity - constitutive_titanmod_qs_PerSlipFamily, & ! q-exponent in glide velocity - constitutive_titanmod_pe_PerSlipSystem, & ! p-exponent in glide velocity - constitutive_titanmod_ps_PerSlipSystem, & ! p-exponent in glide velocity - constitutive_titanmod_qe_PerSlipSystem, & ! q-exponent in glide velocity - constitutive_titanmod_qs_PerSlipSystem, & ! q-exponent in glide velocity - constitutive_titanmod_twinp_PerTwinFamily, & ! p-exponent in glide velocity - constitutive_titanmod_twinq_PerTwinFamily, & ! q-exponent in glide velocity - constitutive_titanmod_twinp_PerTwinSystem, & ! p-exponent in glide velocity - constitutive_titanmod_twinq_PerTwinSystem, & ! p-exponent in glide velocity - constitutive_titanmod_v0e_PerSlipFamily, & ! edge dislocation velocity prefactor [m/s] for each family and instance - constitutive_titanmod_v0e_PerSlipSystem, & ! screw dislocation velocity prefactor [m/s] for each slip system and instance - constitutive_titanmod_v0s_PerSlipFamily, & ! edge dislocation velocity prefactor [m/s] for each family and instance - constitutive_titanmod_v0s_PerSlipSystem, & ! screw dislocation velocity prefactor [m/s] for each slip system and instance - constitutive_titanmod_twingamma0_PerTwinFamily, & ! edge dislocation velocity prefactor [m/s] for each family and instance - constitutive_titanmod_twingamma0_PerTwinSystem, & ! screw dislocation velocity prefactor [m/s] for each slip system and instance - constitutive_titanmod_kinkcriticallength_PerSlipFamily, & ! screw dislocation mobility prefactor for kink-pairs per slip family - constitutive_titanmod_kinkcriticallength_PerSlipSystem, & ! screw dislocation mobility prefactor for kink-pairs per slip system - constitutive_titanmod_twinsizePerTwinFamily, & ! twin thickness [m] for each twin family and instance - constitutive_titanmod_twinsizePerTwinSystem, & ! twin thickness [m] for each twin system and instance - constitutive_titanmod_CeLambdaSlipPerSlipFamily, & ! Adj. parameter for distance between 2 forest dislocations for each slip family and instance - constitutive_titanmod_CeLambdaSlipPerSlipSystem, & ! Adj. parameter for distance between 2 forest dislocations for each slip system and instance - constitutive_titanmod_CsLambdaSlipPerSlipFamily, & ! Adj. parameter for distance between 2 forest dislocations for each slip family and instance - constitutive_titanmod_CsLambdaSlipPerSlipSystem, & ! Adj. parameter for distance between 2 forest dislocations for each slip system and instance - constitutive_titanmod_twinLambdaSlipPerTwinFamily, & ! Adj. parameter for distance between 2 forest dislocations for each slip family and instance - constitutive_titanmod_twinLambdaSlipPerTwinSystem, & ! Adj. parameter for distance between 2 forest dislocations for each slip system and instance - constitutive_titanmod_interactionSlipSlip, & ! coefficients for slip-slip interaction for each interaction type and instance - constitutive_titanmod_interaction_ee, & ! coefficients for e-e interaction for each interaction type and instance - constitutive_titanmod_interaction_ss, & ! coefficients for s-s interaction for each interaction type and instance - constitutive_titanmod_interaction_es, & ! coefficients for e-s-twin interaction for each interaction type and instance - constitutive_titanmod_interactionSlipTwin, & ! coefficients for twin-slip interaction for each interaction type and instance - constitutive_titanmod_interactionTwinSlip, & ! coefficients for twin-slip interaction for each interaction type and instance - constitutive_titanmod_interactionTwinTwin ! coefficients for twin-twin interaction for each interaction type and instance -real(pReal), dimension(:,:,:), allocatable :: constitutive_titanmod_interactionMatrixSlipSlip, & ! interaction matrix of the different slip systems for each instance - constitutive_titanmod_interactionMatrix_ee, & ! interaction matrix of e-e for each instance - constitutive_titanmod_interactionMatrix_ss, & ! interaction matrix of s-s for each instance - constitutive_titanmod_interactionMatrix_es, & ! interaction matrix of e-s for each instance - constitutive_titanmod_interactionMatrixSlipTwin, & ! interaction matrix of slip systems with twin systems for each instance - constitutive_titanmod_interactionMatrixTwinSlip, & ! interaction matrix of twin systems with slip systems for each instance - constitutive_titanmod_interactionMatrixTwinTwin, & ! interaction matrix of the different twin systems for each instance - constitutive_titanmod_forestProjectionEdge, & ! matrix of forest projections of edge dislocations for each instance - constitutive_titanmod_forestProjectionScrew, & ! matrix of forest projections of screw dislocations for each instance - constitutive_titanmod_TwinforestProjectionEdge, & ! matrix of forest projections of edge dislocations in twin system for each instance - constitutive_titanmod_TwinforestProjectionScrew ! matrix of forest projections of screw dislocations in twin system for each instance +integer(pInt), dimension(:), allocatable :: & + constitutive_titanmod_sizeDotState, & ! number of dotStates + constitutive_titanmod_sizeState, & ! total number of microstructural state variables + constitutive_titanmod_sizePostResults ! cumulative size of post results + +integer(pInt), dimension(:,:), allocatable, target :: & + constitutive_titanmod_sizePostResult ! size of each post result output + +character(len=64), dimension(:,:), allocatable, target :: & + constitutive_titanmod_output ! name of each post result output + +integer(pInt), dimension(:), allocatable :: & + constitutive_titanmod_Noutput ! number of outputs per instance of this constitution + +character(len=32), dimension(:), allocatable :: & + constitutive_titanmod_structureName ! name of the lattice structure + +integer(pInt), dimension(:), allocatable :: & + constitutive_titanmod_structure, & ! number representing the kind of lattice structure + constitutive_titanmod_totalNslip, & ! total number of active slip systems for each instance + constitutive_titanmod_totalNtwin ! total number of active twin systems for each instance + +integer(pInt), dimension(:,:), allocatable :: & + constitutive_titanmod_Nslip, & ! number of active slip systems for each family and instance + constitutive_titanmod_Ntwin, & ! number of active twin systems for each family and instance + constitutive_titanmod_slipFamily, & ! lookup table relating active slip system to slip family for each instance + constitutive_titanmod_twinFamily, & ! lookup table relating active twin system to twin family for each instance + constitutive_titanmod_slipSystemLattice, & ! lookup table relating active slip system index to lattice slip system index for each instance + constitutive_titanmod_twinSystemLattice ! lookup table relating active twin system index to lattice twin system index for each instance + +real(pReal), dimension(:), allocatable :: & + constitutive_titanmod_CoverA, & ! c/a ratio for hex type lattice + constitutive_titanmod_C11, & ! C11 element in elasticity matrix + constitutive_titanmod_C12, & ! C12 element in elasticity matrix + constitutive_titanmod_C13, & ! C13 element in elasticity matrix + constitutive_titanmod_C33, & ! C33 element in elasticity matrix + constitutive_titanmod_C44, & ! C44 element in elasticity matrix + constitutive_titanmod_debyefrequency, & !Debye frequency + constitutive_titanmod_kinkf0, & !Debye frequency + constitutive_titanmod_Gmod, & ! shear modulus + constitutive_titanmod_CAtomicVolume, & ! atomic volume in Bugers vector unit + constitutive_titanmod_dc, & ! prefactor for self-diffusion coefficient + constitutive_titanmod_twinhpconstant, & ! activation energy for dislocation climb + constitutive_titanmod_GrainSize, & ! grain size - Not being used + constitutive_titanmod_MaxTwinFraction, & ! maximum allowed total twin volume fraction + constitutive_titanmod_r, & ! r-exponent in twin nucleation rate + constitutive_titanmod_CEdgeDipMinDistance, & ! Not being used + constitutive_titanmod_Cmfptwin, & ! Not being used + constitutive_titanmod_Cthresholdtwin, & ! Not being used + constitutive_titanmod_aTolRho ! absolute tolerance for integration of dislocation density + +real(pReal), dimension(:,:,:), allocatable :: & + constitutive_titanmod_Cslip_66 ! elasticity matrix in Mandel notation for each instance + +real(pReal), dimension(:,:,:,:), allocatable :: & + constitutive_titanmod_Ctwin_66 ! twin elasticity matrix in Mandel notation for each instance + +real(pReal), dimension(:,:,:,:,:), allocatable :: & + constitutive_titanmod_Cslip_3333 ! elasticity matrix for each instance + +real(pReal), dimension(:,:,:,:,:,:), allocatable :: & + constitutive_titanmod_Ctwin_3333 ! twin elasticity matrix for each instance + +real(pReal), dimension(:,:), allocatable :: & + constitutive_titanmod_rho_edge0, & ! initial edge dislocation density per slip system for each family and instance + constitutive_titanmod_rho_screw0, & ! initial screw dislocation density per slip system for each family and instance + constitutive_titanmod_shear_system0, & ! accumulated shear on each system + constitutive_titanmod_burgersPerSlipFamily, & ! absolute length of burgers vector [m] for each slip family and instance + constitutive_titanmod_burgersPerSlipSystem, & ! absolute length of burgers vector [m] for each slip system and instance + constitutive_titanmod_burgersPerTwinFamily, & ! absolute length of burgers vector [m] for each twin family and instance + constitutive_titanmod_burgersPerTwinSystem, & ! absolute length of burgers vector [m] for each twin system and instance + constitutive_titanmod_f0_PerSlipFamily, & ! activation energy for glide [J] for each slip family and instance + constitutive_titanmod_f0_PerSlipSystem, & ! activation energy for glide [J] for each slip system and instance + constitutive_titanmod_twinf0_PerTwinFamily, & ! activation energy for glide [J] for each twin family and instance + constitutive_titanmod_twinf0_PerTwinSystem, & ! activation energy for glide [J] for each twin system and instance + constitutive_titanmod_twinshearconstant_PerTwinFamily, & ! activation energy for glide [J] for each twin family and instance + constitutive_titanmod_twinshearconstant_PerTwinSystem, & ! activation energy for glide [J] for each twin system and instance + constitutive_titanmod_tau0e_PerSlipFamily, & ! Initial yield stress for edge dislocations per slip family + constitutive_titanmod_tau0e_PerSlipSystem, & ! Initial yield stress for edge dislocations per slip system + constitutive_titanmod_tau0s_PerSlipFamily, & ! Initial yield stress for screw dislocations per slip family + constitutive_titanmod_tau0s_PerSlipSystem, & ! Initial yield stress for screw dislocations per slip system + constitutive_titanmod_twintau0_PerTwinFamily, & ! Initial yield stress for edge dislocations per twin family + constitutive_titanmod_twintau0_PerTwinSystem, & ! Initial yield stress for edge dislocations per twin system + constitutive_titanmod_capre_PerSlipFamily, & ! Capture radii for edge dislocations per slip family + constitutive_titanmod_capre_PerSlipSystem, & ! Capture radii for edge dislocations per slip system + constitutive_titanmod_caprs_PerSlipFamily, & ! Capture radii for screw dislocations per slip family + constitutive_titanmod_caprs_PerSlipSystem, & ! Capture radii for screw dislocations per slip system + constitutive_titanmod_pe_PerSlipFamily, & ! p-exponent in glide velocity + constitutive_titanmod_ps_PerSlipFamily, & ! p-exponent in glide velocity + constitutive_titanmod_qe_PerSlipFamily, & ! q-exponent in glide velocity + constitutive_titanmod_qs_PerSlipFamily, & ! q-exponent in glide velocity + constitutive_titanmod_pe_PerSlipSystem, & ! p-exponent in glide velocity + constitutive_titanmod_ps_PerSlipSystem, & ! p-exponent in glide velocity + constitutive_titanmod_qe_PerSlipSystem, & ! q-exponent in glide velocity + constitutive_titanmod_qs_PerSlipSystem, & ! q-exponent in glide velocity + constitutive_titanmod_twinp_PerTwinFamily, & ! p-exponent in glide velocity + constitutive_titanmod_twinq_PerTwinFamily, & ! q-exponent in glide velocity + constitutive_titanmod_twinp_PerTwinSystem, & ! p-exponent in glide velocity + constitutive_titanmod_twinq_PerTwinSystem, & ! p-exponent in glide velocity + constitutive_titanmod_v0e_PerSlipFamily, & ! edge dislocation velocity prefactor [m/s] for each family and instance + constitutive_titanmod_v0e_PerSlipSystem, & ! screw dislocation velocity prefactor [m/s] for each slip system and instance + constitutive_titanmod_v0s_PerSlipFamily, & ! edge dislocation velocity prefactor [m/s] for each family and instance + constitutive_titanmod_v0s_PerSlipSystem, & ! screw dislocation velocity prefactor [m/s] for each slip system and instance + constitutive_titanmod_twingamma0_PerTwinFamily, & ! edge dislocation velocity prefactor [m/s] for each family and instance + constitutive_titanmod_twingamma0_PerTwinSystem, & ! screw dislocation velocity prefactor [m/s] for each slip system and instance + constitutive_titanmod_kinkcriticallength_PerSlipFamily, & ! screw dislocation mobility prefactor for kink-pairs per slip family + constitutive_titanmod_kinkcriticallength_PerSlipSystem, & ! screw dislocation mobility prefactor for kink-pairs per slip system + constitutive_titanmod_twinsizePerTwinFamily, & ! twin thickness [m] for each twin family and instance + constitutive_titanmod_twinsizePerTwinSystem, & ! twin thickness [m] for each twin system and instance + constitutive_titanmod_CeLambdaSlipPerSlipFamily, & ! Adj. parameter for distance between 2 forest dislocations for each slip family and instance + constitutive_titanmod_CeLambdaSlipPerSlipSystem, & ! Adj. parameter for distance between 2 forest dislocations for each slip system and instance + constitutive_titanmod_CsLambdaSlipPerSlipFamily, & ! Adj. parameter for distance between 2 forest dislocations for each slip family and instance + constitutive_titanmod_CsLambdaSlipPerSlipSystem, & ! Adj. parameter for distance between 2 forest dislocations for each slip system and instance + constitutive_titanmod_twinLambdaSlipPerTwinFamily, & ! Adj. parameter for distance between 2 forest dislocations for each slip family and instance + constitutive_titanmod_twinLambdaSlipPerTwinSystem, & ! Adj. parameter for distance between 2 forest dislocations for each slip system and instance + constitutive_titanmod_interactionSlipSlip, & ! coefficients for slip-slip interaction for each interaction type and instance + constitutive_titanmod_interaction_ee, & ! coefficients for e-e interaction for each interaction type and instance + constitutive_titanmod_interaction_ss, & ! coefficients for s-s interaction for each interaction type and instance + constitutive_titanmod_interaction_es, & ! coefficients for e-s-twin interaction for each interaction type and instance + constitutive_titanmod_interactionSlipTwin, & ! coefficients for twin-slip interaction for each interaction type and instance + constitutive_titanmod_interactionTwinSlip, & ! coefficients for twin-slip interaction for each interaction type and instance + constitutive_titanmod_interactionTwinTwin ! coefficients for twin-twin interaction for each interaction type and instance + +real(pReal), dimension(:,:,:),allocatable :: & + constitutive_titanmod_interactionMatrixSlipSlip, & ! interaction matrix of the different slip systems for each instance + constitutive_titanmod_interactionMatrix_ee, & ! interaction matrix of e-e for each instance + constitutive_titanmod_interactionMatrix_ss, & ! interaction matrix of s-s for each instance + constitutive_titanmod_interactionMatrix_es, & ! interaction matrix of e-s for each instance + constitutive_titanmod_interactionMatrixSlipTwin, & ! interaction matrix of slip systems with twin systems for each instance + constitutive_titanmod_interactionMatrixTwinSlip, & ! interaction matrix of twin systems with slip systems for each instance + constitutive_titanmod_interactionMatrixTwinTwin, & ! interaction matrix of the different twin systems for each instance + constitutive_titanmod_forestProjectionEdge, & ! matrix of forest projections of edge dislocations for each instance + constitutive_titanmod_forestProjectionScrew, & ! matrix of forest projections of screw dislocations for each instance + constitutive_titanmod_TwinforestProjectionEdge, & ! matrix of forest projections of edge dislocations in twin system for each instance + constitutive_titanmod_TwinforestProjectionScrew ! matrix of forest projections of screw dislocations in twin system for each instance CONTAINS !**************************************** !* - constitutive_titanmod_init @@ -215,11 +247,11 @@ integer(pInt), intent(in) :: file !* Local variables integer(pInt), parameter :: maxNchunks = 21_pInt integer(pInt), dimension(1_pInt+2_pInt*maxNchunks) :: positions -integer(pInt) section,f,i,j,k,l,m,n,o,p,q,r,s,s1,s2,t,t1,t2,ns,nt,mySize,myStructure,maxTotalNslip, & -maxTotalNtwin +integer(pInt) :: section,f,i,j,k,l,m,n,o,p,q,r,s,s1,s2,t,t1,t2,ns,nt,& + mySize = 0_pInt,myStructure,maxTotalNslip,maxTotalNtwin integer :: maxNinstance !no pInt -character(len=64) tag -character(len=1024) line +character(len=64) :: tag +character(len=1024) :: line write(6,*) write(6,*) '<<<+- constitutive_',trim(constitutive_titanmod_label),' init -+>>>' @@ -967,7 +999,7 @@ write(6,*) 'Determining elasticity matrix' enddo write(6,*) 'Init All done' -return + end subroutine @@ -977,8 +1009,8 @@ function constitutive_titanmod_stateInit(myInstance) !********************************************************************* use prec, only: pReal,pInt use lattice, only: lattice_maxNslipFamily,lattice_maxNtwinFamily -implicit none +implicit none !* Input-Output variables integer(pInt) :: myInstance real(pReal), dimension(constitutive_titanmod_sizeState(myInstance)) :: constitutive_titanmod_stateInit @@ -1062,7 +1094,6 @@ forall (t = 1_pInt:nt) & resistance_twin0(t) = 0.0_pReal constitutive_titanmod_stateInit(7_pInt*ns+nt+1_pInt:7_pInt*ns+2_pInt*nt)=resistance_twin0 -return end function pure function constitutive_titanmod_aTolState(myInstance) @@ -1070,15 +1101,14 @@ pure function constitutive_titanmod_aTolState(myInstance) !* absolute state tolerance * !********************************************************************* use prec, only: pReal, pInt -implicit none +implicit none !* Input-Output variables integer(pInt), intent(in) :: myInstance real(pReal), dimension(constitutive_titanmod_sizeState(myInstance)) :: constitutive_titanmod_aTolState constitutive_titanmod_aTolState = constitutive_titanmod_aTolRho(myInstance) -return endfunction pure function constitutive_titanmod_homogenizedC(state,g,ip,el) @@ -1092,8 +1122,8 @@ pure function constitutive_titanmod_homogenizedC(state,g,ip,el) use prec, only: pReal,pInt,p_vec use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase,phase_constitutionInstance -implicit none +implicit none !* Input-Output variables integer(pInt), intent(in) :: g,ip,el type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: state @@ -1126,7 +1156,6 @@ do i=1_pInt,nt enddo -return end function @@ -1142,9 +1171,8 @@ subroutine constitutive_titanmod_microstructure(Temperature,state,g,ip,el) use prec, only: pReal,pInt,p_vec use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase,phase_constitutionInstance -!use debug, only: debugger -implicit none +implicit none !* Input-Output variables integer(pInt), intent(in) :: g,ip,el real(pReal), intent(in) :: Temperature @@ -1240,8 +1268,6 @@ forall (t = 1_pInt:nt) & (dot_product((abs(state(g,ip,el)%p(2_pInt*ns+1_pInt:2_pInt*ns+nt))),& constitutive_titanmod_interactionMatrixTwinTwin(1:nt,t,myInstance))) - -return end subroutine @@ -1265,8 +1291,8 @@ use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase,phase_constitutionInstance use lattice, only: lattice_Sslip,lattice_Sslip_v,lattice_Stwin_v,lattice_maxNslipFamily,lattice_maxNtwinFamily, & lattice_NslipSystem,lattice_NtwinSystem, lattice_Stwin -implicit none +implicit none !* Input-Output variables integer(pInt), intent(in) :: g,ip,el real(pReal), intent(in) :: Temperature @@ -1548,7 +1574,6 @@ dLp_dTstar = math_Plain3333to99(dLp_dTstar3333) ! write(6,'(a,/,9(9(f10.4,1x)/))') 'dLp_dTstar',dLp_dTstar !endif -return end subroutine @@ -1571,8 +1596,8 @@ use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance use lattice, only: lattice_maxNslipFamily,lattice_maxNtwinFamily, & lattice_NslipSystem,lattice_NtwinSystem, lattice_Stwin_v -implicit none +implicit none !* Input-Output variables integer(pInt), intent(in) :: g,ip,el real(pReal), intent(in) :: Temperature @@ -1696,8 +1721,6 @@ enddo !write(6,'(a,/,4(3(f30.20,1x)/))') 'EdgeAnnihilation',DotRhoEdgeAnnihilation !write(6,'(a,/,4(3(f30.20,1x)/))') 'ScrewAnnihilation',DotRhoScrewAnnihilation - -return end function @@ -1716,8 +1739,8 @@ pure function constitutive_titanmod_dotTemperature(Tstar_v,Temperature,state,g,i use prec, only: pReal,pInt,p_vec use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains -implicit none +implicit none !* Input-Output variables integer(pInt), intent(in) :: g,ip,el real(pReal), intent(in) :: Temperature @@ -1726,8 +1749,7 @@ type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), in real(pReal) constitutive_titanmod_dotTemperature constitutive_titanmod_dotTemperature = 0.0_pReal - -return + end function @@ -1745,9 +1767,8 @@ pure function constitutive_titanmod_postResults(Tstar_v,Temperature,dt,state,g,i use prec, only: pReal,pInt,p_vec use mesh, only: mesh_NcpElems,mesh_maxNips use material, only: homogenization_maxNgrains,material_phase,phase_constitutionInstance,phase_Noutput -implicit none -!* Definition of variables +implicit none integer(pInt), intent(in) :: g,ip,el real(pReal), intent(in) :: dt,Temperature real(pReal), dimension(6), intent(in) :: Tstar_v @@ -1898,7 +1919,6 @@ do o = 1_pInt,phase_Noutput(material_phase(g,ip,el)) end select enddo -return end function END MODULE diff --git a/code/crystallite.f90 b/code/crystallite.f90 index 9f8b0403d..a09770bf6 100644 --- a/code/crystallite.f90 +++ b/code/crystallite.f90 @@ -33,8 +33,15 @@ MODULE crystallite use prec, only: pReal, pInt -implicit none +implicit none +private :: crystallite_integrateStateFPI, & + crystallite_integrateStateEuler, & + crystallite_integrateStateAdaptiveEuler, & + crystallite_integrateStateRK4, & + crystallite_integrateStateRKCK45, & + crystallite_updateTemperature, & + crystallite_updateState ! **************************************************************** ! *** General variables for the crystallite calculation *** ! **************************************************************** @@ -104,11 +111,11 @@ subroutine crystallite_init(Temperature) !*** variables and functions from other modules ***! use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) -use prec, only: pInt, & - pReal use debug, only: debug_info, & debug_reset, & - debug_verbosity + debug_what, & + debug_crystallite, & + debug_levelBasic use math, only: math_I3, & math_EulerToR, & math_inv33, & @@ -383,7 +390,7 @@ call crystallite_stressAndItsTangent(.true.) ! request elastic crystallite_fallbackdPdF = crystallite_dPdF ! use initial elastic stiffness as fallback ! *** Output to MARC output file *** -if (debug_verbosity > 0) then +if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a35,1x,7(i8,1x))') 'crystallite_Temperature: ', shape(crystallite_Temperature) write(6,'(a35,1x,7(i8,1x))') 'crystallite_dotTemperature: ', shape(crystallite_dotTemperature) @@ -435,10 +442,10 @@ if (debug_verbosity > 0) then !$OMP END CRITICAL (write2out) endif -call debug_info() -call debug_reset() +call debug_info +call debug_reset -endsubroutine +end subroutine crystallite_init @@ -448,102 +455,100 @@ endsubroutine subroutine crystallite_stressAndItsTangent(updateJaco) !*** variables and functions from other modules ***! -use prec, only: pInt, & - pReal -use numerics, only: subStepMinCryst, & - subStepSizeCryst, & - stepIncreaseCryst, & - pert_Fg, & - pert_method, & - nCryst, & - numerics_integrator, & - numerics_integrationMode, & - relevantStrain, & - Lp_frac, & - analyticJaco, & - time_sensitive -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & - debug_e, & - debug_i, & - debug_g, & - debug_CrystalliteLoopDistribution -use IO, only: IO_warning -use math, only: math_inv33, & - math_identity2nd, & - math_transpose33, & - math_mul33x33, & - math_mul66x6, & - math_Mandel6to33, & - math_Mandel33to6, & - math_I3, & - math_Plain3333to99, & - math_Plain99to3333, & - math_mul99x99, & - math_Mandel66to3333, & - math_mul3333xx33, & - math_invert, & - math_mul3333xx3333, & - math_spectralDecompositionSym33 -use FEsolving, only: FEsolving_execElem, & - FEsolving_execIP -use mesh, only: mesh_element, & - mesh_NcpElems, & - mesh_maxNips -use material, only: homogenization_Ngrains, & - homogenization_maxNgrains -use constitutive, only: constitutive_sizeState, & - constitutive_sizeDotState, & - constitutive_state, & - constitutive_state_backup, & - constitutive_subState0, & - constitutive_partionedState0, & - constitutive_homogenizedC, & - constitutive_dotState, & - constitutive_dotState_backup, & - constitutive_LpAndItsTangent +use numerics, only: subStepMinCryst, & + subStepSizeCryst, & + stepIncreaseCryst, & + pert_Fg, & + pert_method, & + nCryst, & + numerics_integrator, & + numerics_integrationMode, & + relevantStrain, & + Lp_frac, & + analyticJaco, & + time_sensitive +use debug, only: debug_what, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g, & + debug_CrystalliteLoopDistribution +use IO, only: IO_warning +use math, only: math_inv33, & + math_identity2nd, & + math_transpose33, & + math_mul33x33, & + math_mul66x6, & + math_Mandel6to33, & + math_Mandel33to6, & + math_I3, & + math_Plain3333to99, & + math_Plain99to3333, & + math_mul99x99, & + math_Mandel66to3333, & + math_mul3333xx33, & + math_invert, & + math_mul3333xx3333, & + math_spectralDecompositionSym33 +use FEsolving, only: FEsolving_execElem, & + FEsolving_execIP +use mesh, only: mesh_element, & + mesh_NcpElems, & + mesh_maxNips +use material, only: homogenization_Ngrains, & + homogenization_maxNgrains +use constitutive, only: constitutive_sizeState, & + constitutive_sizeDotState, & + constitutive_state, & + constitutive_state_backup, & + constitutive_subState0, & + constitutive_partionedState0, & + constitutive_homogenizedC, & + constitutive_dotState, & + constitutive_dotState_backup, & + constitutive_LpAndItsTangent implicit none - !*** input variables ***! -logical, intent(in) :: updateJaco ! flag indicating wehther we want to update the Jacobian (stiffness) or not - -!*** output variables ***! +logical, intent(in) :: updateJaco ! flag indicating wehther we want to update the Jacobian (stiffness) or not !*** local variables ***! -real(pReal) myPert, & ! perturbation with correct sign - formerSubStep -real(pReal), dimension(3,3) :: invFp, & ! inverse of the plastic deformation gradient - Fe_guess, & ! guess for elastic deformation gradient - Tstar ! 2nd Piola-Kirchhoff stress tensor +real(pReal) myPert, & ! perturbation with correct sign + formerSubStep +real(pReal), dimension(3,3) :: invFp, & ! inverse of the plastic deformation gradient + Fe_guess, & ! guess for elastic deformation gradient + Tstar ! 2nd Piola-Kirchhoff stress tensor real(pReal), dimension(3,3,3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - dPdF_perturbation1, & - dPdF_perturbation2 + dPdF_perturbation1, & + dPdF_perturbation2 real(pReal), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - F_backup, & - Fp_backup, & - InvFp_backup, & - Fe_backup, & - Lp_backup, & - P_backup + F_backup, & + Fp_backup, & + InvFp_backup, & + Fe_backup, & + Lp_backup, & + P_backup real(pReal), dimension(6,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - Tstar_v_backup + Tstar_v_backup real(pReal), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - Temperature_backup -integer(pInt) NiterationCrystallite, & ! number of iterations in crystallite loop - e, & ! element index - i, & ! integration point index - g, & ! grain index - k, & - l, & - h, & - o, & - p, & - j, & - perturbation , & ! loop counter for forward,backward perturbation mode - myNgrains, & - mySizeState, & - mySizeDotState + Temperature_backup +integer(pInt) NiterationCrystallite, & ! number of iterations in crystallite loop + e, & ! element index + i, & ! integration point index + g, & ! grain index + k, & + l, & + h, & + o, & + p, & + j, & + perturbation , & ! loop counter for forward,backward perturbation mode + myNgrains, & + mySizeState, & + mySizeDotState logical, dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & convergenceFlag_backup ! local variables used for calculating analytic Jacobian @@ -590,7 +595,8 @@ logical :: error ! --+>> INITIALIZE TO STARTING CONDITION <<+-- -if (debug_verbosity > 4 .and. debug_e > 0 .and. debug_e <= mesh_NcpElems & +if(iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt& + .and. debug_e > 0 .and. debug_e <= mesh_NcpElems & .and. debug_i > 0 .and. debug_i <= mesh_maxNips & .and. debug_g > 0 .and. debug_g <= homogenization_maxNgrains) then !$OMP CRITICAL (write2out) @@ -651,8 +657,9 @@ do while (any(crystallite_subStep(:,:,FEsolving_execELem(1):FEsolving_execElem(2 if (crystallite_converged(g,i,e)) then #ifndef _OPENMP - if (debug_verbosity > 4 & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_crystallite),debug_levelBasic) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,'(a,f12.8,a,f12.8,a)') '<< CRYST >> winding forward from ', & crystallite_subFrac(g,i,e),' to current crystallite_subfrac ', & crystallite_subFrac(g,i,e)+crystallite_subStep(g,i,e),' in crystallite_stressAndItsTangent' @@ -675,7 +682,7 @@ do while (any(crystallite_subStep(:,:,FEsolving_execELem(1):FEsolving_execElem(2 crystallite_subTstar0_v(1:6,g,i,e) = crystallite_Tstar_v(1:6,g,i,e) ! ...2nd PK stress !$OMP FLUSH(crystallite_subF0) elseif (formerSubStep > subStepMinCryst) then ! this crystallite just converged - if (debug_verbosity > 4_pInt) then + if (iand(debug_what(debug_crystallite),debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (distributionCrystallite) debug_CrystalliteLoopDistribution(min(nCryst+1_pInt,NiterationCrystallite)) = & debug_CrystalliteLoopDistribution(min(nCryst+1_pInt,NiterationCrystallite)) + 1_pInt @@ -696,8 +703,9 @@ do while (any(crystallite_subStep(:,:,FEsolving_execELem(1):FEsolving_execElem(2 ! cant restore dotState here, since not yet calculated in first cutback after initialization !$OMP FLUSH(crystallite_invFp) #ifndef _OPENMP - if (debug_verbosity > 4_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_crystallite),debug_levelBasic) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,'(a,f12.8)') '<< CRYST >> cutback step in crystallite_stressAndItsTangent with new crystallite_subStep: ',& crystallite_subStep(g,i,e) write(6,*) @@ -761,8 +769,10 @@ enddo crystallite_P(1:3,1:3,g,i,e) = math_mul33x33(Fe_guess,math_mul33x33(Tstar,transpose(invFp))) endif #ifndef _OPENMP - if (debug_verbosity > 4 & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then + + if(iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_what(debug_crystallite),debug_levelSelective) /= 0_pInt)) then write (6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> central solution of cryst_StressAndTangent at el ip g ',e,i,g write (6,*) write (6,'(a,/,3(12x,3(f12.4,1x)/))') '<< CRYST >> P / MPa', math_transpose33(crystallite_P(1:3,1:3,g,i,e))/1.0e6_pReal @@ -821,7 +831,7 @@ if(updateJaco) then myPert = -pert_Fg * (-1.0_pReal)**perturbation ! set perturbation step do k = 1,3; do l = 1,3 ! ...alter individual components #ifndef _OPENMP - if (debug_verbosity> 5) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a,2(1x,i1),1x,a)') '<< CRYST >> [[[[[[ Stiffness perturbation',k,l,']]]]]]' write(6,*) @@ -1074,7 +1084,7 @@ if(updateJaco) then endif endif ! jacobian calculation -endsubroutine +end subroutine crystallite_stressAndItsTangent @@ -1088,8 +1098,11 @@ subroutine crystallite_integrateStateRK4(gg,ii,ee) use prec, only: pInt, & pReal use numerics, only: numerics_integrationMode -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & +use debug, only: debug_what, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & debug_e, & debug_i, & debug_g, & @@ -1248,8 +1261,10 @@ do n = 1_pInt,4_pInt if (crystallite_integrateStress(g,i,e,timeStepFraction(n))) then ! fraction of original times step if (n == 4) then ! final integration step #ifndef _OPENMP - if (debug_verbosity > 5 & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then + + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then mySizeDotState = constitutive_sizeDotState(g,i,e) write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> updateState at el ip g ',e,i,g write(6,*) @@ -1261,14 +1276,14 @@ do n = 1_pInt,4_pInt #endif crystallite_converged(g,i,e) = .true. ! ... converged per definition crystallite_todo(g,i,e) = .false. ! ... integration done - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (distributionState) debug_StateLoopDistribution(n,numerics_integrationMode) = & debug_StateLoopDistribution(n,numerics_integrationMode) + 1 !$OMP END CRITICAL (distributionState) endif endif - else ! broken stress integration + else ! broken stress integration if (.not. crystallite_localConstitution(g,i,e)) then ! if broken non-local... !$OMP CRITICAL (checkTodo) crystallite_todo = crystallite_todo .and. crystallite_localConstitution ! ...all non-locals skipped @@ -1329,7 +1344,7 @@ if (.not. singleRun) then endif endif -endsubroutine +end subroutine crystallite_integrateStateRK4 @@ -1341,10 +1356,11 @@ endsubroutine subroutine crystallite_integrateStateRKCK45(gg,ii,ee) !*** variables and functions from other modules ***! -use prec, only: pInt, & - pReal -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & +use debug, only: debug_what, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & debug_e, & debug_i, & debug_g, & @@ -1371,15 +1387,10 @@ use constitutive, only: constitutive_sizeDotState, & constitutive_microstructure implicit none - - !*** input variables ***! integer(pInt), optional, intent(in):: ee, & ! element index ii, & ! integration point index gg ! grain index - -!*** output variables ***! - !*** local variables ***! integer(pInt) e, & ! element index in element loop i, & ! integration point index in ip loop @@ -1475,7 +1486,7 @@ endif ! --- FIRST RUNGE KUTTA STEP --- #ifndef _OPENMP -if (debug_verbosity > 5) then +if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt) then write(6,'(a,1x,i1)') '<< CRYST >> RUNGE KUTTA STEP',1 endif #endif @@ -1611,8 +1622,8 @@ do n = 1_pInt,5_pInt ! --- dot state and RK dot state--- #ifndef _OPENMP - if (debug_verbosity > 5) then - write(6,'(a,1x,i1)') '<< CRYST >> RUNGE KUTTA STEP',n+1 + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt) then + write(6,'(a,1x,i1)') '<< CRYST >> RUNGE KUTTA STEP',n+1_pInt endif #endif !$OMP DO @@ -1669,13 +1680,14 @@ relTemperatureResiduum = 0.0_pReal ! NEED TO DO THE ADDITION IN THIS LENGTHY WAY BECAUSE OF PARALLELIZATION ! CAN'T USE A REDUCTION CLAUSE ON A POINTER OR USER DEFINED TYPE - stateResiduum(1:mySizeDotState,g,i,e) = ( db(1) * constitutive_RKCK45dotState(1,g,i,e)%p(1:mySizeDotState) & - + db(2) * constitutive_RKCK45dotState(2,g,i,e)%p(1:mySizeDotState) & - + db(3) * constitutive_RKCK45dotState(3,g,i,e)%p(1:mySizeDotState) & - + db(4) * constitutive_RKCK45dotState(4,g,i,e)%p(1:mySizeDotState) & - + db(5) * constitutive_RKCK45dotState(5,g,i,e)%p(1:mySizeDotState) & - + db(6) * constitutive_RKCK45dotState(6,g,i,e)%p(1:mySizeDotState)) & - * crystallite_subdt(g,i,e) + stateResiduum(1:mySizeDotState,g,i,e) = & + ( db(1) * constitutive_RKCK45dotState(1,g,i,e)%p(1:mySizeDotState) & + + db(2) * constitutive_RKCK45dotState(2,g,i,e)%p(1:mySizeDotState) & + + db(3) * constitutive_RKCK45dotState(3,g,i,e)%p(1:mySizeDotState) & + + db(4) * constitutive_RKCK45dotState(4,g,i,e)%p(1:mySizeDotState) & + + db(5) * constitutive_RKCK45dotState(5,g,i,e)%p(1:mySizeDotState) & + + db(6) * constitutive_RKCK45dotState(6,g,i,e)%p(1:mySizeDotState)) & + * crystallite_subdt(g,i,e) temperatureResiduum(g,i,e) = ( db(1) * RKCK45dotTemperature(1,g,i,e) & + db(2) * RKCK45dotTemperature(2,g,i,e) & + db(3) * RKCK45dotTemperature(3,g,i,e) & @@ -1735,8 +1747,9 @@ relTemperatureResiduum = 0.0_pReal .and. abs(relTemperatureResiduum(g,i,e)) < rTol_crystalliteTemperature ) #ifndef _OPENMP - if (debug_verbosity > 5_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt& + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,'(a,i8,1x,i3,1x,i3)') '<< CRYST >> updateState at el ip g ',e,i,g write(6,*) write(6,'(a,/,(12x,12(f12.1,1x)))') '<< CRYST >> absolute residuum tolerance', & @@ -1776,7 +1789,7 @@ relTemperatureResiduum = 0.0_pReal if (crystallite_integrateStress(g,i,e)) then crystallite_converged(g,i,e) = .true. ! ... converged per definitionem crystallite_todo(g,i,e) = .false. ! ... integration done - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (distributionState) debug_StateLoopDistribution(6,numerics_integrationMode) =& debug_StateLoopDistribution(6,numerics_integrationMode) + 1_pInt @@ -1798,7 +1811,7 @@ relTemperatureResiduum = 0.0_pReal ! --- nonlocal convergence check --- #ifndef _OPENMP - if (debug_verbosity > 5) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt) then write(6,'(a,i8,a,i2)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), ' grains converged' write(6,*) endif @@ -1810,7 +1823,7 @@ if (.not. singleRun) then endif -endsubroutine +end subroutine crystallite_integrateStateRKCK45 @@ -1821,10 +1834,11 @@ endsubroutine subroutine crystallite_integrateStateAdaptiveEuler(gg,ii,ee) !*** variables and functions from other modules ***! -use prec, only: pInt, & - pReal -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & +use debug, only: debug_what, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & debug_e, & debug_i, & debug_g, & @@ -1856,9 +1870,6 @@ implicit none integer(pInt), optional, intent(in):: ee, & ! element index ii, & ! integration point index gg ! grain index - -!*** output variables ***! - !*** local variables ***! integer(pInt) e, & ! element index in element loop i, & ! integration point index in ip loop @@ -2046,8 +2057,9 @@ relTemperatureResiduum = 0.0_pReal !$OMP FLUSH(relStateResiduum,relTemperatureResiduum) #ifndef _OPENMP - if (debug_verbosity > 5 & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> updateState at el ip g ',e,i,g write(6,*) write(6,'(a,/,(12x,12(f12.1,1x)))') '<< CRYST >> absolute residuum tolerance', & @@ -2062,7 +2074,7 @@ relTemperatureResiduum = 0.0_pReal write(6,'(a,/,(12x,12(e12.5,1x)))') '<< CRYST >> new state', constitutive_state(g,i,e)%p(1:mySizeDotState) write(6,*) endif -#endif +#endif ! --- converged ? --- @@ -2071,7 +2083,7 @@ relTemperatureResiduum = 0.0_pReal .and. abs(relTemperatureResiduum(g,i,e)) < rTol_crystalliteTemperature ) then crystallite_converged(g,i,e) = .true. ! ... converged per definitionem crystallite_todo(g,i,e) = .false. ! ... integration done - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (distributionState) debug_StateLoopDistribution(2,numerics_integrationMode) = debug_StateLoopDistribution(2,numerics_integrationMode) + 1 !$OMP END CRITICAL (distributionState) @@ -2087,7 +2099,7 @@ relTemperatureResiduum = 0.0_pReal ! --- NONLOCAL CONVERGENCE CHECK --- #ifndef _OPENMP - if (debug_verbosity > 5) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt) then write(6,'(a,i8,a,i2)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), ' grains converged' write(6,*) endif @@ -2098,7 +2110,7 @@ if (.not. singleRun) then endif endif -endsubroutine +end subroutine crystallite_integrateStateAdaptiveEuler @@ -2109,11 +2121,12 @@ endsubroutine subroutine crystallite_integrateStateEuler(gg,ii,ee) !*** variables and functions from other modules ***! -use prec, only: pInt, & - pReal use numerics, only: numerics_integrationMode -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & +use debug, only: debug_what, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & debug_e, & debug_i, & debug_g, & @@ -2132,14 +2145,10 @@ use constitutive, only: constitutive_sizeDotState, & constitutive_microstructure implicit none - !*** input variables ***! integer(pInt), optional, intent(in):: ee, & ! element index ii, & ! integration point index gg ! grain index - -!*** output variables ***! - !*** local variables ***! integer(pInt) e, & ! element index in element loop i, & ! integration point index in ip loop @@ -2220,8 +2229,10 @@ if (numerics_integrationMode < 2) then crystallite_Temperature(g,i,e) = crystallite_subTemperature0(g,i,e) & + crystallite_dotTemperature(g,i,e) * crystallite_subdt(g,i,e) #ifndef _OPENMP - if (debug_verbosity > 5 & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then + + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> updateState at el ip g ',e,i,g write(6,*) write(6,'(a,/,(12x,12(e12.5,1x)))') '<< CRYST >> dotState', constitutive_dotState(g,i,e)%p(1:mySizeDotState) @@ -2256,7 +2267,7 @@ endif if (crystallite_todo(g,i,e)) then if (crystallite_integrateStress(g,i,e)) then crystallite_converged(g,i,e) = .true. - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (distributionState) debug_StateLoopDistribution(1,numerics_integrationMode) = debug_StateLoopDistribution(1,numerics_integrationMode) + 1 !$OMP END CRITICAL (distributionState) @@ -2284,7 +2295,7 @@ if (.not. singleRun) then endif endif -endsubroutine +end subroutine crystallite_integrateStateEuler @@ -2296,9 +2307,10 @@ endsubroutine subroutine crystallite_integrateStateFPI(gg,ii,ee) !*** variables and functions from other modules ***! -use prec, only: pInt, & - pReal -use debug, only: debug_verbosity, & +use debug, only: debug_what,& + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & debug_StateLoopDistribution use numerics, only: nState, & numerics_integrationMode @@ -2447,8 +2459,9 @@ do while (any(crystallite_todo) .and. NiterationState < nState ) enddo; enddo; enddo !$OMP ENDDO + #ifndef _OPENMP - if (debug_verbosity > 5) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt) then write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo after stress integration' endif #endif @@ -2500,7 +2513,7 @@ do while (any(crystallite_todo) .and. NiterationState < nState ) crystallite_todo = crystallite_todo .and. crystallite_localConstitution ! ...all non-locals skipped !$OMP END CRITICAL (checkTodo) elseif (stateConverged .and. temperatureConverged) then ! check (private) logicals "stateConverged" and "temperatureConverged" instead of (shared) "crystallite_converged", so no need to flush the "crystallite_converged" array - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (distributionState) debug_StateLoopDistribution(NiterationState,numerics_integrationMode) = & debug_StateLoopDistribution(NiterationState,numerics_integrationMode) + 1_pInt @@ -2529,7 +2542,7 @@ do while (any(crystallite_todo) .and. NiterationState < nState ) !$OMP END PARALLEL #ifndef _OPENMP - if (debug_verbosity > 5) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt) then write(6,'(a,i8,a,i2)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & ' grains converged after state integration no. ', NiterationState write(6,*) @@ -2547,7 +2560,7 @@ do while (any(crystallite_todo) .and. NiterationState < nState ) crystallite_todo = crystallite_todo .and. .not. crystallite_converged ! skip all converged #ifndef _OPENMP - if (debug_verbosity > 5) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt) then write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_converged(:,:,:)),' grains converged after non-local check' write(6,'(a,i8,a,i2)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo after state integration no. ',& NiterationState @@ -2557,7 +2570,7 @@ do while (any(crystallite_todo) .and. NiterationState < nState ) enddo ! crystallite convergence loop -endsubroutine +end subroutine crystallite_integrateStateFPI @@ -2568,7 +2581,6 @@ endsubroutine subroutine crystallite_updateState(done, converged, g, i, e) !*** variables and functions from other modules ***! -use prec, only: pInt use numerics, only: rTol_crystalliteState use constitutive, only: constitutive_dotState, & constitutive_previousDotState, & @@ -2577,8 +2589,11 @@ use constitutive, only: constitutive_dotState, & constitutive_state, & constitutive_aTolState, & constitutive_microstructure -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & +use debug, only: debug_what, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & debug_e, & debug_i, & debug_g @@ -2618,7 +2633,7 @@ residuum = constitutive_state(g,i,e)%p(1:mySize) - constitutive_subState0(g,i,e) - dotState(1:mySize) * crystallite_subdt(g,i,e) if (any(residuum /= residuum)) then ! if NaN occured then return without changing the state #ifndef _OPENMP - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> updateState encountered NaN at el ip g ',e,i,g endif #endif @@ -2634,7 +2649,9 @@ converged = all( abs(residuum) < constitutive_aTolState(g,i,e)%p(1:mySize) & .or. abs(residuum) < rTol_crystalliteState * abs(state(1:mySize)) ) #ifndef _OPENMP -if (debug_verbosity > 5 .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then +if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then if (converged) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> updateState converged at el ip g ',e,i,g else @@ -2656,7 +2673,7 @@ endif constitutive_dotState(g,i,e)%p(1:mySize) = dotState(1:mySize) constitutive_state(g,i,e)%p(1:mySize) = state(1:mySize) -endsubroutine +end subroutine crystallite_updateState @@ -2664,13 +2681,14 @@ endsubroutine ! update the temperature of the grain ! and tell whether it has converged !******************************************************************** - subroutine crystallite_updateTemperature(done, converged, g, i, e) +subroutine crystallite_updateTemperature(done, converged, g, i, e) !*** variables and functions from other modules ***! -use prec, only: pInt use numerics, only: rTol_crystalliteTemperature use constitutive, only: constitutive_dotTemperature -use debug, only: debug_verbosity +use debug, only: debug_what, & + debug_crystallite, & + debug_levelBasic !*** input variables ***! integer(pInt), intent(in):: e, & ! element index i, & ! integration point index @@ -2698,7 +2716,7 @@ residuum = crystallite_Temperature(g,i,e) - crystallite_subTemperature0(g,i,e) & * crystallite_subdt(g,i,e) if (residuum /= residuum) then #ifndef _OPENMP - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> updateTemperature encountered NaN at el ip g ',e,i,g endif #endif @@ -2714,7 +2732,7 @@ done = .true. converged = ( crystallite_Temperature(g,i,e) == 0.0_pReal & .or. abs(residuum) < rTol_crystalliteTemperature * crystallite_Temperature(g,i,e)) -endsubroutine +end subroutine crystallite_updateTemperature @@ -2731,18 +2749,18 @@ function crystallite_integrateStress(& ) -!*** variables and functions from other modules ***! -use prec, only: pReal, & - pInt, & - pLongInt +use prec, only: pLongInt use numerics, only: nStress, & aTol_crystalliteStress, & rTol_crystalliteStress, & iJacoLpresiduum, & relevantStrain, & numerics_integrationMode -use debug, only: debug_verbosity, & - debug_selectiveDebugger, & +use debug, only: debug_what, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & debug_e, & debug_i, & debug_g, & @@ -2832,7 +2850,9 @@ integer(pLongInt) tick, & crystallite_integrateStress = .false. #ifndef _OPENMP -if (debug_verbosity > 5 .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then +if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> integrateStress at el ip g ',e,i,g endif #endif @@ -2861,9 +2881,11 @@ Lpguess = crystallite_Lp(1:3,1:3,g,i,e) ! ... and tak invFp_current = math_inv33(Fp_current) if (all(invFp_current == 0.0_pReal)) then ! ... failed? #ifndef _OPENMP - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> integrateStress failed on invFp_current inversion at el ip g ',e,i,g - if (debug_verbosity > 5 .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_crystallite), debug_levelSelective) > 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,*) write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> invFp_new',math_transpose33(invFp_new(1:3,1:3)) endif @@ -2896,7 +2918,7 @@ LpLoop: do if (NiterationStress > nStress) then #ifndef _OPENMP - if (debug_verbosity > 4_pInt) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> integrateStress reached loop limit at el ip g ',e,i,g write(6,*) endif @@ -2919,11 +2941,11 @@ LpLoop: do !* calculate plastic velocity gradient and its tangent according to constitutive law - if (debug_verbosity > 0) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then call system_clock(count=tick,count_rate=tickrate,count_max=maxticks) endif call constitutive_LpAndItsTangent(Lp_constitutive, dLp_dT_constitutive, Tstar_v, crystallite_Temperature(g,i,e), g, i, e) - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then call system_clock(count=tock,count_rate=tickrate,count_max=maxticks) !$OMP CRITICAL (debugTimingLpTangent) debug_cumLpCalls = debug_cumLpCalls + 1_pInt @@ -2934,7 +2956,9 @@ LpLoop: do endif #ifndef _OPENMP - if (debug_verbosity > 5 .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger) & + if (iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt) & .and. numerics_integrationMode == 1_pInt) then write(6,'(a,i3)') '<< CRYST >> iteration ', NiterationStress write(6,*) @@ -2961,7 +2985,7 @@ LpLoop: do !* NaN occured at regular speed -> return if (steplength >= steplength0 .and. any(residuum /= residuum)) then #ifndef _OPENMP - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then write(6,'(a,i8,1x,i2,1x,i3,a,i3,a)') '<< CRYST >> integrateStress encountered NaN at el ip g ',e,i,g,& ' ; iteration ', NiterationStress,& ' >> returning..!' @@ -3009,7 +3033,7 @@ LpLoop: do !* something went wrong at accelerated speed? -> return to regular speed and try again else #ifndef _OPENMP - if (debug_verbosity > 5) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt) then write(6,'(a,i8,1x,i2,1x,i3,1x,a,i3)') '<< CRYST >> integrateStress encountered high-speed crash at el ip g ',e,i,g,& '; iteration ', NiterationStress endif @@ -3022,7 +3046,7 @@ LpLoop: do steplength_max = steplength - 1.0_pReal ! limit acceleration steplength = steplength0 ! grinding halt jacoCounter = 0_pInt ! reset counter for Jacobian update (we want to do an update next time!) - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (distributionLeapfrogBreak) debug_LeapfrogBreakDistribution(NiterationStress,numerics_integrationMode) = & debug_LeapfrogBreakDistribution(NiterationStress,numerics_integrationMode) + 1_pInt @@ -3046,10 +3070,11 @@ LpLoop: do call math_invert(9_pInt,dR_dLp,inv_dR_dLp,dummy,error) ! invert dR/dLp --> dLp/dR if (error) then #ifndef _OPENMP - if (debug_verbosity > 4_pInt) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then write(6,'(a,i8,1x,i2,1x,i3,a,i3)') '<< CRYST >> integrateStress failed on dR/dLp inversion at el ip g ',e,i,g - if (debug_verbosity > 5_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,*) write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dR_dLp',transpose(dR_dLp) write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dT_dLp',transpose(dT_dLp) @@ -3091,10 +3116,12 @@ invFp_new = invFp_new/math_det33(invFp_new)**(1.0_pReal/3.0_pReal) ! regularize call math_invert33(invFp_new,Fp_new,det,error) if (error) then #ifndef _OPENMP - if (debug_verbosity > 4) then + if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then write(6,'(a,i8,1x,i2,1x,i3,a,i3)') '<< CRYST >> integrateStress failed on invFp_new inversion at el ip g ',& e,i,g, ' ; iteration ', NiterationStress - if (debug_verbosity > 5 .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,*) write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> invFp_new',math_transpose33(invFp_new) endif @@ -3124,7 +3151,9 @@ crystallite_invFp(1:3,1:3,g,i,e) = invFp_new crystallite_integrateStress = .true. #ifndef _OPENMP -if (debug_verbosity > 5 .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) .or. .not. debug_selectiveDebugger) & +if (iand(debug_what(debug_crystallite),debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_what(debug_crystallite), debug_levelSelective) /= 0_pInt) & .and. numerics_integrationMode == 1_pInt) then write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> P / MPa',math_transpose33(crystallite_P(1:3,1:3,g,i,e))/1.0e6_pReal write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Cauchy / MPa', & @@ -3135,25 +3164,24 @@ if (debug_verbosity > 5 .and. ((e == debug_e .and. i == debug_i .and. g == debug endif #endif -if (debug_verbosity > 4) then +if (iand(debug_what(debug_crystallite), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (distributionStress) debug_StressLoopDistribution(NiterationStress,numerics_integrationMode) = & debug_StressLoopDistribution(NiterationStress,numerics_integrationMode) + 1_pInt !$OMP END CRITICAL (distributionStress) endif -endfunction +end function crystallite_integrateStress !******************************************************************** ! calculates orientations and disorientations (in case of single grain ips) !******************************************************************** -subroutine crystallite_orientations() +subroutine crystallite_orientations !*** variables and functions from other modules ***! -use prec, only: pInt, & - pReal + use math, only: math_pDecomposition, & math_RtoQuaternion, & math_QuaternionDisorientation, & @@ -3267,7 +3295,7 @@ logical error enddo !$OMP END PARALLEL DO -endsubroutine +end subroutine crystallite_orientations @@ -3282,8 +3310,6 @@ function crystallite_postResults(& ) !*** variables and functions from other modules ***! - use prec, only: pInt, & - pReal use math, only: math_QuaternionToEuler, & math_QuaternionToAxisAngle, & math_mul33x33, & @@ -3396,7 +3422,7 @@ function crystallite_postResults(& dt, g, i, e) c = c + constitutive_sizePostResults(g,i,e) -endfunction +end function crystallite_postResults END MODULE diff --git a/code/debug.f90 b/code/debug.f90 index 156137735..cf4cb135b 100644 --- a/code/debug.f90 +++ b/code/debug.f90 @@ -19,349 +19,423 @@ !############################################################## !* $Id$ !############################################################## -MODULE debug +module debug !############################################################## -use prec + use prec, only: pInt, pReal, pLongInt -implicit none -character(len=64), parameter :: debug_configFile = 'debug.config' ! name of configuration file -integer(pInt), parameter :: debug_spectralGeneral = 1_pInt, & - debug_spectralDivergence = 2_pInt, & - debug_spectralRestart = 4_pInt, & - debug_spectralFFTW = 8_pInt + implicit none + private + + integer(pInt), parameter, public :: & + debug_levelSelective = 2_pInt**0_pInt, & + debug_levelBasic = 2_pInt**1_pInt, & + debug_levelExtensive = 2_pInt**2_pInt + integer(pInt), parameter, private :: & + debug_maxForAll = debug_levelExtensive + integer(pInt), parameter, public :: & + debug_spectralRestart = debug_maxForAll*2_pInt**1_pInt, & + debug_spectralFFTW = debug_maxForAll*2_pInt**2_pInt, & + debug_spectralDivergence = debug_maxForAll*2_pInt**3_pInt -integer(pInt), dimension(:,:), allocatable :: debug_StressLoopDistribution -integer(pInt), dimension(:,:), allocatable :: debug_LeapfrogBreakDistribution -integer(pInt), dimension(:,:), allocatable :: debug_StateLoopDistribution -integer(pInt), dimension(:), allocatable :: debug_CrystalliteLoopDistribution -integer(pInt), dimension(:), allocatable :: debug_MaterialpointStateLoopDistribution -integer(pInt), dimension(:), allocatable :: debug_MaterialpointLoopDistribution -integer(pLongInt) :: debug_cumLpTicks = 0_pLongInt -integer(pLongInt) :: debug_cumDotStateTicks = 0_pLongInt -integer(pLongInt) :: debug_cumDotTemperatureTicks = 0_pLongInt -integer(pInt) :: debug_cumLpCalls = 0_pInt -integer(pInt) :: debug_cumDotStateCalls = 0_pInt -integer(pInt) :: debug_cumDotTemperatureCalls = 0_pInt -integer(pInt) :: debug_e = 1_pInt -integer(pInt) :: debug_i = 1_pInt -integer(pInt) :: debug_g = 1_pInt -integer(pInt), dimension(2) :: debug_stressMaxLocation = 0_pInt -integer(pInt), dimension(2) :: debug_stressMinLocation = 0_pInt -integer(pInt), dimension(2) :: debug_jacobianMaxLocation = 0_pInt -integer(pInt), dimension(2) :: debug_jacobianMinLocation = 0_pInt -real(pReal) :: debug_stressMax -real(pReal) :: debug_stressMin -real(pReal) :: debug_jacobianMax -real(pReal) :: debug_jacobianMin -logical :: debug_selectiveDebugger = .true. -integer(pInt) :: debug_verbosity = 1_pInt -integer(pInt) :: debug_spectral = 0_pInt + integer(pInt), parameter, public :: & + debug_debug = 1_pInt, & + debug_math = 2_pInt, & + debug_FEsolving = 3_pInt, & + debug_mesh = 4_pInt, & ! stores debug level for mesh part of DAMASK + debug_material = 5_pInt, & ! stores debug level for material part of DAMASK + debug_lattice = 6_pInt, & ! stores debug level for lattice part of DAMASK + debug_constitutive = 7_pInt, & ! stores debug level for constitutive part of DAMASK + debug_crystallite = 8_pInt, & + debug_homogenization = 9_pInt, & + debug_CPFEM = 10_pInt, & + debug_spectral = 11_pInt + + integer(pInt), dimension(11+2), public :: & ! 11 for specific, and 2 for "all" and "other" + debug_what = 0_pInt -CONTAINS + integer(pInt), public :: & + debug_cumLpCalls = 0_pInt, & + debug_cumDotStateCalls = 0_pInt, & + debug_cumDotTemperatureCalls = 0_pInt, & + debug_e = 1_pInt, & + debug_i = 1_pInt, & + debug_g = 1_pInt + + integer(pLongInt), public :: & + debug_cumLpTicks = 0_pLongInt, & + debug_cumDotStateTicks = 0_pLongInt, & + debug_cumDotTemperatureTicks = 0_pLongInt + + integer(pInt), dimension(2), public :: & + debug_stressMaxLocation = 0_pInt, & + debug_stressMinLocation = 0_pInt, & + debug_jacobianMaxLocation = 0_pInt, & + debug_jacobianMinLocation = 0_pInt + + integer(pInt), dimension(:), allocatable, public :: & + debug_CrystalliteLoopDistribution, & + debug_MaterialpointStateLoopDistribution, & + debug_MaterialpointLoopDistribution + + integer(pInt), dimension(:,:), allocatable, public :: & + debug_StressLoopDistribution, & + debug_LeapfrogBreakDistribution, & + debug_StateLoopDistribution + + real(pReal), public :: & + debug_stressMax = -huge(1.0_pReal), & + debug_stressMin = huge(1.0_pReal), & + debug_jacobianMax = -huge(1.0_pReal), & + debug_jacobianMin = huge(1.0_pReal) + + character(len=64), parameter, private :: & + debug_configFile = 'debug.config' ! name of configuration file + + public :: debug_init, & + debug_reset, & + debug_info + +contains !******************************************************************** ! initialize the debugging capabilities !******************************************************************** -subroutine debug_init() - - use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) - use prec, only: pInt - use numerics, only: nStress, & - nState, & - nCryst, & - nMPstate, & - nHomog - use IO, only: IO_error, & - IO_open_file_stat, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_lc, & - IO_floatValue, & - IO_intValue - implicit none - - !*** input variables ***! - - !*** output variables ***! - - !*** local variables ***! - integer(pInt), parameter :: fileunit = 300_pInt - integer(pInt), parameter :: maxNchunks = 2_pInt - integer(pInt), dimension(1+2*maxNchunks) :: positions - character(len=64) tag - character(len=1024) line - - !$OMP CRITICAL (write2out) - write(6,*) - write(6,*) '<<<+- debug init -+>>>' - write(6,*) '$Id$' +subroutine debug_init + + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use numerics, only: nStress, & + nState, & + nCryst, & + nMPstate, & + nHomog + use IO, only: IO_error, & + IO_open_file_stat, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_lc, & + IO_floatValue, & + IO_intValue + + implicit none + integer(pInt), parameter :: fileunit = 300_pInt + integer(pInt), parameter :: maxNchunks = 6_pInt + + integer(pInt) :: i, what + integer(pInt), dimension(1+2*maxNchunks) :: positions + character(len=64) :: tag + character(len=1024) :: line + + !$OMP CRITICAL (write2out) + write(6,*) + write(6,*) '<<<+- debug init -+>>>' + write(6,*) '$Id$' #include "compilation_info.f90" - !$OMP END CRITICAL (write2out) + !$OMP END CRITICAL (write2out) + + allocate(debug_StressLoopDistribution(nStress,2)) + debug_StressLoopDistribution = 0_pInt + allocate(debug_LeapfrogBreakDistribution(nStress,2)) + debug_LeapfrogBreakDistribution = 0_pInt + allocate(debug_StateLoopDistribution(nState,2)) + debug_StateLoopDistribution = 0_pInt + allocate(debug_CrystalliteLoopDistribution(nCryst+1)) + debug_CrystalliteLoopDistribution = 0_pInt + allocate(debug_MaterialpointStateLoopDistribution(nMPstate)) + debug_MaterialpointStateLoopDistribution = 0_pInt + allocate(debug_MaterialpointLoopDistribution(nHomog+1)) + debug_MaterialpointLoopDistribution = 0_pInt + + + ! try to open the config file + if(IO_open_file_stat(fileunit,debug_configFile)) then + + ! read variables from config file and overwrite parameters + do + read(fileunit,'(a1024)',END=100) line + if (IO_isBlank(line)) cycle ! skip empty lines + positions = IO_stringPos(line,maxNchunks) + tag = IO_lc(IO_stringValue(line,positions,1_pInt)) ! extract key + select case(tag) + case ('element','e','el') + debug_e = IO_intValue(line,positions,2_pInt) + case ('integrationpoint','i','ip') + debug_i = IO_intValue(line,positions,2_pInt) + case ('grain','g','gr') + debug_g = IO_intValue(line,positions,2_pInt) + end select + + what = 0_pInt + select case(tag) + case ('debug') + what = debug_debug + case ('math') + what = debug_math + case ('fesolving', 'fe') + what = debug_FEsolving + case ('mesh') + what = debug_mesh + case ('material') + what = debug_material + case ('lattice') + what = debug_lattice + case ('constitutive') + what = debug_constitutive + case ('crystallite') + what = debug_crystallite + case ('homogenization') + what = debug_homogenization + case ('cpfem') + what = debug_CPFEM + case ('spectral') + what = debug_spectral + case ('all') + what = 12_pInt + case ('other') + what = 13_pInt + end select + if(what /= 0) then + do i = 2_pInt, maxNchunks + select case(IO_lc(IO_stringValue(line,positions,i))) + case('basic') + debug_what(what) = ior(debug_what(what), debug_levelBasic) + case('extensive') + debug_what(what) = ior(debug_what(what), debug_levelExtensive) + case('selective') + debug_what(what) = ior(debug_what(what), debug_levelSelective) + case('restart') + debug_what(what) = ior(debug_what(what), debug_spectralRestart) + case('fft','fftw') + debug_what(what) = ior(debug_what(what), debug_spectralFFTW) + case('divergence') + debug_what(what) = ior(debug_what(what), debug_spectralDivergence) + end select + enddo + endif + enddo + 100 close(fileunit) + + do i = 1_pInt, 11_pInt + if(debug_what(i) == 0) debug_what(i) = ior(debug_what(i), debug_what(13)) + debug_what(i) = ior(debug_what(i), debug_what(12)) + enddo - allocate(debug_StressLoopDistribution(nStress,2)) ; debug_StressLoopDistribution = 0_pInt - allocate(debug_LeapfrogBreakDistribution(nStress,2)) ; debug_LeapfrogBreakDistribution = 0_pInt - allocate(debug_StateLoopDistribution(nState,2)) ; debug_StateLoopDistribution = 0_pInt - allocate(debug_CrystalliteLoopDistribution(nCryst+1)) ; debug_CrystalliteLoopDistribution = 0_pInt - allocate(debug_MaterialpointStateLoopDistribution(nMPstate)) ; debug_MaterialpointStateLoopDistribution = 0_pInt - allocate(debug_MaterialpointLoopDistribution(nHomog+1)) ; debug_MaterialpointLoopDistribution = 0_pInt - - ! try to open the config file - if(IO_open_file_stat(fileunit,debug_configFile)) then - - line = '' - ! read variables from config file and overwrite parameters - do - read(fileunit,'(a1024)',END=100) line - if (IO_isBlank(line)) cycle ! skip empty lines - positions = IO_stringPos(line,maxNchunks) - tag = IO_lc(IO_stringValue(line,positions,1_pInt)) ! extract key - select case(tag) - case ('element','e','el') - debug_e = IO_intValue(line,positions,2_pInt) - case ('integrationpoint','i','ip') - debug_i = IO_intValue(line,positions,2_pInt) - case ('grain','g','gr') - debug_g = IO_intValue(line,positions,2_pInt) - case ('selective') - debug_selectiveDebugger = IO_intValue(line,positions,2_pInt) > 0_pInt - case ('verbosity') - debug_verbosity = IO_intValue(line,positions,2_pInt) - case ('(spectral)') - select case(IO_lc(IO_stringValue(line,positions,2_pInt))) - case('general') - debug_spectral = ior(debug_spectral, debug_spectralGeneral) - case('divergence') - debug_spectral = ior(debug_spectral, debug_spectralDivergence) - case('restart') - debug_spectral = ior(debug_spectral, debug_spectralRestart) - case('fftw', 'fft') - debug_spectral = ior(debug_spectral, debug_spectralFFTW) - endselect - endselect - enddo - 100 close(fileunit) - - if (debug_verbosity > 0_pInt) then - !$OMP CRITICAL (write2out) - write(6,*) ' ... using values from config file' - write(6,*) - !$OMP END CRITICAL (write2out) - endif - - ! no config file, so we use standard values - else + if (iand(debug_what(debug_debug),debug_levelBasic) /= 0) then + !$OMP CRITICAL (write2out) + write(6,*) 'using values from config file' + write(6,*) + !$OMP END CRITICAL (write2out) + endif - if (debug_verbosity > 0_pInt) then - !$OMP CRITICAL (write2out) - write(6,*) ' ... using standard values' - write(6,*) - !$OMP END CRITICAL (write2out) - endif - - endif + ! no config file, so we use standard values + else + if (iand(debug_what(debug_debug),debug_levelBasic) /= 0) then + !$OMP CRITICAL (write2out) + write(6,*) 'using standard values' + write(6,*) + !$OMP END CRITICAL (write2out) + endif + endif - if (debug_verbosity > 0) then - !$OMP CRITICAL (write2out) - write(6,'(a24,1x,i1)') 'verbose: ',debug_verbosity - write(6,'(a24,1x,l1)') 'selective: ',debug_selectiveDebugger - !$OMP END CRITICAL (write2out) - endif - if (debug_selectiveDebugger) then - if (debug_verbosity > 0) then - !$OMP CRITICAL (write2out) - write(6,'(a24,1x,i8)') 'element: ',debug_e - write(6,'(a24,1x,i8)') 'ip: ',debug_i - write(6,'(a24,1x,i8)') 'grain: ',debug_g - !$OMP END CRITICAL (write2out) - endif - else - debug_e = 0_pInt ! switch off selective debugging - debug_i = 0_pInt - debug_g = 0_pInt - endif - !$OMP CRITICAL (write2out) ! bitwise coded - if (iand(debug_spectral,debug_spectralGeneral) > 0_pInt) write(6,'(a)') ' spectral general debugging' - if (iand(debug_spectral,debug_spectralDivergence) > 0_pInt) write(6,'(a)') ' spectral divergence debugging' - if (iand(debug_spectral,debug_spectralRestart) > 0_pInt) write(6,'(a)') ' spectral restart debugging' - if (iand(debug_spectral,debug_spectralFFTW) > 0_pInt) write(6,'(a)') ' spectral FFTW debugging' - !$OMP END CRITICAL (write2out) + !output switched on (debug level for debug must be extensive) + if (iand(debug_what(debug_debug),debug_levelExtensive) /= 0) then + !$OMP CRITICAL (write2out) + do i = 1_pInt, 11_pInt + if(debug_what(i) /= 0) then + if(i == debug_debug) write(6,'(a)') 'Debug debugging:' + if(i == debug_math) write(6,'(a)') 'Math debugging:' + if(i == debug_FEsolving) write(6,'(a)') 'FEsolving debugging:' + if(i == debug_mesh) write(6,'(a)') 'Mesh debugging:' + if(i == debug_material) write(6,'(a)') 'Material debugging:' + if(i == debug_lattice) write(6,'(a)') 'Lattice debugging:' + if(i == debug_constitutive) write(6,'(a)') 'Constitutive debugging:' + if(i == debug_crystallite) write(6,'(a)') 'Crystallite debugging:' + if(i == debug_homogenization) write(6,'(a)') 'Homogenization debugging:' + if(i == debug_CPFEM) write(6,'(a)') 'CPFEM debugging:' + if(i == debug_spectral) write(6,'(a)') 'Spectral solver debugging:' -endsubroutine + if(iand(debug_what(i),debug_levelBasic) /= 0) write(6,'(a)') ' basic' + if(iand(debug_what(i),debug_levelExtensive) /= 0) write(6,'(a)') ' extensive' + if(iand(debug_what(i),debug_levelSelective) /= 0) then + write(6,'(a)') 'selective on:' + write(6,'(a24,1x,i8)') 'element: ',debug_e + write(6,'(a24,1x,i8)') 'ip: ',debug_i + write(6,'(a24,1x,i8)') 'grain: ',debug_g + endif + if(iand(debug_what(i),debug_spectralRestart) /= 0) write(6,'(a)') ' restart' + if(iand(debug_what(i),debug_spectralFFTW) /= 0) write(6,'(a)') ' FFTW' + if(iand(debug_what(i),debug_spectralDivergence)/= 0) write(6,'(a)') ' divergence' + endif + enddo + !$OMP END CRITICAL (write2out) + endif + +end subroutine debug_init !******************************************************************** ! reset debug distributions !******************************************************************** -subroutine debug_reset() +subroutine debug_reset - use prec - implicit none + implicit none - debug_StressLoopDistribution = 0_pInt ! initialize debugging data - debug_LeapfrogBreakDistribution = 0_pInt - debug_StateLoopDistribution = 0_pInt - debug_CrystalliteLoopDistribution = 0_pInt - debug_MaterialpointStateLoopDistribution = 0_pInt - debug_MaterialpointLoopDistribution = 0_pInt - debug_cumLpTicks = 0_pLongInt - debug_cumDotStateTicks = 0_pLongInt - debug_cumDotTemperatureTicks = 0_pLongInt - debug_cumLpCalls = 0_pInt - debug_cumDotStateCalls = 0_pInt - debug_cumDotTemperatureCalls = 0_pInt - debug_stressMaxLocation = 0_pInt - debug_stressMinLocation = 0_pInt - debug_jacobianMaxLocation = 0_pInt - debug_jacobianMinLocation = 0_pInt - debug_stressMax = -huge(1.0_pReal) - debug_stressMin = huge(1.0_pReal) - debug_jacobianMax = -huge(1.0_pReal) - debug_jacobianMin = huge(1.0_pReal) + debug_StressLoopDistribution = 0_pInt ! initialize debugging data + debug_LeapfrogBreakDistribution = 0_pInt + debug_StateLoopDistribution = 0_pInt + debug_CrystalliteLoopDistribution = 0_pInt + debug_MaterialpointStateLoopDistribution = 0_pInt + debug_MaterialpointLoopDistribution = 0_pInt + debug_cumLpTicks = 0_pLongInt + debug_cumDotStateTicks = 0_pLongInt + debug_cumDotTemperatureTicks = 0_pLongInt + debug_cumLpCalls = 0_pInt + debug_cumDotStateCalls = 0_pInt + debug_cumDotTemperatureCalls = 0_pInt + debug_stressMaxLocation = 0_pInt + debug_stressMinLocation = 0_pInt + debug_jacobianMaxLocation = 0_pInt + debug_jacobianMinLocation = 0_pInt + debug_stressMax = -huge(1.0_pReal) + debug_stressMin = huge(1.0_pReal) + debug_jacobianMax = -huge(1.0_pReal) + debug_jacobianMin = huge(1.0_pReal) - -endsubroutine +end subroutine debug_reset !******************************************************************** ! write debug statements to standard out !******************************************************************** -subroutine debug_info() +subroutine debug_info - use prec - use numerics, only: nStress, & - nState, & - nCryst, & - nMPstate, & - nHomog - implicit none + use numerics, only: nStress, & + nState, & + nCryst, & + nMPstate, & + nHomog - integer(pInt) i,integral - integer(pLongInt) tickrate - - call system_clock(count_rate=tickrate) + implicit none + integer(pInt) :: i,integral + integer(pLongInt) :: tickrate - if (debug_verbosity > 4) then - !$OMP CRITICAL (write2out) - - write(6,*) - write(6,*) 'DEBUG Info (from previous cycle)' - write(6,*) - write(6,'(a33,1x,i12)') 'total calls to LpAndItsTangent :',debug_cumLpCalls - if (debug_cumLpCalls > 0_pInt) then - write(6,'(a33,1x,f12.3)') 'total CPU time/s :',real(debug_cumLpTicks,pReal)& - /real(tickrate,pReal) - write(6,'(a33,1x,f12.6)') 'avg CPU time/microsecs per call :',& - real(debug_cumLpTicks,pReal)*1.0e6_pReal/real(tickrate,pReal)/real(debug_cumLpCalls,pReal) - endif - write(6,*) - write(6,'(a33,1x,i12)') 'total calls to collectDotState :',debug_cumDotStateCalls - if (debug_cumdotStateCalls > 0_pInt) then - write(6,'(a33,1x,f12.3)') 'total CPU time/s :',real(debug_cumDotStateTicks,pReal)& - /real(tickrate,pReal) - write(6,'(a33,1x,f12.6)') 'avg CPU time/microsecs per call :',& - real(debug_cumDotStateTicks,pReal)*1.0e6_pReal/real(tickrate,pReal)& - /real(debug_cumDotStateCalls,pReal) - endif - write(6,*) - write(6,'(a33,1x,i12)') 'total calls to dotTemperature :',debug_cumDotTemperatureCalls - if (debug_cumdotTemperatureCalls > 0_pInt) then - write(6,'(a33,1x,f12.3)') 'total CPU time/s :',real(debug_cumDotTemperatureTicks,pReal)& - /real(tickrate,pReal) - write(6,'(a33,1x,f12.6)') 'avg CPU time/microsecs per call :',& - real(debug_cumDotTemperatureTicks,pReal)*1.0e6_pReal/real(tickrate,pReal)& - /real(debug_cumDotTemperatureCalls,pReal) - endif + call system_clock(count_rate=tickrate) + + !$OMP CRITICAL (write2out) + if (iand(debug_what(debug_crystallite),debug_levelBasic) /= 0) then + write(6,*) + write(6,*) 'DEBUG Info (from previous cycle)' + write(6,*) + write(6,'(a33,1x,i12)') 'total calls to LpAndItsTangent :',debug_cumLpCalls + if (debug_cumLpCalls > 0_pInt) then + write(6,'(a33,1x,f12.3)') 'total CPU time/s :',real(debug_cumLpTicks,pReal)& + /real(tickrate,pReal) + write(6,'(a33,1x,f12.6)') 'avg CPU time/microsecs per call :',& + real(debug_cumLpTicks,pReal)*1.0e6_pReal/real(tickrate,pReal)/real(debug_cumLpCalls,pReal) + endif + write(6,*) + write(6,'(a33,1x,i12)') 'total calls to collectDotState :',debug_cumDotStateCalls + if (debug_cumdotStateCalls > 0_pInt) then + write(6,'(a33,1x,f12.3)') 'total CPU time/s :',real(debug_cumDotStateTicks,pReal)& + /real(tickrate,pReal) + write(6,'(a33,1x,f12.6)') 'avg CPU time/microsecs per call :',& + real(debug_cumDotStateTicks,pReal)*1.0e6_pReal/real(tickrate,pReal)& + /real(debug_cumDotStateCalls,pReal) + endif + write(6,*) + write(6,'(a33,1x,i12)') 'total calls to dotTemperature :',debug_cumDotTemperatureCalls + if (debug_cumdotTemperatureCalls > 0_pInt) then + write(6,'(a33,1x,f12.3)') 'total CPU time/s :',real(debug_cumDotTemperatureTicks,pReal)& + /real(tickrate,pReal) + write(6,'(a33,1x,f12.6)') 'avg CPU time/microsecs per call :',& + real(debug_cumDotTemperatureTicks,pReal)*1.0e6_pReal/real(tickrate,pReal)& + /real(debug_cumDotTemperatureCalls,pReal) + endif + + integral = 0_pInt + write(6,*) + write(6,*) + write(6,*) 'distribution_StressLoop : stress frogbreak stiffness frogbreak' + do i=1_pInt,nStress + if (any(debug_StressLoopDistribution(i,:) /= 0_pInt ) .or. & + any(debug_LeapfrogBreakDistribution(i,:) /= 0_pInt ) ) then + integral = integral + i*debug_StressLoopDistribution(i,1) + i*debug_StressLoopDistribution(i,2) + write(6,'(i25,1x,i10,1x,i10,1x,i10,1x,i10)') i,debug_StressLoopDistribution(i,1),debug_LeapfrogBreakDistribution(i,1), & + debug_StressLoopDistribution(i,2),debug_LeapfrogBreakDistribution(i,2) + endif + enddo + write(6,'(a15,i10,1x,i10,12x,i10)') ' total',integral,& + sum(debug_StressLoopDistribution(:,1)), & + sum(debug_StressLoopDistribution(:,2)) + + integral = 0_pInt + write(6,*) + write(6,*) 'distribution_CrystalliteStateLoop :' + do i=1_pInt,nState + if (any(debug_StateLoopDistribution(i,:) /= 0)) then + integral = integral + i*debug_StateLoopDistribution(i,1) + i*debug_StateLoopDistribution(i,2) + write(6,'(i25,1x,i10,12x,i10)') i,debug_StateLoopDistribution(i,1),debug_StateLoopDistribution(i,2) + endif + enddo + write(6,'(a15,i10,1x,i10,12x,i10)') ' total',integral,& + sum(debug_StateLoopDistribution(:,1)), & + sum(debug_StateLoopDistribution(:,2)) - integral = 0_pInt - write(6,*) - write(6,*) - write(6,*) 'distribution_StressLoop : stress frogbreak stiffness frogbreak' - do i=1_pInt,nStress - if (any(debug_StressLoopDistribution(i,:) /= 0_pInt ) .or. & - any(debug_LeapfrogBreakDistribution(i,:) /= 0_pInt ) ) then - integral = integral + i*debug_StressLoopDistribution(i,1) + i*debug_StressLoopDistribution(i,2) - write(6,'(i25,1x,i10,1x,i10,1x,i10,1x,i10)') i,debug_StressLoopDistribution(i,1),debug_LeapfrogBreakDistribution(i,1), & - debug_StressLoopDistribution(i,2),debug_LeapfrogBreakDistribution(i,2) - endif - enddo - write(6,'(a15,i10,1x,i10,12x,i10)') ' total',integral,& - sum(debug_StressLoopDistribution(:,1)), & - sum(debug_StressLoopDistribution(:,2)) - - integral = 0_pInt - write(6,*) - write(6,*) 'distribution_CrystalliteStateLoop :' - do i=1_pInt,nState - if (any(debug_StateLoopDistribution(i,:) /= 0)) then - integral = integral + i*debug_StateLoopDistribution(i,1) + i*debug_StateLoopDistribution(i,2) - write(6,'(i25,1x,i10,12x,i10)') i,debug_StateLoopDistribution(i,1),debug_StateLoopDistribution(i,2) - endif - enddo - write(6,'(a15,i10,1x,i10,12x,i10)') ' total',integral,& - sum(debug_StateLoopDistribution(:,1)), & - sum(debug_StateLoopDistribution(:,2)) + integral = 0_pInt + write(6,*) + write(6,*) 'distribution_CrystalliteCutbackLoop :' + do i=1_pInt,nCryst+1_pInt + if (debug_CrystalliteLoopDistribution(i) /= 0) then + integral = integral + i*debug_CrystalliteLoopDistribution(i) + if (i <= nCryst) then + write(6,'(i25,1x,i10)') i,debug_CrystalliteLoopDistribution(i) + else + write(6,'(i25,a1,i10)') i-1_pInt,'+',debug_CrystalliteLoopDistribution(i) + endif + endif + enddo + write(6,'(a15,i10,1x,i10)') ' total',integral,sum(debug_CrystalliteLoopDistribution) + endif - integral = 0_pInt - write(6,*) - write(6,*) 'distribution_CrystalliteCutbackLoop :' - do i=1_pInt,nCryst+1_pInt - if (debug_CrystalliteLoopDistribution(i) /= 0) then - integral = integral + i*debug_CrystalliteLoopDistribution(i) - if (i <= nCryst) then - write(6,'(i25,1x,i10)') i,debug_CrystalliteLoopDistribution(i) - else - write(6,'(i25,a1,i10)') i-1_pInt,'+',debug_CrystalliteLoopDistribution(i) - endif - endif - enddo - write(6,'(a15,i10,1x,i10)') ' total',integral,sum(debug_CrystalliteLoopDistribution) - - !$OMP END CRITICAL (write2out) - endif - - if (debug_verbosity > 2) then - !$OMP CRITICAL (write2out) - - integral = 0_pInt - write(6,*) - write(6,*) 'distribution_MaterialpointStateLoop :' - do i=1_pInt,nMPstate - if (debug_MaterialpointStateLoopDistribution(i) /= 0) then - integral = integral + i*debug_MaterialpointStateLoopDistribution(i) - write(6,'(i25,1x,i10)') i,debug_MaterialpointStateLoopDistribution(i) - endif - enddo - write(6,'(a15,i10,1x,i10)') ' total',integral,sum(debug_MaterialpointStateLoopDistribution) + if (iand(debug_what(debug_homogenization),debug_levelBasic) /= 0) then + integral = 0_pInt + write(6,*) + write(6,*) 'distribution_MaterialpointStateLoop :' + do i=1_pInt,nMPstate + if (debug_MaterialpointStateLoopDistribution(i) /= 0) then + integral = integral + i*debug_MaterialpointStateLoopDistribution(i) + write(6,'(i25,1x,i10)') i,debug_MaterialpointStateLoopDistribution(i) + endif + enddo + write(6,'(a15,i10,1x,i10)') ' total',integral,sum(debug_MaterialpointStateLoopDistribution) + + integral = 0_pInt + write(6,*) + write(6,*) 'distribution_MaterialpointCutbackLoop :' + do i=1_pInt,nHomog+1_pInt + if (debug_MaterialpointLoopDistribution(i) /= 0) then + integral = integral + i*debug_MaterialpointLoopDistribution(i) + if (i <= nHomog) then + write(6,'(i25,1x,i10)') i,debug_MaterialpointLoopDistribution(i) + else + write(6,'(i25,a1,i10)') i-1_pInt,'+',debug_MaterialpointLoopDistribution(i) + endif + endif + enddo + write(6,'(a15,i10,1x,i10)') ' total',integral,sum(debug_MaterialpointLoopDistribution) - integral = 0_pInt - write(6,*) - write(6,*) 'distribution_MaterialpointCutbackLoop :' - do i=1_pInt,nHomog+1_pInt - if (debug_MaterialpointLoopDistribution(i) /= 0) then - integral = integral + i*debug_MaterialpointLoopDistribution(i) - if (i <= nHomog) then - write(6,'(i25,1x,i10)') i,debug_MaterialpointLoopDistribution(i) - else - write(6,'(i25,a1,i10)') i-1_pInt,'+',debug_MaterialpointLoopDistribution(i) - endif - endif - enddo - write(6,'(a15,i10,1x,i10)') ' total',integral,sum(debug_MaterialpointLoopDistribution) - - write(6,*) - write(6,*) - write(6,*) 'Extreme values of returned stress and jacobian' - write(6,*) - write(6,'(a39)') ' value el ip' - write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') 'stress min :', debug_stressMin, debug_stressMinLocation - write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') ' max :', debug_stressMax, debug_stressMaxLocation - write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') 'jacobian min :', debug_jacobianMin, debug_jacobianMinLocation - write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') ' max :', debug_jacobianMax, debug_jacobianMaxLocation - write(6,*) - - !$OMP END CRITICAL (write2out) - endif - -endsubroutine + write(6,*) + write(6,*) + write(6,*) 'Extreme values of returned stress and jacobian' + write(6,*) + write(6,'(a39)') ' value el ip' + write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') 'stress min :', debug_stressMin, debug_stressMinLocation + write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') ' max :', debug_stressMax, debug_stressMaxLocation + write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') 'jacobian min :', debug_jacobianMin, debug_jacobianMinLocation + write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') ' max :', debug_jacobianMax, debug_jacobianMaxLocation + write(6,*) + endif + !$OMP END CRITICAL (write2out) -END MODULE debug +end subroutine debug_info + +end module debug diff --git a/code/homogenization.f90 b/code/homogenization.f90 index b2c5bbca1..ecc6d2806 100644 --- a/code/homogenization.f90 +++ b/code/homogenization.f90 @@ -73,9 +73,8 @@ CONTAINS !************************************** subroutine homogenization_init(Temperature) use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) -use prec, only: pReal,pInt use math, only: math_I3 -use debug, only: debug_verbosity +use debug, only: debug_what, debug_homogenization, debug_levelBasic use IO, only: IO_error, IO_open_file, IO_open_jobFile_stat, IO_write_jobFile use mesh, only: mesh_maxNips,mesh_NcpElems,mesh_element,FE_Nips use material @@ -207,7 +206,7 @@ allocate(materialpoint_results(materialpoint_sizeResults,mesh_maxNips,mesh_NcpEl write(6,*) '<<<+- homogenization init -+>>>' write(6,*) '$Id$' #include "compilation_info.f90" - if (debug_verbosity > 0) then + if (iand(debug_what(debug_homogenization), debug_levelBasic) /= 0_pInt) then write(6,'(a32,1x,7(i8,1x))') 'homogenization_state0: ', shape(homogenization_state0) write(6,'(a32,1x,7(i8,1x))') 'homogenization_subState0: ', shape(homogenization_subState0) write(6,'(a32,1x,7(i8,1x))') 'homogenization_state: ', shape(homogenization_state) @@ -249,8 +248,6 @@ subroutine materialpoint_stressAndItsTangent(& dt & ! time increment ) - use prec, only: pInt, & - pReal use numerics, only: subStepMinHomog, & subStepSizeHomog, & stepIncreaseHomog, & @@ -289,10 +286,12 @@ subroutine materialpoint_stressAndItsTangent(& crystallite_converged, & crystallite_stressAndItsTangent, & crystallite_orientations -use debug, only: debug_verbosity, & +use debug, only: debug_what, & + debug_homogenization, & + debug_levelBasic, & + debug_levelSelective, & debug_e, & debug_i, & - debug_selectiveDebugger, & debug_MaterialpointLoopDistribution, & debug_MaterialpointStateLoopDistribution use math, only: math_pDecomposition @@ -306,7 +305,8 @@ use debug, only: debug_verbosity, & ! ------ initialize to starting condition ------ - if (debug_verbosity > 2 .and. debug_e > 0 .and. debug_e <= mesh_NcpElems .and. debug_i > 0 .and. debug_i <= mesh_maxNips) then + if (iand(debug_what(debug_homogenization), debug_levelBasic) /= 0_pInt & + .and. debug_e > 0 .and. debug_e <= mesh_NcpElems .and. debug_i > 0 .and. debug_i <= mesh_maxNips) then !$OMP CRITICAL (write2out) write (6,*) write (6,'(a,i5,1x,i2)') '<< HOMOG >> Material Point start at el ip ', debug_e, debug_i @@ -358,7 +358,9 @@ use debug, only: debug_verbosity, & if ( materialpoint_converged(i,e) ) then #ifndef _OPENMP - if (debug_verbosity > 2 .and. ((e == debug_e .and. i == debug_i) .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_homogenization), debug_levelBasic) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i) & + .or. .not. iand(debug_what(debug_homogenization),debug_levelSelective) /= 0_pInt)) then write(6,'(a,1x,f12.8,1x,a,1x,f12.8,1x,a,/)') '<< HOMOG >> winding forward from', & materialpoint_subFrac(i,e), 'to current materialpoint_subFrac', & materialpoint_subFrac(i,e)+materialpoint_subStep(i,e),'in materialpoint_stressAndItsTangent' @@ -388,7 +390,7 @@ use debug, only: debug_verbosity, & materialpoint_subF0(1:3,1:3,i,e) = materialpoint_subF(1:3,1:3,i,e) ! ...def grad !$OMP FLUSH(materialpoint_subF0) elseif (materialpoint_requested(i,e)) then ! this materialpoint just converged ! already at final time (??) - if (debug_verbosity > 2) then + if (iand(debug_what(debug_homogenization), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (distributionHomog) debug_MaterialpointLoopDistribution(min(nHomog+1,NiterationHomog)) = & debug_MaterialpointLoopDistribution(min(nHomog+1,NiterationHomog)) + 1 @@ -402,6 +404,7 @@ use debug, only: debug_verbosity, & subStepSizeHomog * materialpoint_subStep(i,e) <= subStepMinHomog ) then ! would require too small subStep ! cutback makes no sense and... !$OMP CRITICAL (setTerminallyIll) + write(6,*) 'Integration point ', i,' at element ', e, ' terminally ill' terminallyIll = .true. ! ...one kills all !$OMP END CRITICAL (setTerminallyIll) else ! cutback makes sense @@ -409,7 +412,9 @@ use debug, only: debug_verbosity, & !$OMP FLUSH(materialpoint_subStep) #ifndef _OPENMP - if (debug_verbosity > 2 .and. ((e == debug_e .and. i == debug_i) .or. .not. debug_selectiveDebugger)) then + if (iand(debug_what(debug_homogenization), debug_levelBasic) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i) & + .or. .not. iand(debug_what(debug_homogenization), debug_levelSelective) /= 0_pInt)) then write(6,'(a,1x,f12.8,/)') & '<< HOMOG >> cutback step in materialpoint_stressAndItsTangent with new materialpoint_subStep:',& materialpoint_subStep(i,e) @@ -499,7 +504,7 @@ use debug, only: debug_verbosity, & endif !$OMP FLUSH(materialpoint_converged) if (materialpoint_converged(i,e)) then - if (debug_verbosity > 2) then + if (iand(debug_what(debug_homogenization), debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (distributionMPState) debug_MaterialpointStateLoopdistribution(NiterationMPstate) = & debug_MaterialpointStateLoopdistribution(NiterationMPstate) + 1 @@ -594,7 +599,6 @@ subroutine homogenization_partitionDeformation(& el & ! element ) - use prec, only: pInt use mesh, only: mesh_element use material, only: homogenization_type, homogenization_maxNgrains use crystallite, only: crystallite_partionedF0,crystallite_partionedF @@ -635,7 +639,6 @@ function homogenization_updateState(& ip, & ! integration point el & ! element ) - use prec, only: pInt use mesh, only: mesh_element use material, only: homogenization_type, homogenization_maxNgrains use crystallite, only: crystallite_P,crystallite_dPdF,crystallite_partionedF,crystallite_partionedF0 ! modified <<>> @@ -683,7 +686,6 @@ subroutine homogenization_averageStressAndItsTangent(& ip, & ! integration point el & ! element ) - use prec, only: pInt use mesh, only: mesh_element use material, only: homogenization_type, homogenization_maxNgrains use crystallite, only: crystallite_P,crystallite_dPdF @@ -725,7 +727,6 @@ subroutine homogenization_averageTemperature(& ip, & ! integration point el & ! element ) - use prec, only: pInt use mesh, only: mesh_element use material, only: homogenization_type, homogenization_maxNgrains use crystallite, only: crystallite_Temperature @@ -760,7 +761,6 @@ function homogenization_postResults(& ip, & ! integration point el & ! element ) - use prec, only: pReal,pInt use mesh, only: mesh_element use material, only: homogenization_type use homogenization_isostrain diff --git a/code/homogenization_RGC.f90 b/code/homogenization_RGC.f90 index 2fd104318..cea1f3ae3 100644 --- a/code/homogenization_RGC.f90 +++ b/code/homogenization_RGC.f90 @@ -33,8 +33,8 @@ MODULE homogenization_RGC !*** Include other modules *** use prec, only: pReal,pInt - implicit none + implicit none character (len=*), parameter :: homogenization_RGC_label = 'rgc' integer(pInt), dimension(:), allocatable :: homogenization_RGC_sizeState, & @@ -67,12 +67,21 @@ subroutine homogenization_RGC_init(& ) use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) - use prec, only: pInt, pReal - use debug, only: debug_verbosity - use math, only: math_Mandel3333to66, math_Voigt66to3333,math_I3,math_sampleRandomOri,math_EulerToR,inRad + use debug, only: debug_what, & + debug_homogenization, & + debug_levelBasic, & + debug_levelExtensive + use math, only: math_Mandel3333to66,& + math_Voigt66to3333, & + math_I3, & + math_sampleRandomOri,& + math_EulerToR,& + INRAD use mesh, only: mesh_maxNips,mesh_NcpElems,mesh_element,FE_Nips use IO use material + + implicit none integer(pInt), intent(in) :: myFile integer(pInt), parameter :: maxNchunks = 4_pInt integer(pInt), dimension(1_pInt+2_pInt*maxNchunks) :: positions @@ -170,7 +179,7 @@ subroutine homogenization_RGC_init(& endif enddo -100 if (debug_verbosity == 4_pInt) then +100 if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) do i = 1_pInt,maxNinstance write(6,'(a15,1x,i4)') 'instance: ', i @@ -227,9 +236,8 @@ endsubroutine !* initial homogenization state * !********************************************************************* function homogenization_RGC_stateInit(myInstance) - use prec, only: pReal,pInt - implicit none + implicit none !* Definition of variables integer(pInt), intent(in) :: myInstance real(pReal), dimension(homogenization_RGC_sizeState(myInstance)) :: homogenization_RGC_stateInit @@ -253,8 +261,10 @@ subroutine homogenization_RGC_partitionDeformation(& ip, & ! my integration point el & ! my element ) - use prec, only: pReal,pInt,p_vec - use debug, only: debug_verbosity + use prec, only: p_vec + use debug, only: debug_what, & + debug_homogenization, & + debug_levelExtensive use mesh, only: mesh_element use material, only: homogenization_maxNgrains,homogenization_Ngrains,homogenization_typeInstance use FEsolving, only: theInc,cycleCounter @@ -277,7 +287,7 @@ subroutine homogenization_RGC_partitionDeformation(& !* Debugging the overall deformation gradient - if (debug_verbosity == 4_pInt) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a,i3,a,i3,a)')'========== Increment: ',theInc,' Cycle: ',cycleCounter,' ==========' write(6,'(1x,a32)')'Overall deformation gradient: ' @@ -304,7 +314,7 @@ subroutine homogenization_RGC_partitionDeformation(& F(:,:,iGrain) = F(:,:,iGrain) + avgF(:,:) ! resulting relaxed deformation gradient !* Debugging the grain deformation gradients - if (debug_verbosity == 4_pInt) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a32,1x,i3)')'Deformation gradient of grain: ',iGrain do i = 1_pInt,3_pInt @@ -338,7 +348,11 @@ function homogenization_RGC_updateState(& ) use prec, only: pReal,pInt,p_vec - use debug, only: debug_verbosity, debug_e, debug_i + use debug, only: debug_what, & + debug_homogenization,& + debug_levelExtensive, & + debug_e, & + debug_i use math, only: math_invert use mesh, only: mesh_element use material, only: homogenization_maxNgrains,homogenization_typeInstance, & @@ -390,7 +404,7 @@ function homogenization_RGC_updateState(& drelax = state%p(1:3_pInt*nIntFaceTot) - state0%p(1:3_pInt*nIntFaceTot) !* Debugging the obtained state - if (debug_verbosity == 4_pInt) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Obtained state: ' do i = 1_pInt,3_pInt*nIntFaceTot @@ -407,7 +421,7 @@ function homogenization_RGC_updateState(& call homogenization_RGC_volumePenalty(D,volDiscrep,F,avgF,ip,el,homID) !* Debugging the mismatch, stress and penalties of grains - if (debug_verbosity == 4_pInt) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) do iGrain = 1_pInt,nGrain write(6,'(1x,a30,1x,i3,1x,a4,3(1x,e15.8))')'Mismatch magnitude of grain(',iGrain,') :',NN(1,iGrain),NN(2,iGrain),NN(3,iGrain) @@ -456,7 +470,7 @@ function homogenization_RGC_updateState(& enddo !* Debugging the residual stress - if (debug_verbosity == 4_pInt) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a30,1x,i3)')'Traction at interface: ',iNum write(6,'(1x,3(e15.8,1x))')(tract(iNum,j), j = 1_pInt,3_pInt) @@ -474,7 +488,8 @@ function homogenization_RGC_updateState(& residLoc = int(maxloc(abs(tract)),pInt) ! get the position of the maximum residual !* Debugging the convergent criteria - if (debug_verbosity == 4_pInt .and. debug_e == el .and. debug_i == ip) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then !$OMP CRITICAL (write2out) write(6,'(1x,a)')' ' write(6,'(1x,a,1x,i2,1x,i4)')'RGC residual check ...',ip,el @@ -491,7 +506,8 @@ function homogenization_RGC_updateState(& if (residMax < relTol_RGC*stresMax .or. residMax < absTol_RGC) then homogenization_RGC_updateState = .true. - if (debug_verbosity == 4 .and. debug_e == el .and. debug_i == ip) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then !$OMP CRITICAL (write2out) write(6,'(1x,a55)')'... done and happy' write(6,*)' ' @@ -521,7 +537,8 @@ function homogenization_RGC_updateState(& state%p(3*nIntFaceTot+7) = sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) ! the average rate of relaxation vectors state%p(3*nIntFaceTot+8) = maxval(abs(drelax))/dt ! the maximum rate of relaxation vectors - if (debug_verbosity == 4_pInt .and. debug_e == el .and. debug_i == ip) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then !$OMP CRITICAL (write2out) write(6,'(1x,a30,1x,e15.8)')'Constitutive work: ',constitutiveWork write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',sum(NN(1,:))/real(nGrain,pReal), & @@ -545,7 +562,8 @@ function homogenization_RGC_updateState(& !* Try to restart when residual blows up exceeding maximum bound homogenization_RGC_updateState = (/.true.,.false./) ! with direct cut-back - if (debug_verbosity == 4 .and. debug_e == el .and. debug_i == ip) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then !$OMP CRITICAL (write2out) write(6,'(1x,a55)')'... broken' write(6,*)' ' @@ -559,7 +577,8 @@ function homogenization_RGC_updateState(& !* Otherwise, proceed with computing the Jacobian and state update else - if (debug_verbosity == 4 .and. debug_e == el .and. debug_i == ip) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then !$OMP CRITICAL (write2out) write(6,'(1x,a55)')'... not yet done' write(6,*)' ' @@ -615,7 +634,7 @@ function homogenization_RGC_updateState(& enddo !* Debugging the global Jacobian matrix of stress tangent - if (debug_verbosity == 4_pInt) then + if (iand(debug_what(debug_homogenization),debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Jacobian matrix of stress' do i = 1_pInt,3_pInt*nIntFaceTot @@ -671,7 +690,7 @@ function homogenization_RGC_updateState(& enddo !* Debugging the global Jacobian matrix of penalty tangent - if (debug_verbosity == 4) then + if (iand(debug_what(debug_homogenization), debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Jacobian matrix of penalty' do i = 1_pInt,3_pInt*nIntFaceTot @@ -691,7 +710,7 @@ function homogenization_RGC_updateState(& ! only in the main diagonal term !* Debugging the global Jacobian matrix of numerical viscosity tangent - if (debug_verbosity == 4_pInt) then + if (iand(debug_what(debug_homogenization), debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Jacobian matrix of penalty' do i = 1_pInt,3_pInt*nIntFaceTot @@ -705,7 +724,7 @@ function homogenization_RGC_updateState(& !* The overall Jacobian matrix summarizing contributions of smatrix, pmatrix, rmatrix allocate(jmatrix(3*nIntFaceTot,3*nIntFaceTot)); jmatrix = smatrix + pmatrix + rmatrix - if (debug_verbosity == 4) then + if (iand(debug_what(debug_homogenization), debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Jacobian matrix (total)' do i = 1_pInt,3_pInt*nIntFaceTot @@ -724,7 +743,7 @@ function homogenization_RGC_updateState(& call math_invert(3_pInt*nIntFaceTot,jmatrix,jnverse,ival,error) ! Compute the inverse of the overall Jacobian matrix !* Debugging the inverse Jacobian matrix - if (debug_verbosity == 4_pInt) then + if (iand(debug_what(debug_homogenization), debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Jacobian inverse' do i = 1_pInt,3_pInt*nIntFaceTot @@ -754,7 +773,7 @@ function homogenization_RGC_updateState(& endif !* Debugging the return state - if (debug_verbosity == 4_pInt) then + if (iand(debug_homogenization, debug_levelExtensive) > 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Returned state: ' do i = 1_pInt,3_pInt*nIntFaceTot @@ -784,13 +803,14 @@ subroutine homogenization_RGC_averageStressAndItsTangent(& ) use prec, only: pReal,pInt,p_vec - use debug, only: debug_verbosity + use debug, only: debug_what, & + debug_homogenization,& + debug_levelExtensive use mesh, only: mesh_element use material, only: homogenization_maxNgrains,homogenization_Ngrains,homogenization_typeInstance use math, only: math_Plain3333to99 + implicit none - -!* Definition of variables real(pReal), dimension (3,3), intent(out) :: avgP real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: P @@ -804,7 +824,7 @@ subroutine homogenization_RGC_averageStressAndItsTangent(& Ngrains = homogenization_Ngrains(mesh_element(3,el)) !* Debugging the grain tangent - if (debug_verbosity == 4_pInt) then + if (iand(debug_what(debug_homogenization), debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) do iGrain = 1_pInt,Ngrains dPdF99 = math_Plain3333to99(dPdF(1:3,1:3,1:3,1:3,iGrain)) @@ -836,9 +856,8 @@ function homogenization_RGC_averageTemperature(& use prec, only: pReal,pInt,p_vec use mesh, only: mesh_element use material, only: homogenization_maxNgrains, homogenization_Ngrains + implicit none - -!* Definition of variables real(pReal), dimension (homogenization_maxNgrains), intent(in) :: Temperature integer(pInt), intent(in) :: ip,el real(pReal) homogenization_RGC_averageTemperature @@ -862,9 +881,8 @@ pure function homogenization_RGC_postResults(& use prec, only: pReal,pInt,p_vec use mesh, only: mesh_element use material, only: homogenization_typeInstance,homogenization_Noutput + implicit none - -!* Definition of variables type(p_vec), intent(in) :: state integer(pInt), intent(in) :: ip,el ! @@ -925,9 +943,8 @@ subroutine homogenization_RGC_stressPenalty(& use math, only: math_civita,math_invert33 use material, only: homogenization_maxNgrains,homogenization_Ngrains use numerics, only: xSmoo_RGC + implicit none - -!* Definition of variables real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: rPen real(pReal), dimension (3,homogenization_maxNgrains), intent(out) :: nMis real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef @@ -1059,8 +1076,6 @@ subroutine homogenization_RGC_volumePenalty(& use numerics, only: maxVolDiscr_RGC,volDiscrMod_RGC,volDiscrPow_RGC implicit none - -!* Definition of variables real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: vPen real(pReal), intent(out) :: vDiscrep real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef @@ -1109,9 +1124,8 @@ function homogenization_RGC_surfaceCorrection(& use prec, only: pReal,pInt,p_vec use math, only: math_invert33,math_mul33x33 + implicit none - -!* Definition of variables real(pReal), dimension(3,3), intent(in) :: avgF real(pReal), dimension(3) :: homogenization_RGC_surfaceCorrection integer(pInt), intent(in) :: ip,el @@ -1154,9 +1168,8 @@ function homogenization_RGC_equivalentModuli(& use prec, only: pReal,pInt,p_vec use constitutive, only: constitutive_homogenizedC,constitutive_averageBurgers - implicit none -!* Definition of variables + implicit none integer(pInt), intent(in) :: grainID,ip,el real(pReal), dimension (6,6) :: elasTens real(pReal), dimension(2) :: homogenization_RGC_equivalentModuli @@ -1186,9 +1199,8 @@ function homogenization_RGC_relaxationVector(& ) use prec, only: pReal,pInt,p_vec + implicit none - -!* Definition of variables real(pReal), dimension (3) :: homogenization_RGC_relaxationVector integer(pInt), dimension (4), intent(in) :: intFace type(p_vec), intent(in) :: state @@ -1215,9 +1227,8 @@ function homogenization_RGC_interfaceNormal(& use prec, only: pReal,pInt,p_vec use math, only: math_mul33x3 + implicit none - -!* Definition of variables real(pReal), dimension (3) :: homogenization_RGC_interfaceNormal integer(pInt), dimension (4), intent(in) :: intFace integer(pInt), intent(in) :: ip,el @@ -1249,9 +1260,8 @@ function homogenization_RGC_getInterface(& iGrain3 & ! grain ID in 3D array ) use prec, only: pReal,pInt,p_vec + implicit none - -!* Definition of variables integer(pInt), dimension (4) :: homogenization_RGC_getInterface integer(pInt), dimension (3), intent(in) :: iGrain3 integer(pInt), intent(in) :: iFace @@ -1277,9 +1287,8 @@ function homogenization_RGC_grain1to3(& ) use prec, only: pInt,p_vec + implicit none - -!* Definition of variables integer(pInt), dimension (3) :: homogenization_RGC_grain1to3 integer(pInt), intent(in) :: grain1,homID integer(pInt), dimension (3) :: nGDim @@ -1301,9 +1310,8 @@ function homogenization_RGC_grain3to1(& ) use prec, only: pInt,p_vec - implicit none -!* Definition of variables + implicit none integer(pInt), dimension (3), intent(in) :: grain3 integer(pInt) :: homogenization_RGC_grain3to1 integer(pInt), dimension (3) :: nGDim @@ -1324,9 +1332,8 @@ function homogenization_RGC_interface4to1(& ) use prec, only: pInt,p_vec + implicit none - -!* Definition of variables integer(pInt), dimension (4), intent(in) :: iFace4D integer(pInt) :: homogenization_RGC_interface4to1 integer(pInt), dimension (3) :: nGDim,nIntFace @@ -1364,9 +1371,8 @@ function homogenization_RGC_interface1to4(& ) use prec, only: pReal,pInt,p_vec + implicit none - -!* Definition of variables integer(pInt), dimension (4) :: homogenization_RGC_interface1to4 integer(pInt), intent(in) :: iFace1D integer(pInt), dimension (3) :: nGDim,nIntFace @@ -1442,9 +1448,8 @@ subroutine homogenization_RGC_grainDeformation(& use prec, only: pReal,pInt,p_vec use mesh, only: mesh_element use material, only: homogenization_maxNgrains,homogenization_Ngrains,homogenization_typeInstance + implicit none - -!* Definition of variables real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: F0 real(pReal), dimension (3,3), intent(in) :: avgF diff --git a/code/homogenization_isostrain.f90 b/code/homogenization_isostrain.f90 index b5df2e9ce..58cb7003e 100644 --- a/code/homogenization_isostrain.f90 +++ b/code/homogenization_isostrain.f90 @@ -29,22 +29,27 @@ ! Ngrains 6 ! (output) Ngrains -MODULE homogenization_isostrain +module homogenization_isostrain -!*** Include other modules *** - use prec, only: pReal,pInt - implicit none - - character (len=*), parameter :: homogenization_isostrain_label = 'isostrain' + use prec, only: pInt - integer(pInt), dimension(:), allocatable :: homogenization_isostrain_sizeState, & - homogenization_isostrain_Ngrains - integer(pInt), dimension(:), allocatable :: homogenization_isostrain_sizePostResults - integer(pInt), dimension(:,:), allocatable,target :: homogenization_isostrain_sizePostResult - character(len=64), dimension(:,:), allocatable,target :: homogenization_isostrain_output ! name of each post result output + implicit none + character (len=*), parameter :: & + homogenization_isostrain_label = 'isostrain' + + integer(pInt),dimension(:), allocatable :: & + homogenization_isostrain_sizeState, & + homogenization_isostrain_Ngrains, & + homogenization_isostrain_sizePostResults + + integer(pInt), dimension(:,:), allocatable, target :: & + homogenization_isostrain_sizePostResult + + character(len=64), dimension(:,:), allocatable, target :: & + homogenization_isostrain_output ! name of each post result output -CONTAINS +contains !**************************************** !* - homogenization_isostrain_init !* - homogenization_isostrain_stateInit @@ -58,9 +63,7 @@ CONTAINS !************************************** !* Module initialization * !************************************** -subroutine homogenization_isostrain_init(& - myFile & ! file pointer to material configuration - ) +subroutine homogenization_isostrain_init(myFile) ! file pointer to material configuration use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) use prec, only: pInt use math, only: math_Mandel3333to66, math_Voigt66to3333 @@ -71,8 +74,8 @@ subroutine homogenization_isostrain_init(& integer(pInt), dimension(1_pInt+2_pInt*maxNchunks) :: positions integer(pInt) section, i, j, output, mySize integer :: maxNinstance, k !no pInt (stores a system dependen value from 'count' - character(len=64) tag - character(len=1024) line + character(len=64) :: tag + character(len=1024) :: line !$OMP CRITICAL (write2out) write(6,*) @@ -93,7 +96,6 @@ subroutine homogenization_isostrain_init(& maxNinstance)) ; homogenization_isostrain_output = '' rewind(myFile) - line = '' section = 0_pInt do while (IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization) ! wind forward to @@ -144,9 +146,7 @@ subroutine homogenization_isostrain_init(& enddo enddo - return - -endsubroutine +end subroutine homogenization_isostrain_init !********************************************************************* @@ -154,18 +154,15 @@ endsubroutine !********************************************************************* function homogenization_isostrain_stateInit(myInstance) use prec, only: pReal,pInt + implicit none - -!* Definition of variables integer(pInt), intent(in) :: myInstance real(pReal), dimension(homogenization_isostrain_sizeState(myInstance)) :: & homogenization_isostrain_stateInit homogenization_isostrain_stateInit = 0.0_pReal - return - -endfunction +endfunction homogenization_isostrain_stateInit !******************************************************************** @@ -183,9 +180,8 @@ subroutine homogenization_isostrain_partitionDeformation(& use prec, only: pReal,pInt,p_vec use mesh, only: mesh_element use material, only: homogenization_maxNgrains,homogenization_Ngrains + implicit none - -!* Definition of variables real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: F0 real(pReal), dimension (3,3), intent(in) :: avgF @@ -197,9 +193,7 @@ subroutine homogenization_isostrain_partitionDeformation(& forall (i = 1_pInt:homogenization_Ngrains(mesh_element(3,el))) & F(1:3,1:3,i) = avgF - return - -endsubroutine +end subroutine homogenization_isostrain_partitionDeformation !******************************************************************** @@ -229,10 +223,8 @@ function homogenization_isostrain_updateState(& ! homID = homogenization_typeInstance(mesh_element(3,el)) homogenization_isostrain_updateState = .true. ! homogenization at material point converged (done and happy) - - return -endfunction +end function homogenization_isostrain_updateState !******************************************************************** @@ -251,9 +243,8 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(& use prec, only: pReal,pInt,p_vec use mesh, only: mesh_element use material, only: homogenization_maxNgrains, homogenization_Ngrains + implicit none - -!* Definition of variables real(pReal), dimension (3,3), intent(out) :: avgP real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: P @@ -266,9 +257,7 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(& avgP = sum(P,3)/real(Ngrains,pReal) dAvgPdAvgF = sum(dPdF,5)/real(Ngrains,pReal) - return - -endsubroutine +end subroutine homogenization_isostrain_averageStressAndItsTangent !******************************************************************** @@ -283,9 +272,8 @@ function homogenization_isostrain_averageTemperature(& use prec, only: pReal,pInt,p_vec use mesh, only: mesh_element use material, only: homogenization_maxNgrains, homogenization_Ngrains + implicit none - -!* Definition of variables real(pReal), dimension (homogenization_maxNgrains), intent(in) :: Temperature integer(pInt), intent(in) :: ip,el real(pReal) homogenization_isostrain_averageTemperature @@ -295,9 +283,7 @@ function homogenization_isostrain_averageTemperature(& Ngrains = homogenization_Ngrains(mesh_element(3,el)) homogenization_isostrain_averageTemperature = sum(Temperature(1:Ngrains))/real(Ngrains,pReal) - return - -endfunction +end function homogenization_isostrain_averageTemperature !******************************************************************** @@ -312,17 +298,15 @@ pure function homogenization_isostrain_postResults(& use prec, only: pReal,pInt,p_vec use mesh, only: mesh_element use material, only: homogenization_typeInstance,homogenization_Noutput + implicit none - -!* Definition of variables type(p_vec), intent(in) :: state integer(pInt), intent(in) :: ip,el - integer(pInt) homID,o,c - real(pReal), dimension(homogenization_isostrain_sizePostResults(homogenization_typeInstance(mesh_element(3,el)))) :: & - homogenization_isostrain_postResults - - homID = homogenization_typeInstance(mesh_element(3,el)) + integer(pInt) :: homID,o,c + real(pReal), dimension(homogenization_isostrain_sizePostResults& + (homogenization_typeInstance(mesh_element(3,el)))) :: homogenization_isostrain_postResults c = 0_pInt + homID = homogenization_typeInstance(mesh_element(3,el)) homogenization_isostrain_postResults = 0.0_pReal do o = 1_pInt,homogenization_Noutput(mesh_element(3,el)) @@ -335,6 +319,6 @@ pure function homogenization_isostrain_postResults(& return -endfunction +end function homogenization_isostrain_postResults -END MODULE +end module homogenization_isostrain diff --git a/code/lattice.f90 b/code/lattice.f90 index 5856fef76..7defd6780 100644 --- a/code/lattice.f90 +++ b/code/lattice.f90 @@ -27,56 +27,64 @@ !* - Schmid matrices calculation * !************************************ -MODULE lattice +module lattice -!*** Include other modules *** -use prec, only: pReal,pInt -implicit none + use prec, only: pReal,pInt + implicit none !************************************ !* Lattice structures * !************************************ -integer(pInt) lattice_Nhexagonal, & ! # of hexagonal lattice structure (from tag CoverA_ratio) - lattice_Nstructure ! # of lattice structures (1: fcc,2: bcc,3+: hexagonal) -integer(pInt), parameter :: lattice_maxNslipFamily = 5_pInt ! max # of slip system families over lattice structures -integer(pInt), parameter :: lattice_maxNtwinFamily = 4_pInt ! max # of twin system families over lattice structures -integer(pInt), parameter :: lattice_maxNslip = 54_pInt ! max # of slip systems over lattice structures -integer(pInt), parameter :: lattice_maxNtwin = 24_pInt ! max # of twin systems over lattice structures -integer(pInt), parameter :: lattice_maxNinteraction = 30_pInt ! max # of interaction types (in hardening matrix part) + integer(pInt) :: & + lattice_Nhexagonal, & !> # of hexagonal lattice structure (from tag CoverA_ratio) + lattice_Nstructure !> # of lattice structures (1: fcc,2: bcc,3+: hexagonal) -integer(pInt), pointer, dimension(:,:) :: interactionSlipSlip, & - interactionSlipTwin, & - interactionTwinSlip, & - interactionTwinTwin + integer(pInt), parameter :: & + lattice_maxNslipFamily = 5_pInt, & !> max # of slip system families over lattice structures + lattice_maxNtwinFamily = 4_pInt, & !> max # of twin system families over lattice structures + lattice_maxNslip = 54_pInt, & !> max # of slip systems over lattice structures + lattice_maxNtwin = 24_pInt, & !> max # of twin systems over lattice structures + lattice_maxNinteraction = 30_pInt !> max # of interaction types (in hardening matrix part) -! Schmid matrices, normal, shear direction and d x n of slip systems -real(pReal), allocatable, dimension(:,:,:,:) :: lattice_Sslip -real(pReal), allocatable, dimension(:,:,:) :: lattice_Sslip_v -real(pReal), allocatable, dimension(:,:,:) :: lattice_sn, & - lattice_sd, & - lattice_st + integer(pInt), pointer, dimension(:,:) :: & + interactionSlipSlip, & + interactionSlipTwin, & + interactionTwinSlip, & + interactionTwinTwin + + real(pReal), allocatable, dimension(:,:,:,:) :: & + lattice_Sslip ! Schmid matrices, normal, shear direction and d x n of slip systems + + real(pReal), allocatable, dimension(:,:,:) :: & + lattice_Sslip_v, & + lattice_sn, & + lattice_sd, & + lattice_st ! rotation and Schmid matrices, normal, shear direction and d x n of twin systems -real(pReal), allocatable, dimension(:,:,:,:) :: lattice_Qtwin -real(pReal), allocatable, dimension(:,:,:,:) :: lattice_Stwin -real(pReal), allocatable, dimension(:,:,:) :: lattice_Stwin_v -real(pReal), allocatable, dimension(:,:,:) :: lattice_tn, & - lattice_td, & - lattice_tt + real(pReal), allocatable, dimension(:,:,:,:) :: & + lattice_Qtwin, & + lattice_Stwin -! characteristic twin shear -real(pReal), allocatable, dimension(:,:) :: lattice_shearTwin + real(pReal), allocatable, dimension(:,:,:) :: & + lattice_Stwin_v, & + lattice_tn, & + lattice_td, & + lattice_tt -! number of slip and twin systems in each family -integer(pInt), allocatable, dimension(:,:) :: lattice_NslipSystem, & - lattice_NtwinSystem + real(pReal), allocatable, dimension(:,:) :: & + lattice_shearTwin !> characteristic twin shear -! interaction type of slip and twin systems among each other -integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & - lattice_interactionSlipTwin, & - lattice_interactionTwinSlip, & - lattice_interactionTwinTwin + integer(pInt), allocatable, dimension(:,:) :: & + lattice_NslipSystem, & !> number of slip systems in each family + lattice_NtwinSystem !> number of twin systems in each family + + integer(pInt), allocatable, dimension(:,:,:) :: & + lattice_interactionSlipSlip, & !> interaction type between slip/slip + lattice_interactionSlipTwin, & !> interaction type between slip/twin + lattice_interactionTwinSlip, & !> interaction type between twin/slip + lattice_interactionTwinTwin !> interaction type between twin/twin !============================== fcc (1) ================================= @@ -698,16 +706,15 @@ CONTAINS !* - lattice_initializeStructure !**************************************** -pure function lattice_symmetryType(structID) +integer(pInt) pure function lattice_symmetryType(structID) !************************************** !* maps structure to symmetry type * !* fcc(1) and bcc(2) are cubic(1) * !* hex(3+) is hexagonal(2) * !************************************** + implicit none - integer(pInt), intent(in) :: structID - integer(pInt) lattice_symmetryType select case(structID) case (1_pInt,2_pInt) @@ -720,21 +727,29 @@ pure function lattice_symmetryType(structID) return -end function +end function lattice_symmetryType -subroutine lattice_init() +subroutine lattice_init !************************************** !* Module initialization * !************************************** use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) - use IO, only: IO_open_file,IO_open_jobFile_stat,IO_countSections,IO_countTagInPart,IO_error - use material, only: material_configfile,material_localFileExt,material_partPhase - use debug, only: debug_verbosity + use IO, only: IO_open_file,& + IO_open_jobFile_stat, & + IO_countSections, & + IO_countTagInPart, & + IO_error + use material, only: material_configfile, & + material_localFileExt, & + material_partPhase + use debug, only: debug_what, & + debug_lattice, & + debug_levelBasic + implicit none - integer(pInt), parameter :: fileunit = 200_pInt - integer(pInt) Nsections + integer(pInt) :: Nsections !$OMP CRITICAL (write2out) write(6,*) @@ -751,7 +766,7 @@ subroutine lattice_init() ! lattice_Nstructure = Nsections + 2_pInt ! most conservative assumption close(fileunit) - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_lattice),debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a16,1x,i5)') '# phases:',Nsections write(6,'(a16,1x,i5)') '# structures:',lattice_Nstructure @@ -782,19 +797,25 @@ subroutine lattice_init() allocate(lattice_interactionTwinSlip(lattice_maxNslip,lattice_maxNtwin,lattice_Nstructure)); lattice_interactionTwinSlip = 0_pInt ! other:me allocate(lattice_interactionTwinTwin(lattice_maxNtwin,lattice_maxNtwin,lattice_Nstructure)); lattice_interactionTwinTwin = 0_pInt ! other:me -end subroutine +end subroutine lattice_init -function lattice_initializeStructure(struct,CoverA) +integer(pInt) function lattice_initializeStructure(struct,CoverA) !************************************** !* Calculation of Schmid * !* matrices, etc. * !************************************** use prec, only: pReal,pInt - use math + use math, only: math_vectorproduct, & + math_tensorproduct, & + math_mul3x3, & + math_symmetric33, & + math_Mandel33to6, & + math_axisAngleToR, & + INRAD use IO, only: IO_error + implicit none - character(len=*) struct real(pReal) CoverA real(pReal), dimension(3,lattice_maxNslip) :: sd = 0.0_pReal, & @@ -811,7 +832,6 @@ function lattice_initializeStructure(struct,CoverA) integer(pInt) :: i,myNslip,myNtwin,myStructure = 0_pInt logical :: processMe - integer(pInt) lattice_initializeStructure processMe = .false. select case(struct(1:3)) ! check first three chars of structure name @@ -949,7 +969,7 @@ function lattice_initializeStructure(struct,CoverA) lattice_initializeStructure = myStructure ! report my structure index back -end function +end function lattice_initializeStructure -END MODULE +end module lattice diff --git a/code/makefile b/code/makefile deleted file mode 100644 index 00bc008fb..000000000 --- a/code/makefile +++ /dev/null @@ -1,355 +0,0 @@ -######################################################################################## -# Makefile to compile the Material subroutine for BVP solution using spectral method -######################################################################################## -# Be sure to remove all files compiled with different options by using "make clean" -# -# Uses OpenMP to parallelize the material subroutines (set number of threads with "export DAMASK_NUM_THREADS=n" to n) -# -# Install fftw3 (v3.3 is tested): -# + run -# ./configure --enable-threads --enable-sse2 --enable-shared [-enable-float] -# make -# make install -# + specify in the "pathinfo:FFTW" where FFTW was installed. -# We essentially look for two library files "lib/libfftw3_threads" and "lib/libfftw3", so you can copy those, for instance, -# into DAMASK_ROOT/lib/fftw/lib/ and specify "./fftw/" as pathinfo:FFTW -# Use --enable-float in above configure for single precision... -# Uses linux threads to parallelize fftw3 -# -# Instead of the AMD Core Math Library a standard "liblapack.a/dylib/etc." can be used by leaving pathinfo:ACML and pathinfo:IKML blank -######################################################################################## -# OPTIONS = standard (alternative): meaning -#------------------------------------------------------------- -# F90 = ifort (gfortran): compiler, choose Intel or GNU -# COMPILERNAME = overwrite name of Compiler, e.g. using mpich-g90 instead of ifort -# PORTABLE = TRUE (FALSE): decision, if executable is optimized for the machine on which it was built. -# OPTIMIZATION = DEFENSIVE (OFF,AGGRESSIVE,ULTRA): Optimization mode: O2, O0, O3 + further options for most files, O3 + further options for all files -# OPENMP = TRUE (FALSE): OpenMP multiprocessor support -# FFTWROOT = pathinfo:FFTW (will be adjusted by setup_code.py - required in pathinfo) -# IKMLROOT = pathinfo:IKML (will be adjusted by setup_code.py if present in pathinfo) -# ACMLROOT = pathinfo:ACML (will be adjusted by setup_code.py if present in pathinfo) -# LAPACKROOT = pathinfo:LAPACK (will be adjusted by setup_code.py if present in pathinfo) -# PREFIX = arbitrary prefix -# SUFFIX = arbitrary suffix -# STANDARD_CHECK = checking for Fortran 2008, compiler dependend -######################################################################################## - -#auto values will be set by setup_code.py -FFTWROOT :=/$(DAMASK_ROOT)/lib/fftw -IKMLROOT := -ACMLROOT :=/opt/acml4.4.0 -#LAPACKROOT := /usr - -F90 ?= ifort -COMPILERNAME ?= $(F90) -OPENMP ?= ON -OPTIMIZATION ?= DEFENSIVE - -ifeq "$(F90)" "ifort" -ifeq "$(OPTIMIZATION)" "OFF" -ARCHIVE_COMMAND :=ar -else -ARCHIVE_COMMAND :=xiar -endif -else -ARCHIVE_COMMAND :=ar -endif - -ifeq "$(OPTIMIZATION)" "OFF" -OPTI := OFF -MAXOPTI := OFF -endif -ifeq "$(OPTIMIZATION)" "DEFENSIVE" -OPTI := DEFENSIVE -MAXOPTI := DEFENSIVE -endif -ifeq "$(OPTIMIZATION)" "AGGRESSIVE" -OPTI := AGGRESSIVE -MAXOPTI := DEFENSIVE -endif -ifeq "$(OPTIMIZATION)" "ULTRA" -OPTI := AGGRESSIVE -MAXOPTI := AGGRESSIVE -endif - -ifndef OPTI -OPTI := DEFENSIVE -MAXOPTI := DEFENSIVE -endif - -ifeq "$(PORTABLE)" "FALSE" -PORTABLE_SWITCH =-msse3 -endif - - -# settings for multicore support -ifeq "$(OPENMP)" "ON" -OPENMP_FLAG_ifort =-openmp -openmp-report0 -parallel -OPENMP_FLAG_gfortran =-fopenmp -ACML_ARCH =_mp -LIBRARIES +=-lfftw3_threads -lpthread -endif - -LIBRARIES +=-lfftw3 -LIB_DIRS +=-L$(FFTWROOT)/lib - -ifdef IKMLROOT -LIBRARIES +=-mkl -else -ifdef ACMLROOT -LIB_DIRS +=-L$(ACMLROOT)/$(F90)64$(ACML_ARCH)/lib -LIBRARIES +=-lacml$(ACML_ARCH) -else -ifdef LAPACKROOT -LIB_DIRS +=-L$(LAPACKROOT)/lib64 -L$(LAPACKROOT)/lib -LIBRARIES +=-llapack -endif -endif -endif - -ifdef STANDARD_CHECK -STANDARD_CHECK_ifort =$(STANDARD_CHECK) -STANDARD_CHECK_gfortran =$(STANDARD_CHECK) -endif -STANDARD_CHECK_ifort ?=-stand f08 -standard-semantics -STANDARD_CHECK_gfortran ?=-std=f2008 - - -OPTIMIZATION_OFF_ifort :=-O0 -OPTIMIZATION_OFF_gfortran :=-O0 -OPTIMIZATION_DEFENSIVE_ifort :=-O2 -OPTIMIZATION_DEFENSIVE_gfortran :=-O2 -OPTIMIZATION_AGGRESSIVE_ifort :=-O3 $(PORTABLE_SWITCH) -ipo -static -no-prec-div -fp-model fast=2 -OPTIMIZATION_AGGRESSIVE_gfortran :=-O3 $(PORTABLE_SWITCH) -ffast-math -funroll-loops -ftree-vectorize - - -COMPILE_OPTIONS_ifort :=-fpp\ - -implicitnone\ - -diag-enable sc3\ - -diag-disable 5268\ - -warn declarations\ - -warn general\ - -warn usage\ - -warn interfaces\ - -warn ignore_loc\ - -warn alignments\ - -warn unused\ - -warn errors\ - -warn stderrors - -#-fpp: preprocessor -#-fimplicit-none: assume "implicit-none" even if not present in source -#-diag-disable: disables warnings, where -# warning ID 5268: the text exceeds right hand column allowed on the line (we have only comments there) -#-warn: enables warnings, where -# declarations: any undeclared names -# general: warning messages and informational messages are issued by the compiler -# usage: questionable programming practices -# interfaces: checks the interfaces of all SUBROUTINEs called and FUNCTIONs invoked in your compilation against an external set of interface blocks -# ignore_loc: %LOC is stripped from an actual argument -# alignments: data that is not naturally aligned -# unused: declared variables that are never used -# errors: warnings are changed to errors -# stderrors: warnings about Fortran standard violations are changed to errors -# -################################################################################################### -#MORE OPTIONS FOR DEBUGGING DURING COMPILING -#-warn: enables warnings, where -# truncated_source: Determines whether warnings occur when source exceeds the maximum column width in fixed-format files. (too many warnings because we have comments beyond character 132) -# uncalled: Determines whether warnings occur when a statement function is never called -# all: -# -#OPTIONS FOR DEGUBBING DURING RUNTIME -# information on http://software.intel.com/en-us/articles/determining-root-cause-of-sigsegv-or-sigbus-errors/ -#-g: Generate symbolic debugging information in the object file -#-traceback: Generate extra information in the object file to provide source file traceback information when a severe error occurs at run time. -#-gen-interfaces: Generate an interface block for each routine. http://software.intel.com/en-us/blogs/2012/01/05/doctor-fortran-gets-explicit-again/ -#-fp-stack-check: Generate extra code after every function call to ensure that the floating-point (FP) stack is in the expected state. -#-check: checks at runtime, where -# bounds: check if an array index is too small (<1) or too large! -# arg_temp_created: will cause a lot of warnings because we create a bunch of temporary arrays -# format: Checking for the data type of an item being formatted for output. -# output_conversion: Checking for the fit of data items within a designated format descriptor field. -# pointers: Checking for certain disassociated or uninitialized pointers or unallocated allocatable objects. -# uninit: Checking for uninitialized variables. -#-heap-arrays: should not be done for OpenMP, but set "ulimit -s unlimited" on shell. Probably it helps also to unlimit other limits -# -#OPTIONS FOR TYPE DEBUGGING -#-real-size 32: set precision to one of those 32/64/128 (= 4/8/16 bytes) for standard real (=8 for pReal) -#-integer-size 16: set precision to one of those 16/32/64 (= 2/4/8 bytes) for standard integer (=4 for pInt) -################################################################################################### - -COMPILE_OPTIONS_gfortran :=-xf95-cpp-input\ - -ffree-line-length-132\ - -fno-range-check\ - -fimplicit-none\ - -fall-intrinsics\ - -pedantic\ - -Warray-bounds\ - -Wampersand\ - -Wno-tabs\ - -Wcharacter-truncation\ - -Wintrinsic-shadow\ - -Waliasing\ - -Wconversion\ - -Wsurprising\ - -Wunderflow\ - -Wswitch\ - -Wstrict-overflow\ - -Wattributes\ - -Wunsafe-loop-optimizations\ - -Wunused\ - -Wextra - -#-xf95-cpp-input: preprocessor -#-ffree-line-length-132: restrict line length to the standard 132 characters -#-fno-range-check: disables checking if result can be represented by variable. Needs to be set to enable DAMASK_NaN -#-fimplicit-none: assume "implicit-none" even if not present in source -#-fall-intrinsics: -#-pedantic: more strict on standard, enables some of the warnings below -#-Warray-bounds: checks if array reference is out of bounds at compile time. use -fcheck-bounds to also check during runtime -#-Wampersand: checks if a character expression is continued proberly by an ampersand at the end of the line and at the beginning of the new line -#-Wno-tabs: do not allow tabs in source -#-Wcharacter-truncation: warn if character expressions (strings) are truncated -#-Wintrinsic-shadow: warn if a user-defined procedure or module procedure has the same name as an intrinsic -#-Waliasing: warn about possible aliasing of dummy arguments. Specifically, it warns if the same actual argument is associated with a dummy argument with "INTENT(IN)" and a dummy argument with "INTENT(OUT)" in a call with an explicit interface. -#-Wconversion: warn about implicit conversions between different type -#-Wsurprising: warn when "suspicious" code constructs are encountered. While technically legal these usually indicate that an error has been made. -#-Wunderflow: produce a warning when numerical constant expressions are encountered, which yield an UNDERFLOW during compilation -#-Wswitch: warn whenever a "switch" statement has an index of enumerated type and lacks a "case" for one or more of the named codes of that enumeration. (The presence of a "default" label prevents this warning.) "case" labels outside the enumeration range also provokewarnings when this option is used (even if there is a "default" label) -#-Wstrict-overflow: -#-Wattributes: warn about inappropriate attribute usage -#-Wunsafe-loop-optimizations: warn if the loop cannot be optimized due to nontrivial assumptions. -#-Wunused: -# -value: -# -parameter: find usused variables with "parameter" attribute -#-Wextra: -################################################################################################### -#OPTIONS FOR GFORTRAN 4.6 -#-Wsuggest-attribute=const: -#-Wsuggest-attribute=noreturn: -#-Wsuggest-attribute=pure: -#-Wreal-q-constant: Warn about real-literal-constants with 'q' exponent-letter -#MORE OPTIONS FOR DEBUGGING DURING COMPILING -#-Wline-truncation: too many warnings because we have comments beyond character 132 -#-Wintrinsic-std: warnings because of "flush" is not longer in the standard, but still an intrinsic fuction of the compilers: -#-Warray-temporarieswarnings: -# because we have many temporary arrays (performance issue?): -#-Wimplicit-interface -#-pedantic-errors -#-fmodule-private -# -#OPTIONS FOR DEGUBBING DURING RUNTIME -#-fcheck-bounds: check if an array index is too small (<1) or too large! -# -#OPTIONS FOR TYPE DEBUGGING -#-fdefault-real-8: set precision to 8 bytes for standard real (=8 for pReal). Will set size of double to 16 bytes as long as -fdefault-double-8 is not set -#-fdefault-integer-8: set precision to 8 bytes for standard integer (=4 for pInt) -################################################################################################## - -COMPILE =$(OPENMP_FLAG_$(F90)) $(COMPILE_OPTIONS_$(F90)) $(STANDARD_CHECK_$(F90)) $(OPTIMIZATION_$(OPTI)_$(F90)) -c -COMPILE_MAXOPTI =$(OPENMP_FLAG_$(F90)) $(COMPILE_OPTIONS_$(F90)) $(STANDARD_CHECK_$(F90)) $(OPTIMIZATION_$(MAXOPTI)_$(F90)) -c -################################################################################################### - -DAMASK_spectral.exe: DAMASK_spectral.o CPFEM.a - $(PREFIX) $(COMPILERNAME) ${OPENMP_FLAG_${F90}} -o DAMASK_spectral.exe DAMASK_spectral.o CPFEM.a \ - constitutive.a advanced.a basics.a $(LIB_DIRS) $(LIBRARIES) - -DAMASK_spectral.o: DAMASK_spectral.f90 CPFEM.o - $(PREFIX) $(COMPILERNAME) $(COMPILE_MAXOPTI) DAMASK_spectral.f90 $(SUFFIX) - - - -CPFEM.a: CPFEM.o - $(ARCHIVE_COMMAND) rc CPFEM.a homogenization.o homogenization_RGC.o homogenization_isostrain.o crystallite.o CPFEM.o constitutive.o - -CPFEM.o: CPFEM.f90 homogenization.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) CPFEM.f90 $(SUFFIX) - -homogenization.o: homogenization.f90 homogenization_isostrain.o homogenization_RGC.o crystallite.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) homogenization.f90 $(SUFFIX) - -homogenization_RGC.o: homogenization_RGC.f90 constitutive.a - $(PREFIX) $(COMPILERNAME) $(COMPILE) homogenization_RGC.f90 $(SUFFIX) - -homogenization_isostrain.o: homogenization_isostrain.f90 basics.a advanced.a - $(PREFIX) $(COMPILERNAME) $(COMPILE) homogenization_isostrain.f90 $(SUFFIX) - -crystallite.o: crystallite.f90 constitutive.a - $(PREFIX) $(COMPILERNAME) $(COMPILE) crystallite.f90 $(SUFFIX) - - - -constitutive.a: constitutive.o - $(ARCHIVE_COMMAND) rc constitutive.a constitutive.o constitutive_titanmod.o constitutive_nonlocal.o constitutive_dislotwin.o constitutive_j2.o constitutive_phenopowerlaw.o basics.a advanced.a - -constitutive.o: constitutive.f90 constitutive_titanmod.o constitutive_nonlocal.o constitutive_dislotwin.o constitutive_j2.o constitutive_phenopowerlaw.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) constitutive.f90 $(SUFFIX) - -constitutive_titanmod.o: constitutive_titanmod.f90 basics.a advanced.a - $(PREFIX) $(COMPILERNAME) $(COMPILE) constitutive_titanmod.f90 $(SUFFIX) - -constitutive_nonlocal.o: constitutive_nonlocal.f90 basics.a advanced.a - $(PREFIX) $(COMPILERNAME) $(COMPILE) constitutive_nonlocal.f90 $(SUFFIX) - -constitutive_dislotwin.o: constitutive_dislotwin.f90 basics.a advanced.a - $(PREFIX) $(COMPILERNAME) $(COMPILE) constitutive_dislotwin.f90 $(SUFFIX) - -constitutive_j2.o: constitutive_j2.f90 basics.a advanced.a - $(PREFIX) $(COMPILERNAME) $(COMPILE) constitutive_j2.f90 $(SUFFIX) - -constitutive_phenopowerlaw.o: constitutive_phenopowerlaw.f90 basics.a advanced.a - $(PREFIX) $(COMPILERNAME) $(COMPILE) constitutive_phenopowerlaw.f90 $(SUFFIX) - - - -advanced.a: lattice.o - $(ARCHIVE_COMMAND) rc advanced.a FEsolving.o mesh.o material.o lattice.o - -lattice.o: lattice.f90 material.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) lattice.f90 $(SUFFIX) - -material.o: material.f90 mesh.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) material.f90 $(SUFFIX) - -mesh.o: mesh.f90 FEsolving.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) mesh.f90 $(SUFFIX) - -FEsolving.o: FEsolving.f90 basics.a - $(PREFIX) $(COMPILERNAME) $(COMPILE) FEsolving.f90 $(SUFFIX) - - - -basics.a: math.o - $(ARCHIVE_COMMAND) rc basics.a math.o debug.o numerics.o IO.o DAMASK_spectral_interface.o prec.o - -math.o: math.f90 debug.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) math.f90 $(SUFFIX) - -debug.o: debug.f90 numerics.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) debug.f90 $(SUFFIX) - -numerics.o: numerics.f90 IO.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) numerics.f90 $(SUFFIX) - -IO.o: IO.f90 DAMASK_spectral_interface.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) IO.f90 $(SUFFIX) - -DAMASK_spectral_interface.o: DAMASK_spectral_interface.f90 prec.o - $(PREFIX) $(COMPILERNAME) $(COMPILE) DAMASK_spectral_interface.f90 $(SUFFIX) - -prec.o: prec.f90 - $(PREFIX) $(COMPILERNAME) $(COMPILE) prec.f90 $(SUFFIX) - - -tidy: - rm -rf *.o - rm -rf *.mod - rm -rf *.a - -clean: - rm -rf *.o - rm -rf *.mod - rm -rf *.a - rm -rf *.exe - diff --git a/code/material.f90 b/code/material.f90 index 244f4d875..be0c841b3 100644 --- a/code/material.f90 +++ b/code/material.f90 @@ -16,106 +16,129 @@ ! You should have received a copy of the GNU General Public License ! along with DAMASK. If not, see . ! -!############################################################## +!-------------------------------------------------------------------------------------------------- !* $Id$ -!************************************ -!* Module: MATERIAL * -!************************************ -!* contains: * -!* - parsing of material.config * -!************************************ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!! Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Parses material.config +!-------------------------------------------------------------------------------------------------- +module material -MODULE material + use prec, only: pReal, & + pInt -!*** Include other modules *** -use prec, only: pReal,pInt -implicit none + implicit none + private + character(len=64), parameter, public :: & + material_configFile = 'material.config', & + material_localFileExt = 'materialConfig' + + character(len=32), parameter, public :: & + material_partHomogenization = 'homogenization', & + material_partCrystallite = 'crystallite', & + material_partPhase = 'phase' + + character(len=64), dimension(:), allocatable, public :: & + phase_constitution, & !> constitution of each phase + phase_name, & !> name of each phase + homogenization_name, & !> name of each homogenization + homogenization_type, & !> type of each homogenization + crystallite_name !> name of each crystallite setting -character(len=64), parameter, public :: material_configFile = 'material.config' -character(len=64), parameter, public :: material_localFileExt = 'materialConfig' -character(len=32), parameter, public :: material_partHomogenization = 'homogenization' -character(len=32), parameter, private :: material_partMicrostructure = 'microstructure' -character(len=32), parameter, public :: material_partCrystallite = 'crystallite' -character(len=32), parameter, public :: material_partPhase = 'phase' -character(len=32), parameter, private :: material_partTexture = 'texture' - + integer(pInt), public :: & + homogenization_maxNgrains, & !> max number of grains in any USED homogenization + material_Nphase, & !> number of phases + material_Nhomogenization, & !> number of homogenizations + material_Nmicrostructure, & !> number of microstructures + material_Ncrystallite !> number of crystallite settings + + integer(pInt), dimension(:), allocatable, public :: & + homogenization_Ngrains, & !> number of grains in each homogenization + homogenization_Noutput, & !> number of '(output)' items per homogenization + phase_Noutput, & !> number of '(output)' items per phase + phase_constitutionInstance, & !> instance of particular constitution of each phase + crystallite_Noutput, & !> number of '(output)' items per crystallite setting + homogenization_typeInstance, & !> instance of particular type of each homogenization + microstructure_crystallite !> crystallite setting ID of each microstructure -!************************************* -!* Definition of material properties * -!************************************* -!* Number of materials -integer(pInt) & - material_Nhomogenization, & ! number of homogenizations - material_Nmicrostructure, & ! number of microstructures - material_Ncrystallite, & ! number of crystallite settings - material_Nphase, & ! number of phases - material_Ntexture, & ! number of textures - microstructure_maxNconstituents,&! max number of constituents in any phase - homogenization_maxNgrains, & ! max number of grains in any USED homogenization - texture_maxNgauss, & ! max number of Gauss components in any texture - texture_maxNfiber ! max number of Fiber components in any texture -character(len=64), dimension(:), allocatable :: & - homogenization_name, & ! name of each homogenization - homogenization_type, & ! type of each homogenization - microstructure_name, & ! name of each microstructure - crystallite_name, & ! name of each crystallite setting - phase_name, & ! name of each phase - phase_constitution, & ! constitution of each phase - texture_name ! name of each texture -character(len=256),dimension(:), allocatable :: & - texture_ODFfile ! name of each ODF file -integer(pInt), dimension(:), allocatable :: & - homogenization_Ngrains, & ! number of grains in each homogenization - homogenization_typeInstance, & ! instance of particular type of each homogenization - homogenization_Noutput, & ! number of '(output)' items per homogenization - microstructure_Nconstituents, & ! number of constituents in each microstructure - crystallite_Noutput, & ! number of '(output)' items per crystallite setting - phase_constitutionInstance, & ! instance of particular constitution of each phase - phase_Noutput, & ! number of '(output)' items per phase - texture_symmetry, & ! number of symmetric orientations per texture - texture_Ngauss, & ! number of Gauss components per texture - texture_Nfiber ! number of Fiber components per texture -logical, dimension(:), allocatable :: & - homogenization_active, & ! - microstructure_active, & ! - microstructure_elemhomo, & ! flag to indicate homogeneous microstructure distribution over element's IPs - phase_localConstitution ! flags phases with local constitutive law -integer(pInt), dimension(:), allocatable :: & - microstructure_crystallite ! crystallite setting ID of each microstructure -integer(pInt), dimension(:,:), allocatable :: & - microstructure_phase, & ! phase IDs of each microstructure - microstructure_texture ! texture IDs of each microstructure -real(pReal), dimension(:,:), allocatable :: & - microstructure_fraction ! vol fraction of each constituent in microstructure -real(pReal), dimension(:,:,:), allocatable :: & - material_volume ! volume of each grain,IP,element -integer(pInt), dimension(:,:,:), allocatable :: & - material_phase, & ! phase (index) of each grain,IP,element - material_texture ! texture (index) of each grain,IP,element -real(pReal), dimension(:,:,:,:), allocatable :: & - material_EulerAngles ! initial orientation of each grain,IP,element -real(pReal), dimension(:,:,:), allocatable :: & - texture_Gauss, & ! data of each Gauss component - texture_Fiber ! data of each Fiber component + integer(pInt), dimension(:,:,:), allocatable, public :: & + material_phase, & !> phase (index) of each grain,IP,element + material_texture !> texture (index) of each grain,IP,element + + real(pReal), dimension(:,:,:,:), allocatable, public :: & + material_EulerAngles !> initial orientation of each grain,IP,element + + logical, dimension(:), allocatable, public :: & + microstructure_active, & + microstructure_elemhomo, & !> flag to indicate homogeneous microstructure distribution over element's IPs + phase_localConstitution !> flags phases with local constitutive law -CONTAINS + character(len=32), parameter, private :: & + material_partMicrostructure = 'microstructure', & + material_partTexture = 'texture' + + character(len=64), dimension(:), allocatable, private :: & + microstructure_name, & !> name of each microstructure + texture_name !> name of each texture + + character(len=256), dimension(:), allocatable, private :: & + texture_ODFfile !> name of each ODF file + + integer(pInt), private :: & + material_Ntexture, & !> number of textures + microstructure_maxNconstituents, & !> max number of constituents in any phase + texture_maxNgauss, & !> max number of Gauss components in any texture + texture_maxNfiber !> max number of Fiber components in any texture + + integer(pInt), dimension(:), allocatable, private :: & + microstructure_Nconstituents, & !> number of constituents in each microstructure + texture_symmetry, & !> number of symmetric orientations per texture + texture_Ngauss, & !> number of Gauss components per texture + texture_Nfiber !> number of Fiber components per texture + + integer(pInt), dimension(:,:), allocatable, private :: & + microstructure_phase, & !> phase IDs of each microstructure + microstructure_texture !> texture IDs of each microstructure + + real(pReal), dimension(:,:), allocatable, private :: & + microstructure_fraction !> vol fraction of each constituent in microstructure + + real(pReal), dimension(:,:,:), allocatable :: & + material_volume, & !> volume of each grain,IP,element + texture_Gauss, & !> data of each Gauss component + texture_Fiber !> data of each Fiber component + + logical, dimension(:), allocatable, private :: & + homogenization_active + + + public :: material_init + +contains !********************************************************************* -subroutine material_init() +subroutine material_init !********************************************************************* !* Module initialization * !************************************** use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) - use prec, only: pReal,pInt - use IO, only: IO_error, IO_open_file, IO_open_jobFile_stat - use debug, only: debug_verbosity + use IO, only: IO_error, & + IO_open_file, & + IO_open_jobFile_stat + use debug, only: debug_what, & + debug_material, & + debug_levelBasic, & + debug_levelExtensive + implicit none - !* Definition of variables integer(pInt), parameter :: fileunit = 200_pInt - integer(pInt) i,j + integer(pInt) :: i,j, myDebug + + myDebug = debug_what(debug_material) !$OMP CRITICAL (write2out) write(6,*) @@ -128,31 +151,31 @@ subroutine material_init() call IO_open_file(fileunit,material_configFile) ! ...open material.config file endif call material_parseHomogenization(fileunit,material_partHomogenization) - if (debug_verbosity > 0_pInt) then + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write (6,*) 'Homogenization parsed' !$OMP END CRITICAL (write2out) endif call material_parseMicrostructure(fileunit,material_partMicrostructure) - if (debug_verbosity > 0_pInt) then + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write (6,*) 'Microstructure parsed' !$OMP END CRITICAL (write2out) endif call material_parseCrystallite(fileunit,material_partCrystallite) - if (debug_verbosity > 0_pInt) then + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write (6,*) 'Crystallite parsed' !$OMP END CRITICAL (write2out) endif call material_parseTexture(fileunit,material_partTexture) - if (debug_verbosity > 0_pInt) then + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write (6,*) 'Texture parsed' !$OMP END CRITICAL (write2out) endif call material_parsePhase(fileunit,material_partPhase) - if (debug_verbosity > 0_pInt) then + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write (6,*) 'Phase parsed' !$OMP END CRITICAL (write2out) @@ -167,7 +190,7 @@ subroutine material_init() if (minval(microstructure_texture(1:microstructure_Nconstituents(i),i)) < 1_pInt .or. & maxval(microstructure_texture(1:microstructure_Nconstituents(i),i)) > material_Ntexture) call IO_error(152_pInt,i) if (abs(sum(microstructure_fraction(:,i)) - 1.0_pReal) >= 1.0e-10_pReal) then - if (debug_verbosity > 0_pInt) then + if (iand(myDebug,debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,*)'sum of microstructure fraction = ',sum(microstructure_fraction(:,i)) !$OMP END CRITICAL (write2out) @@ -175,7 +198,7 @@ subroutine material_init() call IO_error(153_pInt,i) endif enddo - if (debug_verbosity > 0_pInt) then + if (iand(myDebug,debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write (6,*) write (6,*) 'MATERIAL configuration' @@ -188,14 +211,14 @@ subroutine material_init() write (6,'(a32,1x,a11,1x,a12,1x,a13)') 'microstructure ','crystallite','constituents','homogeneous' do i = 1_pInt,material_Nmicrostructure write (6,'(a32,4x,i4,8x,i4,8x,l1)') microstructure_name(i), & - microstructure_crystallite(i), & - microstructure_Nconstituents(i), & - microstructure_elemhomo(i) + microstructure_crystallite(i), & + microstructure_Nconstituents(i), & + microstructure_elemhomo(i) if (microstructure_Nconstituents(i) > 0_pInt) then do j = 1_pInt,microstructure_Nconstituents(i) write (6,'(a1,1x,a32,1x,a32,1x,f7.4)') '>',phase_name(microstructure_phase(j,i)),& - texture_name(microstructure_texture(j,i)),& - microstructure_fraction(j,i) + texture_name(microstructure_texture(j,i)),& + microstructure_fraction(j,i) enddo write (6,*) endif @@ -203,27 +226,28 @@ subroutine material_init() !$OMP END CRITICAL (write2out) endif - call material_populateGrains() + call material_populateGrains -endsubroutine +end subroutine material_init !********************************************************************* subroutine material_parseHomogenization(myFile,myPart) !********************************************************************* - use prec, only: pInt use IO use mesh, only: mesh_element + implicit none - character(len=*), intent(in) :: myPart - integer(pInt), intent(in) :: myFile - integer(pInt), parameter :: maxNchunks = 2_pInt + integer(pInt), intent(in) :: myFile + + integer(pInt), parameter :: maxNchunks = 2_pInt + integer(pInt), dimension(1+2*maxNchunks) :: positions integer(pInt) Nsections, section, s - character(len=64) tag - character(len=1024) line + character(len=64) :: tag + character(len=1024) ::line Nsections = IO_countSections(myFile,myPart) material_Nhomogenization = Nsections @@ -273,25 +297,26 @@ subroutine material_parseHomogenization(myFile,myPart) 100 homogenization_maxNgrains = maxval(homogenization_Ngrains,homogenization_active) - endsubroutine + end subroutine material_parseHomogenization !********************************************************************* subroutine material_parseMicrostructure(myFile,myPart) !********************************************************************* - use prec, only: pInt use IO use mesh, only: mesh_element, mesh_NcpElems + implicit none - character(len=*), intent(in) :: myPart - integer(pInt), intent(in) :: myFile + integer(pInt), intent(in) :: myFile + integer(pInt), parameter :: maxNchunks = 7_pInt + integer(pInt), dimension(1_pInt+2_pInt*maxNchunks) :: positions - integer(pInt) Nsections, section, constituent, e, i - character(len=64) tag - character(len=1024) line + integer(pInt) :: Nsections, section, constituent, e, i + character(len=64) :: tag + character(len=1024) :: line Nsections = IO_countSections(myFile,myPart) material_Nmicrostructure = Nsections @@ -353,21 +378,27 @@ subroutine material_parseMicrostructure(myFile,myPart) endif enddo -100 endsubroutine +100 end subroutine material_parseMicrostructure !********************************************************************* subroutine material_parseCrystallite(myFile,myPart) !********************************************************************* - use prec, only: pInt - use IO - implicit none + use IO, only: IO_countSections, & + IO_error, & + IO_countTagInPart, & + IO_getTag, & + IO_lc, & + IO_isBlank + implicit none character(len=*), intent(in) :: myPart - integer(pInt), intent(in) :: myFile - integer(pInt) Nsections, section - character(len=1024) line + integer(pInt), intent(in) :: myFile + + integer(pInt) :: Nsections, & + section + character(len=1024) :: line Nsections = IO_countSections(myFile,myPart) material_Ncrystallite = Nsections @@ -396,24 +427,25 @@ subroutine material_parseCrystallite(myFile,myPart) endif enddo -100 endsubroutine +100 end subroutine material_parseCrystallite !********************************************************************* subroutine material_parsePhase(myFile,myPart) !********************************************************************* - use prec, only: pInt use IO + implicit none - character(len=*), intent(in) :: myPart - integer(pInt), intent(in) :: myFile + integer(pInt), intent(in) :: myFile + integer(pInt), parameter :: maxNchunks = 2_pInt + integer(pInt), dimension(1+2*maxNchunks) :: positions integer(pInt) Nsections, section, s - character(len=64) tag - character(len=1024) line + character(len=64) :: tag + character(len=1024) :: line Nsections = IO_countSections(myFile,myPart) material_Nphase = Nsections @@ -458,25 +490,26 @@ subroutine material_parsePhase(myFile,myPart) endif enddo -100 endsubroutine +100 end subroutine material_parsePhase !********************************************************************* subroutine material_parseTexture(myFile,myPart) !********************************************************************* - use prec, only: pInt, pReal use IO use math, only: inRad, math_sampleRandomOri + implicit none - character(len=*), intent(in) :: myPart - integer(pInt), intent(in) :: myFile - integer(pInt), parameter :: maxNchunks = 13_pInt + integer(pInt), intent(in) :: myFile + + integer(pInt), parameter :: maxNchunks = 13_pInt + integer(pInt), dimension(1+2*maxNchunks) :: positions - integer(pInt) Nsections, section, gauss, fiber, i - character(len=64) tag - character(len=1024) line + integer(pInt) :: Nsections, section, gauss, fiber, i + character(len=64) :: tag + character(len=1024) :: line Nsections = IO_countSections(myFile,myPart) @@ -589,36 +622,47 @@ subroutine material_parseTexture(myFile,myPart) endif enddo -100 endsubroutine +100 end subroutine material_parseTexture !********************************************************************* -subroutine material_populateGrains() +subroutine material_populateGrains !********************************************************************* - use prec, only: pInt, pReal - use math, only: math_sampleRandomOri, math_sampleGaussOri, math_sampleFiberOri, math_symmetricEulers - use mesh, only: mesh_element, mesh_maxNips, mesh_NcpElems, mesh_ipVolume, FE_Nips - use IO, only: IO_error, IO_hybridIA + use math, only: math_sampleRandomOri, & + math_sampleGaussOri, & + math_sampleFiberOri, & + math_symmetricEulers + use mesh, only: mesh_element, & + mesh_maxNips, & + mesh_NcpElems, & + mesh_ipVolume, & + FE_Nips + use IO, only: IO_error, & + IO_hybridIA use FEsolving, only: FEsolving_execIP - use debug, only: debug_verbosity + use debug, only: debug_what, & + debug_material, & + debug_levelBasic + implicit none - integer(pInt), dimension (:,:), allocatable :: Ngrains - integer(pInt), dimension (microstructure_maxNconstituents) :: NgrainsOfConstituent + integer(pInt), dimension (microstructure_maxNconstituents) & + :: NgrainsOfConstituent real(pReal), dimension (:), allocatable :: volumeOfGrain real(pReal), dimension (:,:), allocatable :: orientationOfGrain - real(pReal), dimension (3) :: orientation - real(pReal), dimension (3,3) :: symOrientation + real(pReal), dimension (3) :: orientation + real(pReal), dimension (3,3) :: symOrientation integer(pInt), dimension (:), allocatable :: phaseOfGrain, textureOfGrain - integer(pInt) t,e,i,g,j,m,homog,micro,sgn,hme - integer(pInt) phaseID,textureID,dGrains,myNgrains,myNorientations, & + integer(pInt) :: t,e,i,g,j,m,homog,micro,sgn,hme, myDebug + integer(pInt) :: phaseID,textureID,dGrains,myNgrains,myNorientations, & grain,constituentGrain,symExtension - real(pReal) extreme,rnd + real(pReal) :: extreme,rnd integer(pInt), dimension (:,:), allocatable :: Nelems ! counts number of elements in homog, micro array integer(pInt), dimension (:,:,:), allocatable :: elemsOfHomogMicro ! lists element number in homog, micro array - + myDebug = debug_what(debug_material) + allocate(material_volume(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; material_volume = 0.0_pReal allocate(material_phase(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; material_phase = 0_pInt allocate(material_texture(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; material_texture = 0_pInt @@ -663,7 +707,7 @@ subroutine material_populateGrains() allocate(textureOfGrain(maxval(Ngrains))) ! reserve memory for maximum case allocate(orientationOfGrain(3,maxval(Ngrains))) ! reserve memory for maximum case - if (debug_verbosity > 0_pInt) then + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write (6,*) write (6,*) 'MATERIAL grain population' @@ -676,7 +720,7 @@ subroutine material_populateGrains() do micro = 1_pInt,material_Nmicrostructure ! all pairs of homog and micro if (Ngrains(homog,micro) > 0_pInt) then ! an active pair of homog and micro myNgrains = Ngrains(homog,micro) ! assign short name for total number of grains to populate - if (debug_verbosity > 0_pInt) then + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then !$OMP CRITICAL (write2out) write (6,*) write (6,'(a32,1x,a32,1x,i6)') homogenization_name(homog),microstructure_name(micro),myNgrains @@ -837,7 +881,6 @@ subroutine material_populateGrains() deallocate(Nelems) deallocate(elemsOfHomogMicro) - endsubroutine +end subroutine material_populateGrains - -END MODULE +end module material diff --git a/code/math.f90 b/code/math.f90 index f48515fcb..c9514c668 100644 --- a/code/math.f90 +++ b/code/math.f90 @@ -22,21 +22,20 @@ #include "kdtree2.f90" - MODULE math +module math !############################################################## use, intrinsic :: iso_c_binding use prec, only: pReal,pInt - use IO, only: IO_error + implicit none - - real(pReal), parameter :: pi = 3.14159265358979323846264338327950288419716939937510_pReal - real(pReal), parameter :: inDeg = 180.0_pReal/pi - real(pReal), parameter :: inRad = pi/180.0_pReal - complex(pReal), parameter :: two_pi_img = (0.0_pReal,2.0_pReal)* pi + real(pReal), parameter, public :: PI = 3.14159265358979323846264338327950288419716939937510_pReal + real(pReal), parameter, public :: INDEG = 180.0_pReal/pi + real(pReal), parameter, public :: INRAD = pi/180.0_pReal + complex(pReal), parameter, public :: TWOPIIMG = (0.0_pReal,2.0_pReal)* pi ! *** 3x3 Identity *** - real(pReal), dimension(3,3), parameter :: math_I3 = & + real(pReal), dimension(3,3), parameter, public :: math_I3 = & reshape( (/ & 1.0_pReal,0.0_pReal,0.0_pReal, & 0.0_pReal,1.0_pReal,0.0_pReal, & @@ -132,20 +131,22 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & /),(/4,36/)) include 'fftw3.f03' - - CONTAINS + + public :: math_init, & + math_range +contains !************************************************************************** ! initialization of module !************************************************************************** - SUBROUTINE math_init () +subroutine math_init use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) use prec, only: tol_math_check use numerics, only: fixedSeed use IO, only: IO_error + implicit none - integer(pInt) :: i real(pReal), dimension(3,3) :: R,R2 real(pReal), dimension(3) :: Eulers @@ -155,6 +156,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & integer, dimension(:), allocatable :: randInit ! if recalculations of former randomness (with given seed) is necessary ! comment the first random_seed call out, set randSize to 1, and use ifort character(len=64) :: error_msg + !$OMP CRITICAL (write2out) write(6,*) '' write(6,*) '<<<+- math init -+>>>' @@ -164,7 +166,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & call random_seed(size=randSize) allocate(randInit(randSize)) - if (fixedSeed > 0) then + if (fixedSeed > 0_pInt) then randInit(1:randSize) = int(fixedSeed) ! fixedSeed is of type pInt, randInit not call random_seed(put=randInit) else @@ -229,7 +231,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & call IO_error(404_pInt,ext_msg=error_msg) endif - ENDSUBROUTINE math_init +end subroutine math_init !************************************************************************** @@ -238,7 +240,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & ! Sorting is done with respect to array(1,:) ! and keeps array(2:N,:) linked to it. !************************************************************************** - RECURSIVE SUBROUTINE qsort(a, istart, iend) +recursive subroutine qsort(a, istart, iend) implicit none integer(pInt), dimension(:,:), intent(inout) :: a @@ -251,13 +253,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & call qsort(a, ipivot+1_pInt, iend) endif - ENDSUBROUTINE qsort +end subroutine qsort !************************************************************************** ! Partitioning required for quicksort !************************************************************************** - integer(pInt) function math_partition(a, istart, iend) +integer(pInt) function math_partition(a, istart, iend) implicit none integer(pInt), dimension(:,:), intent(inout) :: a @@ -297,13 +299,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & endif enddo - endfunction math_partition +end function math_partition !************************************************************************** ! range of integers starting at one !************************************************************************** - pure function math_range(N) +pure function math_range(N) implicit none @@ -313,13 +315,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & forall (i=1_pInt:N) math_range(i) = i - endfunction math_range +end function math_range !************************************************************************** ! second rank identity tensor of specified dimension !************************************************************************** - pure function math_identity2nd(dimen) +pure function math_identity2nd(dimen) implicit none @@ -330,7 +332,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & math_identity2nd = 0.0_pReal forall (i=1_pInt:dimen) math_identity2nd(i,i) = 1.0_pReal - endfunction math_identity2nd +end function math_identity2nd !************************************************************************** @@ -339,7 +341,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & ! e_ijk = -1 if odd permutation of ijk ! e_ijk = 0 otherwise !************************************************************************** - pure function math_civita(i,j,k) +pure function math_civita(i,j,k) implicit none @@ -354,7 +356,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & ((i == 2_pInt).and.(j == 1_pInt).and.(k == 3_pInt)) .or. & ((i == 3_pInt).and.(j == 2_pInt).and.(k == 1_pInt))) math_civita = -1.0_pReal - endfunction math_civita +end function math_civita !************************************************************************** @@ -362,7 +364,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & ! d_ij = 1 if i = j ! d_ij = 0 otherwise !************************************************************************** - pure function math_delta(i,j) +pure function math_delta(i,j) implicit none @@ -372,13 +374,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & math_delta = 0.0_pReal if (i == j) math_delta = 1.0_pReal - endfunction math_delta +end function math_delta !************************************************************************** ! fourth rank identity tensor of specified dimension !************************************************************************** - pure function math_identity4th(dimen) +pure function math_identity4th(dimen) implicit none @@ -389,13 +391,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & forall (i=1_pInt:dimen,j=1_pInt:dimen,k=1_pInt:dimen,l=1_pInt:dimen) math_identity4th(i,j,k,l) = & 0.5_pReal*(math_I3(i,k)*math_I3(j,k)+math_I3(i,l)*math_I3(j,k)) - endfunction math_identity4th +end function math_identity4th !************************************************************************** ! vector product a x b !************************************************************************** - pure function math_vectorproduct(A,B) +pure function math_vectorproduct(A,B) implicit none @@ -406,13 +408,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & math_vectorproduct(2) = A(3)*B(1)-A(1)*B(3) math_vectorproduct(3) = A(1)*B(2)-A(2)*B(1) - endfunction math_vectorproduct +end function math_vectorproduct !************************************************************************** ! tensor product a \otimes b !************************************************************************** - pure function math_tensorproduct(A,B) +pure function math_tensorproduct(A,B) implicit none @@ -422,13 +424,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) math_tensorproduct(i,j) = A(i)*B(j) - endfunction math_tensorproduct +end function math_tensorproduct !************************************************************************** ! matrix multiplication 3x3 = 1 !************************************************************************** - pure function math_mul3x3(A,B) +pure function math_mul3x3(A,B) implicit none @@ -440,13 +442,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & forall (i=1_pInt:3_pInt) C(i) = A(i)*B(i) math_mul3x3 = sum(C) - endfunction math_mul3x3 +end function math_mul3x3 !************************************************************************** ! matrix multiplication 6x6 = 1 !************************************************************************** - pure function math_mul6x6(A,B) +pure function math_mul6x6(A,B) implicit none @@ -458,13 +460,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & forall (i=1_pInt:6_pInt) C(i) = A(i)*B(i) math_mul6x6 = sum(C) - endfunction math_mul6x6 +end function math_mul6x6 !************************************************************************** ! matrix multiplication 33x33 = 1 (double contraction --> ij * ij) !************************************************************************** - pure function math_mul33xx33(A,B) +pure function math_mul33xx33(A,B) implicit none @@ -476,13 +478,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) C(i,j) = A(i,j) * B(i,j) math_mul33xx33 = sum(C) - endfunction math_mul33xx33 +end function math_mul33xx33 !************************************************************************** ! matrix multiplication 3333x33 = 33 (double contraction --> ijkl *kl = ij) !************************************************************************** - pure function math_mul3333xx33(A,B) +pure function math_mul3333xx33(A,B) implicit none @@ -493,13 +495,14 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & forall(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt)& math_mul3333xx33(i,j) = sum(A(i,j,1:3,1:3)*B(1:3,1:3)) - endfunction math_mul3333xx33 + +end function math_mul3333xx33 !************************************************************************** ! matrix multiplication 3333x3333 = 3333 (ijkl *klmn = ijmn) !************************************************************************** - pure function math_mul3333xx3333(A,B) +pure function math_mul3333xx3333(A,B) implicit none @@ -515,13 +518,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & math_mul3333xx3333(i,j,k,l) = sum(A(i,j,1:3,1:3)*B(1:3,1:3,k,l)) enddo; enddo; enddo; enddo - endfunction math_mul3333xx3333 +end function math_mul3333xx3333 !************************************************************************** ! matrix multiplication 33x33 = 33 !************************************************************************** - pure function math_mul33x33(A,B) +pure function math_mul33x33(A,B) implicit none @@ -532,13 +535,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) math_mul33x33(i,j) = & A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) - endfunction math_mul33x33 +end function math_mul33x33 !************************************************************************** ! matrix multiplication 66x66 = 66 !************************************************************************** - pure function math_mul66x66(A,B) +pure function math_mul66x66(A,B) implicit none @@ -550,13 +553,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + & A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) - endfunction math_mul66x66 +end function math_mul66x66 !************************************************************************** ! matrix multiplication 99x99 = 99 !************************************************************************** - pure function math_mul99x99(A,B) +pure function math_mul99x99(A,B) use prec, only: pReal, pInt implicit none @@ -572,13 +575,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) + & A(i,7)*B(7,j) + A(i,8)*B(8,j) + A(i,9)*B(9,j) - endfunction math_mul99x99 +end function math_mul99x99 !************************************************************************** ! matrix multiplication 33x3 = 3 !************************************************************************** - pure function math_mul33x3(A,B) +pure function math_mul33x3(A,B) implicit none @@ -589,12 +592,12 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & forall (i=1_pInt:3_pInt) math_mul33x3(i) = sum(A(i,1:3)*B) - endfunction math_mul33x3 +end function math_mul33x3 !************************************************************************** ! matrix multiplication complex(33) x real(3) = complex(3) !************************************************************************** - pure function math_mul33x3_complex(A,B) +pure function math_mul33x3_complex(A,B) implicit none @@ -605,13 +608,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & forall (i=1_pInt:3_pInt) math_mul33x3_complex(i) = sum(A(i,1:3)*cmplx(B,0.0_pReal,pReal)) - endfunction math_mul33x3_complex +end function math_mul33x3_complex !************************************************************************** ! matrix multiplication 66x6 = 6 !************************************************************************** - pure function math_mul66x6(A,B) +pure function math_mul66x6(A,B) implicit none @@ -624,13 +627,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3) + & A(i,4)*B(4) + A(i,5)*B(5) + A(i,6)*B(6) - endfunction math_mul66x6 +end function math_mul66x6 !************************************************************************** ! random quaternion !************************************************************************** - function math_qRnd() +function math_qRnd() implicit none @@ -643,13 +646,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & math_qRnd(3) = cos(2.0_pReal*pi*rnd(2))*sqrt(1.0_pReal-rnd(3)) math_qRnd(4) = sin(2.0_pReal*pi*rnd(1))*sqrt(rnd(3)) - endfunction math_qRnd +end function math_qRnd !************************************************************************** ! quaternion multiplication q1xq2 = q12 !************************************************************************** - pure function math_qMul(A,B) +pure function math_qMul(A,B) implicit none @@ -661,13 +664,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & math_qMul(3) = A(1)*B(3) - A(2)*B(4) + A(3)*B(1) + A(4)*B(2) math_qMul(4) = A(1)*B(4) + A(2)*B(3) - A(3)*B(2) + A(4)*B(1) - endfunction math_qMul +end function math_qMul !************************************************************************** ! quaternion dotproduct !************************************************************************** - pure function math_qDot(A,B) +pure function math_qDot(A,B) implicit none @@ -676,13 +679,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & math_qDot = A(1)*B(1) + A(2)*B(2) + A(3)*B(3) + A(4)*B(4) - endfunction math_qDot +end function math_qDot !************************************************************************** ! quaternion conjugation !************************************************************************** - pure function math_qConj(Q) +pure function math_qConj(Q) implicit none @@ -692,13 +695,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & math_qConj(1) = Q(1) math_qConj(2:4) = -Q(2:4) - endfunction math_qConj +end function math_qConj !************************************************************************** ! quaternion norm !************************************************************************** - pure function math_qNorm(Q) +pure function math_qNorm(Q) implicit none @@ -707,13 +710,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & math_qNorm = sqrt(max(0.0_pReal, Q(1)*Q(1) + Q(2)*Q(2) + Q(3)*Q(3) + Q(4)*Q(4))) - endfunction math_qNorm +end function math_qNorm !************************************************************************** ! quaternion inversion !************************************************************************** - pure function math_qInv(Q) +pure function math_qInv(Q) implicit none @@ -727,13 +730,13 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & if (squareNorm > tiny(squareNorm)) & math_qInv = math_qConj(Q) / squareNorm - endfunction math_qInv +end function math_qInv !************************************************************************** ! action of a quaternion on a vector (rotate vector v with Q) !************************************************************************** - pure function math_qRot(Q,v) +pure function math_qRot(Q,v) implicit none @@ -755,7 +758,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = & math_qRot = 2.0_pReal * math_qRot + v - endfunction math_qRot +end function math_qRot !************************************************************************** @@ -771,13 +774,13 @@ pure function math_transpose33(A) forall(i=1_pInt:3_pInt, j=1_pInt:3_pInt) math_transpose33(i,j) = A(j,i) - endfunction math_transpose33 +end function math_transpose33 !************************************************************************** ! Cramer inversion of 33 matrix (function) !************************************************************************** - pure function math_inv33(A) +pure function math_inv33(A) ! direct Cramer inversion of matrix A. ! returns all zeroes if not possible, i.e. if det close to zero @@ -808,13 +811,13 @@ pure function math_transpose33(A) math_inv33(3,3) = ( A(1,1) * A(2,2) - A(1,2) * A(2,1)) / DetA endif - endfunction math_inv33 +end function math_inv33 !************************************************************************** ! Cramer inversion of 33 matrix (subroutine) !************************************************************************** - PURE SUBROUTINE math_invert33(A, InvA, DetA, error) +pure subroutine math_invert33(A, InvA, DetA, error) ! Bestimmung der Determinanten und Inversen einer 33-Matrix ! A = Matrix A @@ -851,13 +854,41 @@ pure function math_transpose33(A) error = .false. endif - ENDSUBROUTINE math_invert33 +end subroutine math_invert33 +!************************************************************************** +! Inversion of symmetriced 3x3x3x3 tensor. +!************************************************************************** +function math_invSym3333(A) + + use IO, only: IO_error + + implicit none + real(pReal),dimension(3,3,3,3) :: math_invSym3333 + + real(pReal),dimension(3,3,3,3),intent(in) :: A + + integer(pInt) :: ierr1, ierr2 + integer(pInt), dimension(6) :: ipiv6 + real(pReal), dimension(6,6) :: temp66_Real + real(pReal), dimension(6) :: work6 + + temp66_real = math_Mandel3333to66(A) + call dgetrf(6,6,temp66_real,6,ipiv6,ierr1) + call dgetri(6,temp66_real,6,ipiv6,work6,6,ierr2) + if (ierr1*ierr2 == 0_pInt) then + math_invSym3333 = math_Mandel66to3333(temp66_real) + else + call IO_error(400_pInt, ext_msg = 'math_invSym3333') + endif + +end function math_invSym3333 + !************************************************************************** ! Gauss elimination to invert matrix of arbitrary dimension !************************************************************************** - PURE SUBROUTINE math_invert(dimen,A, InvA, AnzNegEW, error) +pure subroutine math_invert(dimen,A, InvA, AnzNegEW, error) ! Invertieren einer dimen x dimen - Matrix ! A = Matrix A @@ -881,12 +912,12 @@ pure function math_transpose33(A) B = A CALL Gauss(dimen,B,InvA,LogAbsDetA,AnzNegEW,error) - ENDSUBROUTINE math_invert +end subroutine math_invert ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - PURE SUBROUTINE Gauss (dimen,A,B,LogAbsDetA,NegHDK,error) +pure subroutine Gauss (dimen,A,B,LogAbsDetA,NegHDK,error) ! Solves a linear EQS A * X = B with the GAUSS-Algorithm ! For numerical stabilization using a pivot search in rows and columns @@ -1034,13 +1065,13 @@ pure function math_transpose33(A) error = .false. - ENDSUBROUTINE Gauss +end subroutine Gauss !******************************************************************** ! symmetrize a 33 matrix !******************************************************************** - function math_symmetric33(m) +function math_symmetric33(m) implicit none @@ -1050,13 +1081,13 @@ pure function math_transpose33(A) forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) math_symmetric33(i,j) = 0.5_pReal * (m(i,j) + m(j,i)) - endfunction math_symmetric33 +end function math_symmetric33 !******************************************************************** ! symmetrize a 66 matrix !******************************************************************** - pure function math_symmetric66(m) +pure function math_symmetric66(m) implicit none @@ -1066,7 +1097,7 @@ pure function math_transpose33(A) forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) math_symmetric66(i,j) = 0.5_pReal * (m(i,j) + m(j,i)) - endfunction math_symmetric66 +end function math_symmetric66 !******************************************************************** @@ -1082,7 +1113,7 @@ pure function math_skew33(m) forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) math_skew33(i,j) = m(i,j) - 0.5_pReal * (m(i,j) + m(j,i)) -endfunction math_skew33 +end function math_skew33 !******************************************************************** @@ -1101,13 +1132,13 @@ pure function math_deviatoric33(m) math_deviatoric33 = m forall (i=1_pInt:3_pInt) math_deviatoric33(i,i) = m(i,i) - hydrostatic -endfunction math_deviatoric33 +end function math_deviatoric33 !******************************************************************** ! equivalent scalar quantity of a full strain tensor !******************************************************************** - pure function math_equivStrain33(m) +pure function math_equivStrain33(m) implicit none @@ -1124,10 +1155,10 @@ endfunction math_deviatoric33 math_equivStrain33 = 2.0_pReal*(1.50_pReal*(e11**2.0_pReal+e22**2.0_pReal+e33**2.0_pReal) + & 0.75_pReal*(s12**2.0_pReal+s23**2.0_pReal+s31**2.0_pReal))**(0.5_pReal)/3.0_pReal - endfunction math_equivStrain33 +end function math_equivStrain33 !******************************************************************** - subroutine math_equivStrain33_field(res,tensor,vm) +subroutine math_equivStrain33_field(res,tensor,vm) !******************************************************************** !calculate von Mises equivalent of tensor field ! @@ -1156,13 +1187,13 @@ endfunction math_deviatoric33 vm(i,j,k) = sqrt(3.0_pReal*J_2) enddo; enddo; enddo - end subroutine math_equivStrain33_field +end subroutine math_equivStrain33_field !******************************************************************** ! determinant of a 33 matrix !******************************************************************** - pure function math_det33(m) +pure function math_det33(m) implicit none @@ -1173,13 +1204,13 @@ endfunction math_deviatoric33 -m(1,2)*(m(2,1)*m(3,3)-m(2,3)*m(3,1)) & +m(1,3)*(m(2,1)*m(3,2)-m(2,2)*m(3,1)) - endfunction math_det33 +end function math_det33 !******************************************************************** ! norm of a 33 matrix !******************************************************************** - pure function math_norm33(m) +pure function math_norm33(m) implicit none @@ -1188,13 +1219,13 @@ endfunction math_deviatoric33 math_norm33 = sqrt(sum(m**2.0_pReal)) - endfunction +end function !******************************************************************** ! euclidic norm of a 3 vector !******************************************************************** - pure function math_norm3(v) +pure function math_norm3(v) implicit none @@ -1203,13 +1234,13 @@ endfunction math_deviatoric33 math_norm3 = sqrt(v(1)*v(1) + v(2)*v(2) + v(3)*v(3)) - endfunction math_norm3 +end function math_norm3 !******************************************************************** ! convert 33 matrix into vector 9 !******************************************************************** - pure function math_Plain33to9(m33) +pure function math_Plain33to9(m33) implicit none @@ -1219,13 +1250,13 @@ endfunction math_deviatoric33 forall (i=1_pInt:9_pInt) math_Plain33to9(i) = m33(mapPlain(1,i),mapPlain(2,i)) - endfunction math_Plain33to9 +end function math_Plain33to9 !******************************************************************** ! convert Plain 9 back to 33 matrix !******************************************************************** - pure function math_Plain9to33(v9) +pure function math_Plain9to33(v9) implicit none @@ -1235,13 +1266,13 @@ endfunction math_deviatoric33 forall (i=1_pInt:9_pInt) math_Plain9to33(mapPlain(1,i),mapPlain(2,i)) = v9(i) - endfunction math_Plain9to33 +end function math_Plain9to33 !******************************************************************** ! convert symmetric 33 matrix into Mandel vector 6 !******************************************************************** - pure function math_Mandel33to6(m33) +pure function math_Mandel33to6(m33) implicit none @@ -1251,13 +1282,13 @@ endfunction math_deviatoric33 forall (i=1_pInt:6_pInt) math_Mandel33to6(i) = nrmMandel(i)*m33(mapMandel(1,i),mapMandel(2,i)) - endfunction math_Mandel33to6 +end function math_Mandel33to6 !******************************************************************** ! convert Mandel 6 back to symmetric 33 matrix !******************************************************************** - pure function math_Mandel6to33(v6) +pure function math_Mandel6to33(v6) implicit none @@ -1270,13 +1301,13 @@ endfunction math_deviatoric33 math_Mandel6to33(mapMandel(2,i),mapMandel(1,i)) = invnrmMandel(i)*v6(i) end forall - endfunction math_Mandel6to33 +end function math_Mandel6to33 !******************************************************************** ! convert 3333 tensor into plain matrix 99 !******************************************************************** - pure function math_Plain3333to99(m3333) +pure function math_Plain3333to99(m3333) implicit none @@ -1287,12 +1318,12 @@ endfunction math_deviatoric33 forall (i=1_pInt:9_pInt,j=1_pInt:9_pInt) math_Plain3333to99(i,j) = & m3333(mapPlain(1,i),mapPlain(2,i),mapPlain(1,j),mapPlain(2,j)) - endfunction math_Plain3333to99 +end function math_Plain3333to99 !******************************************************************** ! plain matrix 99 into 3333 tensor !******************************************************************** - pure function math_Plain99to3333(m99) +pure function math_Plain99to3333(m99) implicit none @@ -1303,13 +1334,13 @@ endfunction math_deviatoric33 forall (i=1_pInt:9_pInt,j=1_pInt:9_pInt) math_Plain99to3333(mapPlain(1,i),mapPlain(2,i),& mapPlain(1,j),mapPlain(2,j)) = m99(i,j) - endfunction math_Plain99to3333 +end function math_Plain99to3333 !******************************************************************** ! convert Mandel matrix 66 into Plain matrix 66 !******************************************************************** - pure function math_Mandel66toPlain66(m66) +pure function math_Mandel66toPlain66(m66) implicit none @@ -1321,13 +1352,13 @@ endfunction math_deviatoric33 math_Mandel66toPlain66(i,j) = invnrmMandel(i) * invnrmMandel(j) * m66(i,j) return - endfunction +end function !******************************************************************** ! convert Plain matrix 66 into Mandel matrix 66 !******************************************************************** - pure function math_Plain66toMandel66(m66) +pure function math_Plain66toMandel66(m66) implicit none @@ -1339,13 +1370,13 @@ endfunction math_deviatoric33 math_Plain66toMandel66(i,j) = nrmMandel(i) * nrmMandel(j) * m66(i,j) return - endfunction +end function !******************************************************************** ! convert symmetric 3333 tensor into Mandel matrix 66 !******************************************************************** - pure function math_Mandel3333to66(m3333) +pure function math_Mandel3333to66(m3333) implicit none @@ -1356,13 +1387,13 @@ endfunction math_deviatoric33 forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) math_Mandel3333to66(i,j) = & nrmMandel(i)*nrmMandel(j)*m3333(mapMandel(1,i),mapMandel(2,i),mapMandel(1,j),mapMandel(2,j)) - endfunction math_Mandel3333to66 +end function math_Mandel3333to66 !******************************************************************** ! convert Mandel matrix 66 back to symmetric 3333 tensor !******************************************************************** - pure function math_Mandel66to3333(m66) +pure function math_Mandel66to3333(m66) implicit none @@ -1377,13 +1408,13 @@ endfunction math_deviatoric33 math_Mandel66to3333(mapMandel(2,i),mapMandel(1,i),mapMandel(2,j),mapMandel(1,j)) = invnrmMandel(i)*invnrmMandel(j)*m66(i,j) end forall - endfunction math_Mandel66to3333 +end function math_Mandel66to3333 !******************************************************************** ! convert Voigt matrix 66 back to symmetric 3333 tensor !******************************************************************** - pure function math_Voigt66to3333(m66) +pure function math_Voigt66to3333(m66) implicit none @@ -1398,66 +1429,66 @@ endfunction math_deviatoric33 math_Voigt66to3333(mapVoigt(2,i),mapVoigt(1,i),mapVoigt(2,j),mapVoigt(1,j)) = invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) end forall - endfunction math_Voigt66to3333 +end function math_Voigt66to3333 !******************************************************************** ! Euler angles (in radians) from rotation matrix !******************************************************************** - pure function math_RtoEuler(R) +pure function math_RtoEuler(R) implicit none real(pReal), dimension (3,3), intent(in) :: R real(pReal), dimension(3) :: math_RtoEuler - real(pReal) :: sqhkl, squvw, sqhk, val + real(pReal) :: sqhkl, squvw, sqhk, myVal sqhkl=sqrt(R(1,3)*R(1,3)+R(2,3)*R(2,3)+R(3,3)*R(3,3)) squvw=sqrt(R(1,1)*R(1,1)+R(2,1)*R(2,1)+R(3,1)*R(3,1)) sqhk=sqrt(R(1,3)*R(1,3)+R(2,3)*R(2,3)) ! calculate PHI - val=R(3,3)/sqhkl + myVal=R(3,3)/sqhkl - if(val > 1.0_pReal) val = 1.0_pReal - if(val < -1.0_pReal) val = -1.0_pReal + if(myVal > 1.0_pReal) myVal = 1.0_pReal + if(myVal < -1.0_pReal) myVal = -1.0_pReal - math_RtoEuler(2) = acos(val) + math_RtoEuler(2) = acos(myVal) if(math_RtoEuler(2) < 1.0e-8_pReal) then ! calculate phi2 math_RtoEuler(3) = 0.0_pReal ! calculate phi1 - val=R(1,1)/squvw - if(val > 1.0_pReal) val = 1.0_pReal - if(val < -1.0_pReal) val = -1.0_pReal + myVal=R(1,1)/squvw + if(myVal > 1.0_pReal) myVal = 1.0_pReal + if(myVal < -1.0_pReal) myVal = -1.0_pReal - math_RtoEuler(1) = acos(val) + math_RtoEuler(1) = acos(myVal) if(R(2,1) > 0.0_pReal) math_RtoEuler(1) = 2.0_pReal*pi-math_RtoEuler(1) else ! calculate phi2 - val=R(2,3)/sqhk - if(val > 1.0_pReal) val = 1.0_pReal - if(val < -1.0_pReal) val = -1.0_pReal + myVal=R(2,3)/sqhk + if(myVal > 1.0_pReal) myVal = 1.0_pReal + if(myVal < -1.0_pReal) myVal = -1.0_pReal - math_RtoEuler(3) = acos(val) + math_RtoEuler(3) = acos(myVal) if(R(1,3) < 0.0) math_RtoEuler(3) = 2.0_pReal*pi-math_RtoEuler(3) ! calculate phi1 - val=-R(3,2)/sin(math_RtoEuler(2)) - if(val > 1.0_pReal) val = 1.0_pReal - if(val < -1.0_pReal) val = -1.0_pReal + myVal=-R(3,2)/sin(math_RtoEuler(2)) + if(myVal > 1.0_pReal) myVal = 1.0_pReal + if(myVal < -1.0_pReal) myVal = -1.0_pReal - math_RtoEuler(1) = acos(val) + math_RtoEuler(1) = acos(myVal) if(R(3,1) < 0.0) math_RtoEuler(1) = 2.0_pReal*pi-math_RtoEuler(1) end if - endfunction math_RtoEuler +end function math_RtoEuler !******************************************************************** ! quaternion (w+ix+jy+kz) from orientation matrix !******************************************************************** ! math adopted from http://code.google.com/p/mtex/source/browse/trunk/geometry/geometry_tools/mat2quat.m - pure function math_RtoQuaternion(R) +pure function math_RtoQuaternion(R) implicit none @@ -1505,13 +1536,13 @@ endfunction math_deviatoric33 math_RtoQuaternion = math_RtoQuaternion*0.25_pReal/max_absQ math_RtoQuaternion(largest(1)) = max_absQ - endfunction math_RtoQuaternion +end function math_RtoQuaternion !**************************************************************** ! rotation matrix from Euler angles (in radians) !**************************************************************** - pure function math_EulerToR(Euler) +pure function math_EulerToR(Euler) implicit none @@ -1536,13 +1567,13 @@ endfunction math_deviatoric33 math_EulerToR(3,2)=-C1*S math_EulerToR(3,3)=C - endfunction math_EulerToR +end function math_EulerToR !******************************************************************** ! quaternion (w+ix+jy+kz) from 3-1-3 Euler angles (in radians) !******************************************************************** - pure function math_EulerToQuaternion(eulerangles) +pure function math_EulerToQuaternion(eulerangles) implicit none @@ -1561,13 +1592,13 @@ endfunction math_deviatoric33 math_EulerToQuaternion(3) = sin(halfangles(1)-halfangles(3)) * s math_EulerToQuaternion(4) = sin(halfangles(1)+halfangles(3)) * c - endfunction math_EulerToQuaternion +end function math_EulerToQuaternion !**************************************************************** ! rotation matrix from axis and angle (in radians) !**************************************************************** - pure function math_AxisAngleToR(axis,omega) +pure function math_AxisAngleToR(axis,omega) implicit none @@ -1605,13 +1636,13 @@ endfunction math_deviatoric33 endif - endfunction math_AxisAngleToR +end function math_AxisAngleToR !**************************************************************** ! quaternion (w+ix+jy+kz) from axis and angle (in radians) !**************************************************************** - pure function math_AxisAngleToQuaternion(axis,omega) +pure function math_AxisAngleToQuaternion(axis,omega) implicit none @@ -1634,13 +1665,13 @@ endfunction math_deviatoric33 math_AxisAngleToQuaternion = (/1.0_pReal,0.0_pReal,0.0_pReal,0.0_pReal/) ! no rotation endif - endfunction math_AxisAngleToQuaternion +end function math_AxisAngleToQuaternion !******************************************************************** ! orientation matrix from quaternion (w+ix+jy+kz) !******************************************************************** - pure function math_QuaternionToR(Q) +pure function math_QuaternionToR(Q) implicit none @@ -1658,13 +1689,13 @@ endfunction math_deviatoric33 2.0_pReal * T - & 2.0_pReal * Q(1) * S - endfunction math_QuaternionToR +end function math_QuaternionToR !******************************************************************** ! 3-1-3 Euler angles (in radians) from quaternion (w+ix+jy+kz) !******************************************************************** - pure function math_QuaternionToEuler(Q) +pure function math_QuaternionToEuler(Q) implicit none @@ -1693,13 +1724,13 @@ endfunction math_deviatoric33 if (math_QuaternionToEuler(2) < 0.0_pReal) & math_QuaternionToEuler(2) = math_QuaternionToEuler(2) + pi - endfunction math_QuaternionToEuler +end function math_QuaternionToEuler !******************************************************************** ! axis-angle (x, y, z, ang in radians) from quaternion (w+ix+jy+kz) !******************************************************************** - pure function math_QuaternionToAxisAngle(Q) +pure function math_QuaternionToAxisAngle(Q) implicit none @@ -1717,13 +1748,13 @@ endfunction math_deviatoric33 math_QuaternionToAxisAngle(4) = halfAngle*2.0_pReal endif - endfunction math_QuaternionToAxisAngle +end function math_QuaternionToAxisAngle !******************************************************************** ! Rodrigues vector (x, y, z) from unit quaternion (w+ix+jy+kz) !******************************************************************** - pure function math_QuaternionToRodrig(Q) +pure function math_QuaternionToRodrig(Q) use prec, only: DAMASK_NaN implicit none @@ -1737,13 +1768,13 @@ endfunction math_deviatoric33 math_QuaternionToRodrig = DAMASK_NaN ! NaN since Rodrig is unbound for 180 deg... endif - endfunction math_QuaternionToRodrig +end function math_QuaternionToRodrig !************************************************************************** ! misorientation angle between two sets of Euler angles !************************************************************************** - pure function math_EulerMisorientation(EulerA,EulerB) +pure function math_EulerMisorientation(EulerA,EulerB) implicit none @@ -1756,7 +1787,7 @@ endfunction math_deviatoric33 tr = (r(1,1)+r(2,2)+r(3,3)-1.0_pReal)*0.4999999_pReal math_EulerMisorientation = abs(0.5_pReal*pi-asin(tr)) - endfunction math_EulerMisorientation +end function math_EulerMisorientation !************************************************************************** @@ -1790,7 +1821,7 @@ pure function math_QuaternionInSST(Q, symmetryType) math_QuaternionInSST = .true. end select -endfunction math_QuaternionInSST +end function math_QuaternionInSST !************************************************************************** @@ -1840,13 +1871,13 @@ function math_QuaternionDisorientation(Q1, Q2, symmetryType) call IO_error(450_pInt,symmetryType) ! complain about unknown symmetry end select -endfunction math_QuaternionDisorientation +end function math_QuaternionDisorientation !******************************************************************** ! draw a random sample from Euler space !******************************************************************** - function math_sampleRandomOri() +function math_sampleRandomOri() implicit none @@ -1857,14 +1888,14 @@ endfunction math_QuaternionDisorientation math_sampleRandomOri(2) = acos(2.0_pReal*rnd(2)-1.0_pReal) math_sampleRandomOri(3) = rnd(3)*2.0_pReal*pi - endfunction math_sampleRandomOri +end function math_sampleRandomOri !******************************************************************** ! draw a random sample from Gauss component ! with noise (in radians) half-width !******************************************************************** - function math_sampleGaussOri(center,noise) +function math_sampleGaussOri(center,noise) implicit none @@ -1895,14 +1926,14 @@ endif math_sampleGaussOri = math_RtoEuler(math_mul33x33(math_EulerToR(disturb),math_EulerToR(center))) - endfunction math_sampleGaussOri +end function math_sampleGaussOri !******************************************************************** ! draw a random sample from Fiber component ! with noise (in radians) !******************************************************************** - function math_sampleFiberOri(alpha,beta,noise) +function math_sampleFiberOri(alpha,beta,noise) implicit none @@ -1969,14 +2000,14 @@ endif ! ---# apply the three rotations #--- math_sampleFiberOri = math_RtoEuler(math_mul33x33(pRot,math_mul33x33(fRot,oRot))) - endfunction math_sampleFiberOri +end function math_sampleFiberOri !******************************************************************** ! symmetric Euler angles for given symmetry string ! 'triclinic' or '', 'monoclinic', 'orthotropic' !******************************************************************** - pure function math_symmetricEulers(sym,Euler) +pure function math_symmetricEulers(sym,Euler) implicit none @@ -2009,7 +2040,7 @@ endif math_symmetricEulers = 0.0_pReal end select - endfunction math_symmetricEulers +end function math_symmetricEulers !******************************************************************** @@ -2052,7 +2083,7 @@ enddo math_sampleGaussVar = scatter * stddev -endfunction math_sampleGaussVar +end function math_sampleGaussVar !**************************************************************** @@ -2072,12 +2103,11 @@ subroutine math_spectralDecompositionSym33(M,values,vectors,error) call DSYEV('V','U',3,vectors,3,values,work,(64+2)*3,info) error = (info == 0_pInt) - return end subroutine !**************************************************************** - pure subroutine math_pDecomposition(FE,U,R,error) +pure subroutine math_pDecomposition(FE,U,R,error) !-----FE = R.U !**************************************************************** implicit none @@ -2096,11 +2126,11 @@ end subroutine call math_invert33(U,UI,det,error) if (.not. error) R = math_mul33x33(FE,UI) - ENDSUBROUTINE math_pDecomposition +end subroutine math_pDecomposition !********************************************************************** - pure subroutine math_spectral1(M,EW1,EW2,EW3,EB1,EB2,EB3) +pure subroutine math_spectral1(M,EW1,EW2,EW3,EB1,EB2,EB3) !**** EIGENWERTE UND EIGENWERTBASIS DER SYMMETRISCHEN 3X3 MATRIX M implicit none @@ -2194,11 +2224,11 @@ end subroutine END IF END IF - ENDSUBROUTINE math_spectral1 +end subroutine math_spectral1 !********************************************************************** - function math_eigenvalues33(M) +function math_eigenvalues33(M) !**** Eigenvalues of symmetric 3X3 matrix M implicit none @@ -2239,13 +2269,13 @@ end subroutine math_eigenvalues33(2) = Y2-R/3.0_pReal math_eigenvalues33(3) = Y3-R/3.0_pReal endif - endfunction math_eigenvalues33 +end function math_eigenvalues33 !********************************************************************** !**** HAUPTINVARIANTEN HI1M, HI2M, HI3M DER 3X3 MATRIX M - PURE SUBROUTINE math_hi(M,HI1M,HI2M,HI3M) +pure subroutine math_hi(M,HI1M,HI2M,HI3M) implicit none @@ -2258,7 +2288,7 @@ end subroutine HI3M=math_det33(M) ! QUESTION: is 3rd equiv det(M) ?? if yes, use function math_det !agreed on YES - ENDSUBROUTINE math_hi +end subroutine math_hi !******************************************************************************* @@ -2278,7 +2308,7 @@ end subroutine ! Modified: 29 April 2005 ! Author: Franz Roters ! - SUBROUTINE get_seed(seed) +subroutine get_seed(seed) implicit none integer(pInt) :: seed @@ -2316,7 +2346,7 @@ end subroutine seed = seed -1_pInt end if - ENDSUBROUTINE get_seed +end subroutine get_seed !******************************************************************************* @@ -2332,7 +2362,7 @@ end subroutine ! Modified: 29 April 2005 ! Author: Franz Roters ! - subroutine halton(ndim, r) +subroutine halton(ndim, r) implicit none integer(pInt), intent(in) :: ndim @@ -2351,7 +2381,7 @@ end subroutine value_halton(1) = 1_pInt call halton_memory ('INC', 'SEED', 1_pInt, value_halton) - ENDSUBROUTINE halton +end subroutine halton !******************************************************************************* @@ -2387,7 +2417,7 @@ end subroutine ! Modified: 29 April 2005 ! Author: Franz Roters - subroutine halton_memory (action_halton, name_halton, ndim, value_halton) +subroutine halton_memory (action_halton, name_halton, ndim, value_halton) implicit none character(len = *), intent(in) :: action_halton, name_halton @@ -2463,7 +2493,7 @@ end subroutine end if endif - ENDSUBROUTINE halton_memory +end subroutine halton_memory !******************************************************************************* @@ -2478,7 +2508,7 @@ end subroutine ! Modified: 29 April 2005 ! Author: Franz Roters ! - subroutine halton_ndim_set (ndim) +subroutine halton_ndim_set (ndim) implicit none integer(pInt), intent(in) :: ndim @@ -2487,7 +2517,7 @@ end subroutine value_halton(1) = ndim call halton_memory ('SET', 'NDIM', 1_pInt, value_halton) - ENDSUBROUTINE halton_ndim_set +end subroutine halton_ndim_set !******************************************************************************* @@ -2514,7 +2544,7 @@ end subroutine ! Modified: 29 April 2005 ! Author: Franz Roters ! - subroutine halton_seed_set (seed) +subroutine halton_seed_set (seed) implicit none integer(pInt), parameter :: ndim = 1_pInt @@ -2524,7 +2554,7 @@ end subroutine value_halton(1) = seed call halton_memory ('SET', 'SEED', ndim, value_halton) - ENDSUBROUTINE halton_seed_set +end subroutine halton_seed_set !******************************************************************************* @@ -2554,7 +2584,9 @@ end subroutine ! Modified: 29 April 2005 ! Author: Franz RotersA - subroutine i_to_halton (seed, base, ndim, r) +subroutine i_to_halton (seed, base, ndim, r) + + use IO, only: IO_error implicit none integer(pInt), intent(in) :: ndim @@ -2580,7 +2612,7 @@ end subroutine seed2(1:ndim) = seed2(1:ndim) / base(1:ndim) enddo - ENDSUBROUTINE i_to_halton +end subroutine i_to_halton !******************************************************************************* @@ -2610,7 +2642,9 @@ end subroutine ! Modified: 29 April 2005 ! Author: Franz Roters ! - function prime(n) +function prime(n) + + use IO, only: IO_error implicit none integer(pInt), parameter :: prime_max = 1500_pInt @@ -2813,13 +2847,13 @@ end subroutine else call IO_error(error_ID=406_pInt) end if - endfunction prime +end function prime !************************************************************************** ! volume of tetrahedron given by four vertices !************************************************************************** - pure function math_volTetrahedron(v1,v2,v3,v4) +pure function math_volTetrahedron(v1,v2,v3,v4) implicit none @@ -2833,13 +2867,13 @@ end subroutine math_volTetrahedron = math_det33(m)/6.0_pReal - endfunction math_volTetrahedron +end function math_volTetrahedron !************************************************************************** ! rotate 33 tensor forward !************************************************************************** - pure function math_rotate_forward33(tensor,rot_tensor) +pure function math_rotate_forward33(tensor,rot_tensor) implicit none @@ -2849,13 +2883,13 @@ end subroutine math_rotate_forward33 = math_mul33x33(rot_tensor,& math_mul33x33(tensor,math_transpose33(rot_tensor))) - endfunction math_rotate_forward33 +end function math_rotate_forward33 !************************************************************************** ! rotate 33 tensor backward !************************************************************************** - pure function math_rotate_backward33(tensor,rot_tensor) +pure function math_rotate_backward33(tensor,rot_tensor) implicit none @@ -2865,14 +2899,14 @@ end subroutine math_rotate_backward33 = math_mul33x33(math_transpose33(rot_tensor),& math_mul33x33(tensor,rot_tensor)) - endfunction math_rotate_backward33 +end function math_rotate_backward33 !************************************************************************** ! rotate 3333 tensor ! C'_ijkl=g_im*g_jn*g_ko*g_lp*C_mnop !************************************************************************** - pure function math_rotate_forward3333(tensor,rot_tensor) +pure function math_rotate_forward3333(tensor,rot_tensor) implicit none @@ -2889,7 +2923,7 @@ end subroutine rot_tensor(o,k)*rot_tensor(p,l)*tensor(m,n,o,p) enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo - endfunction math_rotate_forward3333 +end function math_rotate_forward3333 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -2899,7 +2933,7 @@ end subroutine !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! put the next two funtions into mesh? - function mesh_location(idx,resolution) +function mesh_location(idx,resolution) ! small helper functions for indexing ! CAREFULL, index and location runs from 0 to N-1 (python style) @@ -2910,7 +2944,7 @@ end subroutine modulo(idx/ resolution(3), resolution(2)), & modulo(idx, resolution(3))/) - end function mesh_location +end function mesh_location function mesh_index(location,resolution) @@ -2923,18 +2957,20 @@ end subroutine (modulo(location(2), resolution(2)))*resolution(3) +& (modulo(location(1), resolution(1)))*resolution(3)*resolution(2) - end function mesh_index +end function mesh_index !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - subroutine volume_compare(res,geomdim,defgrad,nodes,volume_mismatch) +subroutine volume_compare(res,geomdim,defgrad,nodes,volume_mismatch) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Routine to calculate the mismatch between volume of reconstructed (compatible ! cube and determinant of defgrad at the FP - use debug, only: debug_verbosity - implicit none + use debug, only: debug_math, & + debug_what, & + debug_levelBasic + implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res real(pReal), intent(in), dimension(3) :: geomdim @@ -2947,7 +2983,7 @@ end subroutine integer(pInt) i,j,k real(pReal) vol_initial - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Calculating volume mismatch' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res @@ -2985,9 +3021,11 @@ subroutine shape_compare(res,geomdim,defgrad,nodes,centroids,shape_mismatch) ! the corners of reconstructed (combatible) volume element and the vectors calculated by deforming ! the initial volume element with the current deformation gradient - use debug, only: debug_verbosity + use debug, only: debug_math, & + debug_what, & + debug_levelBasic + implicit none - ! input variables integer(pInt), intent(in), dimension(3) :: res real(pReal), intent(in), dimension(3) :: geomdim @@ -3000,7 +3038,7 @@ subroutine shape_compare(res,geomdim,defgrad,nodes,centroids,shape_mismatch) real(pReal), dimension(8,3) :: coords_initial integer(pInt) i,j,k - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Calculating shape mismatch' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res @@ -3054,7 +3092,7 @@ subroutine shape_compare(res,geomdim,defgrad,nodes,centroids,shape_mismatch) - matmul(defgrad(i,j,k,1:3,1:3), coords_initial(8,1:3)))**2.0_pReal)) enddo; enddo; enddo - end subroutine shape_compare +end subroutine shape_compare !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -3062,7 +3100,10 @@ subroutine mesh_regular_grid(res,geomdim,defgrad_av,centroids,nodes) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Routine to build mesh of (distoreted) cubes for given coordinates (= center of the cubes) ! - use debug, only: debug_verbosity + use debug, only: debug_math, & + debug_what, & + debug_levelBasic + implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res @@ -3089,7 +3130,7 @@ subroutine mesh_regular_grid(res,geomdim,defgrad_av,centroids,nodes) /), & (/3,8/)) - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Meshing cubes around centroids' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res @@ -3133,7 +3174,10 @@ subroutine deformed_linear(res,geomdim,defgrad_av,defgrad,coord_avgCorner) ! Routine to calculate coordinates in current configuration for given defgrad ! using linear interpolation (blurres out high frequency defomation) ! - use debug, only: debug_verbosity + use debug, only: debug_math, & + debug_what, & + debug_levelBasic + implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res @@ -3181,7 +3225,7 @@ subroutine deformed_linear(res,geomdim,defgrad_av,defgrad,coord_avgCorner) /), & (/3,6/)) - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Restore geometry using linear integration' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res @@ -3246,8 +3290,12 @@ subroutine deformed_fft(res,geomdim,defgrad_av,scaling,defgrad,coords) ! Routine to calculate coordinates in current configuration for given defgrad ! using integration in Fourier space (more accurate than deformed(...)) ! + use IO, only: IO_error use numerics, only: fftw_timelimit, fftw_planner_flag - use debug, only: debug_verbosity + use debug, only: debug_math, & + debug_what, & + debug_levelBasic + implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res @@ -3271,7 +3319,7 @@ subroutine deformed_fft(res,geomdim,defgrad_av,scaling,defgrad,coords) integrator = geomdim / 2.0_pReal / pi ! see notes where it is used - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Restore geometry using FFT-based integration' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res @@ -3371,8 +3419,12 @@ subroutine curl_fft(res,geomdim,vec_tens,field,curl) ! calculates curl field using differentation in Fourier space ! use vec_tens to decide if tensor (3) or vector (1) + use IO, only: IO_error use numerics, only: fftw_timelimit, fftw_planner_flag - use debug, only: debug_verbosity + use debug, only: debug_math, & + debug_what, & + debug_levelBasic + implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res @@ -3395,7 +3447,7 @@ subroutine curl_fft(res,geomdim,vec_tens,field,curl) integer(pInt), dimension(3) :: k_s real(pReal) :: wgt - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Calculating curl of vector/tensor field' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res @@ -3457,11 +3509,11 @@ subroutine curl_fft(res,geomdim,vec_tens,field,curl) do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res1_red do l = 1_pInt, vec_tens curl_fourier(i,j,k,l,1) = ( field_fourier(i,j,k,l,3)*xi(i,j,k,2)& - -field_fourier(i,j,k,l,2)*xi(i,j,k,3) )*two_pi_img + -field_fourier(i,j,k,l,2)*xi(i,j,k,3) )*TWOPIIMG curl_fourier(i,j,k,l,2) = (-field_fourier(i,j,k,l,3)*xi(i,j,k,1)& - +field_fourier(i,j,k,l,1)*xi(i,j,k,3) )*two_pi_img + +field_fourier(i,j,k,l,1)*xi(i,j,k,3) )*TWOPIIMG curl_fourier(i,j,k,l,3) = ( field_fourier(i,j,k,l,2)*xi(i,j,k,1)& - -field_fourier(i,j,k,l,1)*xi(i,j,k,2) )*two_pi_img + -field_fourier(i,j,k,l,1)*xi(i,j,k,2) )*TWOPIIMG enddo enddo; enddo; enddo @@ -3488,9 +3540,13 @@ subroutine divergence_fft(res,geomdim,vec_tens,field,divergence) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! calculates divergence field using integration in Fourier space ! use vec_tens to decide if tensor (3) or vector (1) - + + use IO, only: IO_error use numerics, only: fftw_timelimit, fftw_planner_flag - use debug, only: debug_verbosity + use debug, only: debug_math, & + debug_what, & + debug_levelBasic + implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res @@ -3513,7 +3569,7 @@ subroutine divergence_fft(res,geomdim,vec_tens,field,divergence) real(pReal) :: wgt integer(pInt), dimension(3) :: k_s - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_math),debug_levelBasic) /= 0_pInt) then print '(a)', 'Calculating divergence of tensor/vector field using FFT' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res @@ -3572,7 +3628,7 @@ if (pReal /= C_DOUBLE .or. pInt /= C_INT) call IO_error(error_ID=808_pInt) do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res1_red do l = 1_pInt, vec_tens divergence_fourier(i,j,k,l)=sum(field_fourier(i,j,k,l,1:3)*cmplx(xi(i,j,k,1:3),0.0_pReal,pReal))& - *two_pi_img + *TWOPIIMG enddo enddo; enddo; enddo call fftw_execute_dft_c2r(fftw_back, divergence_fourier, divergence_real) @@ -3591,16 +3647,19 @@ if (pReal /= C_DOUBLE .or. pInt /= C_INT) call IO_error(error_ID=808_pInt) call fftw_free(field_fftw) ! This procedure ensures that optimization do not mix-up lines, because a if(.not.(c_associated(C_LOC(divergence_real(1,1,1,1))) .and. c_associated(C_LOC(divergence_fourier(1,1,1,1)))))& ! simple fftw_free(field_fftw) could be done immediately after the last line where field_fftw appears, e.g: call fftw_free(divergence_fftw) ! call c_f_pointer(field_fftw, field_fourier, [res1_red ,res(2),res(3),vec_tens,3]) - end subroutine divergence_fft +end subroutine divergence_fft !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - subroutine divergence_fdm(res,geomdim,vec_tens,order,field,divergence) +subroutine divergence_fdm(res,geomdim,vec_tens,order,field,divergence) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! calculates divergence field using FDM with variable accuracy ! use vec_tes to decide if tensor (3) or vector (1) - use debug, only: debug_verbosity + use debug, only: debug_math, & + debug_what, & + debug_levelBasic + implicit none integer(pInt), intent(in), dimension(3) :: res integer(pInt), intent(in) :: vec_tens @@ -3619,7 +3678,7 @@ if (pReal /= C_DOUBLE .or. pInt /= C_INT) call IO_error(error_ID=808_pInt) 4.0_pReal/5.0_pReal,-1.0_pReal/ 5.0_pReal,4.0_pReal/105.0_pReal,-1.0_pReal/280.0_pReal/),& (/4,4/)) - if (debug_verbosity > 0_pInt) then + if (iand(debug_what(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Calculating divergence of tensor/vector field using FDM' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res @@ -3653,10 +3712,10 @@ if (pReal /= C_DOUBLE .or. pInt /= C_INT) call IO_error(error_ID=808_pInt) enddo enddo; enddo; enddo - end subroutine divergence_fdm +end subroutine divergence_fdm !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - subroutine tensor_avg(res,tensor,avg) +subroutine tensor_avg(res,tensor,avg) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !calculate average of tensor field ! @@ -3676,7 +3735,7 @@ if (pReal /= C_DOUBLE .or. pInt /= C_INT) call IO_error(error_ID=808_pInt) avg(m,n) = sum(tensor(1:res(1),1:res(2),1:res(3),m,n)) * wgt enddo; enddo - end subroutine tensor_avg +end subroutine tensor_avg !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine logstrain_spat(res,defgrad,logstrain_field) @@ -3708,7 +3767,7 @@ subroutine logstrain_spat(res,defgrad,logstrain_field) eigenvalue(3)*eigenvectorbasis(3,1:3,1:3) enddo; enddo; enddo - end subroutine logstrain_spat +end subroutine logstrain_spat !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine logstrain_mat(res,defgrad,logstrain_field) @@ -3738,7 +3797,7 @@ subroutine logstrain_mat(res,defgrad,logstrain_field) eigenvalue(3)*eigenvectorbasis(3,1:3,1:3) enddo; enddo; enddo - end subroutine logstrain_mat +end subroutine logstrain_mat !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine calculate_cauchy(res,defgrad,p_stress,c_stress) @@ -3804,6 +3863,6 @@ subroutine find_nearest_neighbor(res,geomdim,defgrad_av,spatial_dim,range_dim,do map_range_to_domain(i) = map_1range_to_domain(1)%idx enddo - end subroutine +end subroutine -END MODULE math +end module math diff --git a/code/mesh.f90 b/code/mesh.f90 index e8c0c5bc4..bb0d329b5 100644 --- a/code/mesh.f90 +++ b/code/mesh.f90 @@ -22,85 +22,83 @@ MODULE mesh !############################################################## - use prec, only: pReal,pInt + use prec, only: pReal, pInt implicit none + private + + integer(pInt), public :: & + mesh_NcpElems, & ! total number of CP elements in mesh + mesh_NelemSets, & + mesh_maxNelemInSet, & + mesh_Nmaterials, & + mesh_Nnodes, & ! total number of nodes in mesh + mesh_maxNnodes, & ! max number of nodes in any CP element + mesh_maxNips, & ! max number of IPs in any CP element + mesh_maxNipNeighbors, & ! max number of IP neighbors in any CP element + mesh_maxNsharedElems, & ! max number of CP elements sharing a node + mesh_maxNsubNodes -! --------------------------- -! _Nelems : total number of elements in mesh -! _NcpElems : total number of CP elements in mesh -! _Nnodes : total number of nodes in mesh -! _maxNnodes : max number of nodes in any CP element -! _maxNips : max number of IPs in any CP element -! _maxNipNeighbors : max number of IP neighbors in any CP element -! _maxNsharedElems : max number of CP elements sharing a node -! -! _element : FEid, type(internal representation), material, texture, node indices -! _node0 : x,y,z coordinates (initially!) -! _node : x,y,z coordinates (after deformation!) -! _sharedElem : entryCount and list of elements containing node -! -! _mapFEtoCPelem : [sorted FEid, corresponding CPid] -! _mapFEtoCPnode : [sorted FEid, corresponding CPid] -! -! MISSING: these definitions should actually reside in the -! FE-solver specific part (different for MARC/ABAQUS)..! + integer(pInt), dimension(:,:), allocatable, public :: & + mesh_element, & ! FEid, type(internal representation), material, texture, node indices + mesh_sharedElem, & ! entryCount and list of elements containing node + mesh_nodeTwins ! node twins are surface nodes that lie exactly on opposite sides of the mesh (surfaces nodes with equal coordinate values in two dimensions) + + integer(pInt), dimension(:,:,:,:), allocatable, public :: & + mesh_ipNeighborhood ! 6 or less neighboring IPs as [element_num, IP_index] + + real(pReal), dimension(:,:), allocatable, public :: & + mesh_ipVolume, & ! volume associated with IP (initially!) + mesh_node0, & ! node x,y,z coordinates (initially!) + mesh_node ! node x,y,z coordinates (after deformation! ONLY FOR MARC!!!) + + real(pReal), dimension(:,:,:), allocatable, public :: & + mesh_ipCenterOfGravity, & ! center of gravity of IP (after deformation!) + mesh_ipArea ! area of interface to neighboring IP (initially!) + + real(pReal),dimension(:,:,:,:), allocatable, public :: & + mesh_ipAreaNormal ! area normal of interface to neighboring IP (initially!) + + logical, dimension(3), public :: mesh_periodicSurface ! flag indicating periodic outer surfaces (used for fluxes) + + integer(pInt), private :: & + mesh_Nelems, & ! total number of elements in mesh + hypoelasticTableStyle, & + initialcondTableStyle + + integer(pInt), dimension(2), private :: & + mesh_maxValStateVar = 0_pInt + + character(len=64), dimension(:), allocatable, private :: & + mesh_nameElemSet, & ! names of elementSet + mesh_nameMaterial, & ! names of material in solid section + mesh_mapMaterial ! name of elementSet for material + + integer(pInt), dimension(:,:), allocatable, private :: & + mesh_mapElemSet ! list of elements in elementSet + + integer(pInt), dimension(:,:), allocatable, target, private :: & + mesh_mapFEtoCPelem, & ! [sorted FEid, corresponding CPid] + mesh_mapFEtoCPnode ! [sorted FEid, corresponding CPid] + + real(pReal),dimension(:,:,:), allocatable, private :: & + mesh_subNodeCoord ! coordinates of subnodes per element + + logical, private :: noPart ! for cases where the ABAQUS input file does not use part/assembly information + + +! Thee definitions should actually reside in the FE-solver specific part (different for MARC/ABAQUS) ! Hence, I suggest to prefix with "FE_" -! -! _Nnodes : # nodes in a specific type of element (how we use it) -! _NoriginalNodes : # nodes in a specific type of element (how it is originally defined by marc) -! _Nips : # IPs in a specific type of element -! _NipNeighbors : # IP neighbors in a specific type of element -! _ipNeighbor : +x,-x,+y,-y,+z,-z list of intra-element IPs and -! (negative) neighbor faces per own IP in a specific type of element -! _NfaceNodes : # nodes per face in a specific type of element -! _nodeOnFace : list of node indices on each face of a specific type of element -! _maxNnodesAtIP : max number of (equivalent) nodes attached to an IP -! _nodesAtIP : map IP index to two node indices in a specific type of element -! _NsubNodes : # subnodes required to fully define all IP volumes - -! order is +x,-x,+y,-y,+z,-z but meaning strongly depends on Elemtype -! --------------------------- - integer(pInt) mesh_Nelems, mesh_NcpElems, mesh_NelemSets, mesh_maxNelemInSet - integer(pInt) mesh_Nmaterials - integer(pInt) mesh_Nnodes, mesh_maxNnodes, mesh_maxNips, mesh_maxNipNeighbors, mesh_maxNsharedElems, mesh_maxNsubNodes - integer(pInt), dimension(2) :: mesh_maxValStateVar = 0_pInt - character(len=64), dimension(:), allocatable :: mesh_nameElemSet, & ! names of elementSet - mesh_nameMaterial, & ! names of material in solid section - mesh_mapMaterial ! name of elementSet for material - integer(pInt), dimension(:,:), allocatable :: mesh_mapElemSet ! list of elements in elementSet - integer(pInt), dimension(:,:), allocatable, target :: mesh_mapFEtoCPelem, mesh_mapFEtoCPnode - integer(pInt), dimension(:,:), allocatable :: mesh_element, & ! FEid, type(internal representation), material, texture, node indices - mesh_sharedElem, & ! entryCount and list of elements containing node - mesh_nodeTwins ! node twins are surface nodes that lie exactly on opposite sides of the mesh (surfaces nodes with equal coordinate values in two dimensions) - integer(pInt), dimension(:,:,:,:), allocatable :: mesh_ipNeighborhood ! 6 or less neighboring IPs as [element_num, IP_index] - - real(pReal), dimension(:,:,:), allocatable :: mesh_subNodeCoord ! coordinates of subnodes per element - real(pReal), dimension(:,:), allocatable :: mesh_node0, & ! node coordinates (initially!) - mesh_node, & ! node coordinates (after deformation! ONLY FOR MARC!!!) - mesh_ipVolume ! volume associated with IP (initially!) - real(pReal), dimension(:,:,:), allocatable :: mesh_ipArea, & ! area of interface to neighboring IP (initially!) - mesh_ipCenterOfGravity ! center of gravity of IP (after deformation!) - real(pReal), dimension(:,:,:,:), allocatable :: mesh_ipAreaNormal ! area normal of interface to neighboring IP (initially!) - - integer(pInt), dimension(:,:,:), allocatable :: FE_nodesAtIP ! map IP index to two node indices in a specific type of element - integer(pInt), dimension(:,:,:), allocatable :: FE_ipNeighbor - integer(pInt), dimension(:,:,:), allocatable :: FE_subNodeParent - integer(pInt), dimension(:,:,:,:), allocatable :: FE_subNodeOnIPFace - - logical :: noPart ! for cases where the ABAQUS input file does not use part/assembly information - logical, dimension(3) :: mesh_periodicSurface ! flag indicating periodic outer surfaces (used for fluxes) - - integer(pInt) :: hypoelasticTableStyle - integer(pInt) :: initialcondTableStyle - integer(pInt), parameter :: FE_Nelemtypes = 10_pInt - integer(pInt), parameter :: FE_maxNnodes = 8_pInt - integer(pInt), parameter :: FE_maxNsubNodes = 56_pInt - integer(pInt), parameter :: FE_maxNips = 27_pInt - integer(pInt), parameter :: FE_maxNipNeighbors = 6_pInt - integer(pInt), parameter :: FE_maxmaxNnodesAtIP = 8_pInt - integer(pInt), parameter :: FE_NipFaceNodes = 4_pInt - integer(pInt), dimension(FE_Nelemtypes), parameter :: FE_Nnodes = & + integer(pInt), parameter, public :: & + FE_Nelemtypes = 10_pInt, & + FE_maxNnodes = 8_pInt, & + FE_maxNsubNodes = 56_pInt, & + FE_maxNips = 27_pInt, & + FE_maxNipNeighbors = 6_pInt, & + FE_maxmaxNnodesAtIP = 8_pInt, & ! max number of (equivalent) nodes attached to an IP + FE_NipFaceNodes = 4_pInt + + integer(pInt), dimension(FE_Nelemtypes), parameter, public :: FE_Nnodes = & ! nodes in a specific type of element (how we use it) int([8, & ! element 7 4, & ! element 134 4, & ! element 11 @@ -112,19 +110,7 @@ 8, & ! element 57 (c3d20r == c3d8 --> copy of 7) 3 & ! element 155, 125, 128 ],pInt) - integer(pInt), dimension(FE_Nelemtypes), parameter :: FE_NoriginalNodes = & - int([8, & ! element 7 - 4, & ! element 134 - 4, & ! element 11 - 8, & ! element 27 - 4, & ! element 157 - 6, & ! element 136 - 20,& ! element 21 - 8, & ! element 117 - 20,& ! element 57 (c3d20r == c3d8 --> copy of 7) - 6 & ! element 155, 125, 128 - ],pInt) - integer(pInt), dimension(FE_Nelemtypes), parameter :: FE_Nips = & + integer(pInt), dimension(FE_Nelemtypes), parameter, public :: FE_Nips = & ! IPs in a specific type of element int([8, & ! element 7 1, & ! element 134 4, & ! element 11 @@ -136,7 +122,7 @@ 8, & ! element 57 (c3d20r == c3d8 --> copy of 7) 3 & ! element 155, 125, 128 ],pInt) - integer(pInt), dimension(FE_Nelemtypes), parameter :: FE_NipNeighbors = & + integer(pInt), dimension(FE_Nelemtypes), parameter, public :: FE_NipNeighbors = & !IP neighbors in a specific type of element int([6, & ! element 7 4, & ! element 134 4, & ! element 11 @@ -148,8 +134,8 @@ 6, & ! element 57 (c3d20r == c3d8 --> copy of 7) 4 & ! element 155, 125, 128 ],pInt) - integer(pInt), dimension(FE_Nelemtypes), parameter :: FE_NsubNodes = & - int([19,& ! element 7 + integer(pInt), dimension(FE_Nelemtypes), parameter, private :: FE_NsubNodes = & ! subnodes required to fully define all IP volumes + int([19,& ! element 7 ! order is +x,-x,+y,-y,+z,-z but meaning strongly depends on Elemtype 0, & ! element 134 5, & ! element 11 12,& ! element 27 @@ -160,7 +146,19 @@ 19,& ! element 57 (c3d20r == c3d8 --> copy of 7) 4 & ! element 155, 125, 128 ],pInt) - integer(pInt), dimension(FE_maxNipNeighbors,FE_Nelemtypes), parameter :: FE_NfaceNodes = & + integer(pInt), dimension(FE_Nelemtypes), parameter, private :: FE_NoriginalNodes = & ! nodes in a specific type of element (how it is originally defined by marc) + int([8, & ! element 7 + 4, & ! element 134 + 4, & ! element 11 + 8, & ! element 27 + 4, & ! element 157 + 6, & ! element 136 + 20,& ! element 21 + 8, & ! element 117 + 20,& ! element 57 (c3d20r == c3d8 --> copy of 7) + 6 & ! element 155, 125, 128 + ],pInt) + integer(pInt), dimension(FE_maxNipNeighbors,FE_Nelemtypes), parameter, private :: FE_NfaceNodes = &! nodes per face in a specific type of element reshape(int([& 4,4,4,4,4,4, & ! element 7 3,3,3,3,0,0, & ! element 134 @@ -172,8 +170,8 @@ 4,4,4,4,4,4, & ! element 117 4,4,4,4,4,4, & ! element 57 (c3d20r == c3d8 --> copy of 7) 2,2,2,0,0,0 & ! element 155, 125, 128 - ],pInt),(/FE_maxNipNeighbors,FE_Nelemtypes/)) - integer(pInt), dimension(FE_Nelemtypes), parameter :: FE_maxNnodesAtIP = & + ],pInt),[FE_maxNipNeighbors,FE_Nelemtypes]) + integer(pInt), dimension(FE_Nelemtypes), parameter, private :: FE_maxNnodesAtIP = & ! map IP index to two node indices in a specific type of element int([1, & ! element 7 4, & ! element 134 1, & ! element 11 @@ -185,7 +183,8 @@ 1, & ! element 57 (c3d20r == c3d8 --> copy of 7) 1 & ! element 155, 125, 128 ],pInt) - integer(pInt), dimension(FE_NipFaceNodes,FE_maxNipNeighbors,FE_Nelemtypes), parameter :: FE_nodeOnFace = & + integer(pInt), dimension(FE_NipFaceNodes,FE_maxNipNeighbors,FE_Nelemtypes), parameter, private :: & + FE_nodeOnFace = & ! List of node indices on each face of a specific type of element reshape(int([& 1,2,3,4 , & ! element 7 2,1,5,6 , & @@ -247,31 +246,77 @@ 0,0,0,0 , & 0,0,0,0 , & 0,0,0,0 & - ],pInt),(/FE_NipFaceNodes,FE_maxNipNeighbors,FE_Nelemtypes/)) - - CONTAINS -! --------------------------- -! subroutine mesh_init() -! function mesh_FEtoCPelement(FEid) -! function mesh_build_ipNeighorhood() -! --------------------------- + ],pInt),[FE_NipFaceNodes,FE_maxNipNeighbors,FE_Nelemtypes]) + + integer(pInt), dimension(:,:,:), allocatable, private :: & + FE_nodesAtIP, & ! map IP index to two node indices in a specific type of element + FE_ipNeighbor, & ! +x,-x,+y,-y,+z,-z list of intra-element IPs and(negative) neighbor faces per own IP in a specific type of element + FE_subNodeParent + + integer(pInt), dimension(:,:,:,:), allocatable, private :: & + FE_subNodeOnIPFace + + public :: mesh_init, & + mesh_FEasCP, & + mesh_build_subNodeCoords, & + mesh_build_ipVolumes, & + mesh_build_ipCoordinates + private :: FE_mapElemtype, & + mesh_faceMatch, & + mesh_build_FEdata, & + mesh_marc_get_tableStyles, & + mesh_get_damaskOptions, & + mesh_spectral_count_nodesAndElements, & + mesh_marc_count_nodesAndElements, & + mesh_abaqus_count_nodesAndElements, & + mesh_abaqus_count_elementSets, & + mesh_abaqus_count_materials, & + mesh_spectral_count_cpElements, & + mesh_abaqus_count_cpElements, & + mesh_marc_map_elementSets, & + mesh_abaqus_map_elementSets, & + mesh_abaqus_map_materials, & + mesh_spectral_map_nodes, & + mesh_marc_map_nodes, & + mesh_abaqus_map_nodes, & + mesh_marc_map_elements, & + mesh_abaqus_map_elements, & + mesh_spectral_count_cpSizes, & + mesh_marc_count_cpSizes, & + mesh_abaqus_count_cpSizes, & + mesh_spectral_build_nodes, & + mesh_marc_build_nodes, & + mesh_abaqus_build_nodes, & + mesh_spectral_build_elements, & + mesh_marc_build_elements, & + mesh_abaqus_build_elements, & + mesh_build_ipNeighborhood, & + mesh_build_ipAreas, & + mesh_build_nodeTwins, & + mesh_tell_statistics +contains !*********************************************************** ! initialization !*********************************************************** - subroutine mesh_init (ip,element) +subroutine mesh_init(ip,element) use DAMASK_interface - use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) - use prec, only: pInt - use IO, only: IO_error,IO_open_InputFile,IO_abaqus_hasNoPart - use FEsolving, only: parallelExecution, FEsolving_execElem, FEsolving_execIP, calcMode, lastMode, FEmodelGeometry + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: IO_error, & + IO_open_InputFile, & + IO_abaqus_hasNoPart + use FEsolving, only: parallelExecution, & + FEsolving_execElem, & + FEsolving_execIP, & + calcMode, & + lastMode, & + FEmodelGeometry implicit none - integer(pInt), parameter :: fileUnit = 222_pInt - integer(pInt) e,element,ip + integer(pInt) :: e, element, ip !$OMP CRITICAL (write2out) write(6,*) @@ -280,17 +325,17 @@ #include "compilation_info.f90" !$OMP END CRITICAL (write2out) - call mesh_build_FEdata() ! --- get properties of the different types of elements + call mesh_build_FEdata ! get properties of the different types of elements - call IO_open_inputFile(fileUnit,FEmodelGeometry) ! --- parse info from input file... + call IO_open_inputFile(fileUnit,FEmodelGeometry) ! parse info from input file... select case (FEsolver) case ('Spectral') call mesh_spectral_count_nodesAndElements(fileUnit) - call mesh_spectral_count_cpElements() - call mesh_spectral_map_elements() - call mesh_spectral_map_nodes() - call mesh_spectral_count_cpSizes() + call mesh_spectral_count_cpElements + call mesh_spectral_map_elements + call mesh_spectral_map_nodes + call mesh_spectral_count_cpSizes call mesh_spectral_build_nodes(fileUnit) call mesh_spectral_build_elements(fileUnit) @@ -322,14 +367,14 @@ call mesh_get_damaskOptions(fileUnit) close (fileUnit) - call mesh_build_subNodeCoords() - call mesh_build_ipCoordinates() - call mesh_build_ipVolumes() - call mesh_build_ipAreas() - call mesh_build_nodeTwins() - call mesh_build_sharedElems() - call mesh_build_ipNeighborhood() - call mesh_tell_statistics() + call mesh_build_subNodeCoords + call mesh_build_ipCoordinates + call mesh_build_ipVolumes + call mesh_build_ipAreas + call mesh_build_nodeTwins + call mesh_build_sharedElems + call mesh_build_ipNeighborhood + call mesh_tell_statistics parallelExecution = (parallelExecution .and. (mesh_Nelems == mesh_NcpElems)) ! plus potential killer from non-local constitutive @@ -341,21 +386,19 @@ calcMode = .false. ! pretend to have collected what first call is asking (F = I) calcMode(ip,mesh_FEasCP('elem',element)) = .true. ! first ip,el needs to be already pingponged to "calc" lastMode = .true. ! and its mode is already known... - endsubroutine - +end subroutine mesh_init + !*********************************************************** ! mapping of FE element types to internal representation !*********************************************************** - function FE_mapElemtype(what) +integer(pInt) function FE_mapElemtype(what) use IO, only: IO_lc implicit none - character(len=*), intent(in) :: what - integer(pInt) FE_mapElemtype select case (IO_lc(what)) case ( '7', & @@ -393,7 +436,7 @@ FE_mapElemtype = 0_pInt ! unknown element --> should raise an error upstream..! endselect - endfunction + end function FE_mapElemtype @@ -402,16 +445,16 @@ ! ! valid questions are 'elem', 'node' !*********************************************************** - function mesh_FEasCP(what,id) +integer(pInt) function mesh_FEasCP(what,myID) - use prec, only: pInt use IO, only: IO_lc + implicit none - character(len=*), intent(in) :: what - integer(pInt), intent(in) :: id + integer(pInt), intent(in) :: myID + integer(pInt), dimension(:,:), pointer :: lookupMap - integer(pInt) mesh_FEasCP, lower,upper,center + integer(pInt) :: lower,upper,center mesh_FEasCP = 0_pInt select case(IO_lc(what(1:4))) @@ -427,10 +470,10 @@ upper = int(size(lookupMap,2_pInt),pInt) ! check at bounds QUESTION is it valid to extend bounds by 1 and just do binary search w/o init check at bounds? - if (lookupMap(1_pInt,lower) == id) then + if (lookupMap(1_pInt,lower) == myID) then mesh_FEasCP = lookupMap(2_pInt,lower) return - elseif (lookupMap(1_pInt,upper) == id) then + elseif (lookupMap(1_pInt,upper) == myID) then mesh_FEasCP = lookupMap(2_pInt,upper) return endif @@ -438,9 +481,9 @@ ! binary search in between bounds do while (upper-lower > 1_pInt) center = (lower+upper)/2_pInt - if (lookupMap(1_pInt,center) < id) then + if (lookupMap(1_pInt,center) < myID) then lower = center - elseif (lookupMap(1_pInt,center) > id) then + elseif (lookupMap(1_pInt,center) > myID) then upper = center else mesh_FEasCP = lookupMap(2_pInt,center) @@ -448,7 +491,7 @@ endif enddo - endfunction +end function mesh_FEasCP !*********************************************************** @@ -456,58 +499,55 @@ !*********************************************************** subroutine mesh_faceMatch(elem, face ,matchingElem, matchingFace) -use prec, only: pInt implicit none - !*** output variables -integer(pInt), intent(out) :: matchingElem, & ! matching CP element ID - matchingFace ! matching FE face ID +integer(pInt), intent(out) :: matchingElem, & ! matching CP element ID + matchingFace ! matching FE face ID !*** input variables -integer(pInt), intent(in) :: face, & ! FE face ID - elem ! FE elem ID +integer(pInt), intent(in) :: face, & ! FE face ID + elem ! FE elem ID !*** local variables integer(pInt), dimension(FE_NfaceNodes(face,mesh_element(2,elem))) :: & - myFaceNodes ! global node ids on my face -integer(pInt) myType, & + myFaceNodes ! global node ids on my face +integer(pInt) :: myType, & candidateType, & candidateElem, & candidateFace, & candidateFaceNode, & minNsharedElems, & NsharedElems, & - lonelyNode, & + lonelyNode = 0_pInt, & i, & n, & - dir ! periodicity direction + dir ! periodicity direction integer(pInt), dimension(:), allocatable :: element_seen logical checkTwins - -minNsharedElems = mesh_maxNsharedElems + 1_pInt ! init to worst case +matchingElem = 0_pInt matchingFace = 0_pInt -matchingElem = 0_pInt ! intialize to "no match found" -myType = mesh_element(2_pInt,elem) ! figure elemType +minNsharedElems = mesh_maxNsharedElems + 1_pInt ! init to worst case +myType = mesh_element(2_pInt,elem) ! figure elemType -do n = 1_pInt,FE_NfaceNodes(face,myType) ! loop over nodes on face - myFaceNodes(n) = mesh_FEasCP('node',mesh_element(4_pInt+FE_nodeOnFace(n,face,myType),elem)) ! CP id of face node - NsharedElems = mesh_sharedElem(1_pInt,myFaceNodes(n)) ! figure # shared elements for this node +do n = 1_pInt,FE_NfaceNodes(face,myType) ! loop over nodes on face + myFaceNodes(n) = mesh_FEasCP('node',mesh_element(4_pInt+FE_nodeOnFace(n,face,myType),elem)) ! CP id of face node + NsharedElems = mesh_sharedElem(1_pInt,myFaceNodes(n)) ! figure # shared elements for this node if (NsharedElems < minNsharedElems) then - minNsharedElems = NsharedElems ! remember min # shared elems - lonelyNode = n ! remember most lonely node + minNsharedElems = NsharedElems ! remember min # shared elems + lonelyNode = n ! remember most lonely node endif enddo allocate(element_seen(minNsharedElems)) element_seen = 0_pInt -checkCandidate: do i = 1_pInt,minNsharedElems ! iterate over lonelyNode's shared elements - candidateElem = mesh_sharedElem(1_pInt+i,myFaceNodes(lonelyNode)) ! present candidate elem - if (all(element_seen /= candidateElem)) then ! element seen for the first time? +checkCandidate: do i = 1_pInt,minNsharedElems ! iterate over lonelyNode's shared elements + candidateElem = mesh_sharedElem(1_pInt+i,myFaceNodes(lonelyNode)) ! present candidate elem + if (all(element_seen /= candidateElem)) then ! element seen for the first time? element_seen(i) = candidateElem - candidateType = mesh_element(2_pInt,candidateElem) ! figure elemType of candidate -checkCandidateFace: do candidateFace = 1_pInt,FE_maxNipNeighbors ! check each face of candidate + candidateType = mesh_element(2_pInt,candidateElem) ! figure elemType of candidate +checkCandidateFace: do candidateFace = 1_pInt,FE_maxNipNeighbors ! check each face of candidate if (FE_NfaceNodes(candidateFace,candidateType) /= FE_NfaceNodes(face,myType) & ! incompatible face .or. (candidateElem == elem .and. candidateFace == face)) then ! this is my face cycle checkCandidateFace @@ -544,7 +584,7 @@ enddo checkCandidate deallocate(element_seen) -endsubroutine +end subroutine mesh_faceMatch !******************************************************************** @@ -553,11 +593,9 @@ endsubroutine ! assign globals: ! FE_nodesAtIP, FE_ipNeighbor, FE_subNodeParent, FE_subNodeOnIPFace !******************************************************************** - subroutine mesh_build_FEdata () - - use prec, only: pInt +subroutine mesh_build_FEdata + implicit none - allocate(FE_nodesAtIP(FE_maxmaxNnodesAtIP,FE_maxNips,FE_Nelemtypes)) ; FE_nodesAtIP = 0_pInt allocate(FE_ipNeighbor(FE_maxNipNeighbors,FE_maxNips,FE_Nelemtypes)) ; FE_ipNeighbor = 0_pInt allocate(FE_subNodeParent(FE_maxNips,FE_maxNsubNodes,FE_Nelemtypes)) ; FE_subNodeParent = 0_pInt @@ -1386,7 +1424,7 @@ FE_ipNeighbor(1:FE_NipNeighbors(8),1:FE_Nips(8),8) = & ! element 117 6, 7, 7, 6 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(10),FE_Nips(10)]) - endsubroutine +end subroutine mesh_build_FEdata !******************************************************************** @@ -1394,16 +1432,18 @@ FE_ipNeighbor(1:FE_NipNeighbors(8),1:FE_Nips(8),8) = & ! element 117 ! ! initialcondTableStyle, hypoelasticTableStyle !******************************************************************** - subroutine mesh_marc_get_tableStyles (myUnit) +subroutine mesh_marc_get_tableStyles(myUnit) - use prec, only: pInt - use IO + use IO, only: IO_lc, & + IO_intValue, & + IO_stringValue, & + IO_stringPos + implicit none - + integer(pInt), intent(in) :: myUnit + integer(pInt), parameter :: maxNchunks = 6_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos - - integer(pInt) myUnit character(len=300) line initialcondTableStyle = 0_pInt @@ -1423,7 +1463,7 @@ FE_ipNeighbor(1:FE_NipNeighbors(8),1:FE_Nips(8),8) = & ! element 117 endif enddo -620 endsubroutine +620 end subroutine mesh_marc_get_tableStyles !******************************************************************** @@ -1434,10 +1474,11 @@ FE_ipNeighbor(1:FE_NipNeighbors(8),1:FE_Nips(8),8) = & ! element 117 subroutine mesh_get_damaskOptions(myUnit) use DAMASK_interface, only: FEsolver -use prec, only: pInt -use IO -implicit none +use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos +implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 5_pInt @@ -1490,7 +1531,7 @@ do endselect enddo -620 endsubroutine +620 end subroutine mesh_get_damaskOptions !******************************************************************** @@ -1498,17 +1539,24 @@ enddo ! ! mesh_Nelems, mesh_Nnodes !******************************************************************** - subroutine mesh_spectral_count_nodesAndElements (myUnit) +subroutine mesh_spectral_count_nodesAndElements(myUnit) - use prec, only: pInt - use IO + use IO, only: IO_lc, & + IO_intValue, & + IO_stringValue, & + IO_stringPos, & + IO_error + implicit none - + integer(pInt), intent(in) :: myUnit + integer(pInt), parameter :: maxNchunks = 7_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos - integer(pInt) a,b,c,i,j,headerLength - - integer(pInt) myUnit + integer(pInt) :: a = 0_pInt, & + b = 0_pInt, & + c = 0_pInt, & + headerLength = 0_pInt, & + i,j character(len=1024) line,keyword mesh_Nnodes = 0_pInt @@ -1544,23 +1592,25 @@ enddo endif enddo - endsubroutine +end subroutine mesh_spectral_count_nodesAndElements !******************************************************************** ! count overall number of nodes and elements in mesh ! ! mesh_Nelems, mesh_Nnodes !******************************************************************** - subroutine mesh_marc_count_nodesAndElements (myUnit) +subroutine mesh_marc_count_nodesAndElements(myUnit) - use prec, only: pInt - use IO + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_IntValue + implicit none - + integer(pInt), intent(in) :: myUnit + integer(pInt), parameter :: maxNchunks = 4_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos - - integer(pInt) myUnit character(len=300) line mesh_Nnodes = 0_pInt @@ -1580,25 +1630,28 @@ enddo endif enddo -620 endsubroutine +620 end subroutine mesh_marc_count_nodesAndElements !******************************************************************** ! count overall number of nodes and elements in mesh ! ! mesh_Nelems, mesh_Nnodes !******************************************************************** - subroutine mesh_abaqus_count_nodesAndElements (myUnit) +subroutine mesh_abaqus_count_nodesAndElements(myUnit) - use prec, only: pInt - use IO + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countDataLines, & + IO_error + implicit none - + integer(pInt), intent(in) :: myUnit + integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos - character(len=300) line - - integer(pInt) myUnit - logical inPart + character(len=300) :: line + logical :: inPart mesh_Nnodes = 0_pInt mesh_Nelems = 0_pInt @@ -1639,7 +1692,7 @@ enddo 620 if (mesh_Nnodes < 2_pInt) call IO_error(error_ID=900_pInt) if (mesh_Nelems == 0_pInt) call IO_error(error_ID=901_pInt) - endsubroutine +end subroutine mesh_abaqus_count_nodesAndElements !******************************************************************** @@ -1647,16 +1700,18 @@ enddo ! ! mesh_NelemSets, mesh_maxNelemInSet !******************************************************************** - subroutine mesh_marc_count_elementSets (myUnit) + subroutine mesh_marc_count_elementSets(myUnit) - use prec, only: pInt - use IO + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countContinousIntValues + implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos - - integer(pInt) myUnit character(len=300) line mesh_NelemSets = 0_pInt @@ -1677,7 +1732,7 @@ enddo endif enddo -620 endsubroutine +620 end subroutine mesh_marc_count_elementSets !******************************************************************** @@ -1685,18 +1740,20 @@ enddo ! ! mesh_NelemSets, mesh_maxNelemInSet !******************************************************************** - subroutine mesh_abaqus_count_elementSets (myUnit) +subroutine mesh_abaqus_count_elementSets(myUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error - use prec, only: pInt - use IO implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos - character(len=300) line - - integer(pInt) myUnit - logical inPart + character(len=300) :: line + logical :: inPart mesh_NelemSets = 0_pInt mesh_maxNelemInSet = mesh_Nelems ! have to be conservative, since Abaqus allows for recursive definitons @@ -1719,7 +1776,7 @@ enddo 620 continue if (mesh_NelemSets == 0) call IO_error(error_ID=902_pInt) - endsubroutine +end subroutine mesh_abaqus_count_elementSets !******************************************************************** @@ -1727,17 +1784,19 @@ enddo ! ! mesh_Nmaterials !******************************************************************** - subroutine mesh_abaqus_count_materials (myUnit) +subroutine mesh_abaqus_count_materials(myUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error - use prec, only: pInt - use IO implicit none - + integer(pInt), intent(in) :: myUnit + integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos - character(len=300) line - - integer(pInt) myUnit + character(len=300) :: line logical inPart mesh_Nmaterials = 0_pInt @@ -1761,7 +1820,7 @@ enddo 620 if (mesh_Nmaterials == 0_pInt) call IO_error(error_ID=903_pInt) - endsubroutine +end subroutine mesh_abaqus_count_materials !******************************************************************** @@ -1769,13 +1828,13 @@ enddo ! ! mesh_NcpElems !******************************************************************** - subroutine mesh_spectral_count_cpElements () +subroutine mesh_spectral_count_cpElements implicit none mesh_NcpElems = mesh_Nelems - endsubroutine +end subroutine mesh_spectral_count_cpElements !******************************************************************** @@ -1783,17 +1842,20 @@ enddo ! ! mesh_NcpElems !******************************************************************** - subroutine mesh_marc_count_cpElements (myUnit) +subroutine mesh_marc_count_cpElements(myUnit) - use prec, only: pInt - use IO + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countContinousIntValues + implicit none - + integer(pInt), intent(in) :: myUnit + integer(pInt), parameter :: maxNchunks = 1_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos - - integer(pInt) myUnit,i - character(len=300) line + integer(pInt) :: i + character(len=300):: line mesh_NcpElems = 0_pInt @@ -1813,7 +1875,7 @@ enddo endif enddo -620 endsubroutine +620 end subroutine mesh_marc_count_cpElements !******************************************************************** @@ -1821,19 +1883,23 @@ enddo ! ! mesh_NcpElems !******************************************************************** - subroutine mesh_abaqus_count_cpElements (myUnit) +subroutine mesh_abaqus_count_cpElements(myUnit) - use prec, only: pInt - use IO + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error, & + IO_extractValue + implicit none - + integer(pInt), intent(in) :: myUnit + integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos character(len=300) line - - integer(pInt) myUnit,i,k - logical materialFound - character (len=64) materialName,elemSetName + integer(pInt) :: i,k + logical :: materialFound = .false. + character(len=64) ::materialName,elemSetName mesh_NcpElems = 0_pInt @@ -1865,7 +1931,7 @@ enddo 620 if (mesh_NcpElems == 0_pInt) call IO_error(error_ID=906_pInt) - endsubroutine +end subroutine mesh_abaqus_count_cpElements !******************************************************************** @@ -1873,25 +1939,26 @@ enddo ! ! allocate globals: mesh_nameElemSet, mesh_mapElemSet !******************************************************************** - subroutine mesh_marc_map_elementSets (myUnit) +subroutine mesh_marc_map_elementSets(myUnit) - use prec, only: pInt - use IO + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_continousIntValues implicit none - + integer(pInt), intent(in) :: myUnit + integer(pInt), parameter :: maxNchunks = 4_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos - character(len=300) line - - integer(pInt) myUnit,elemSet + character(len=300) :: line + integer(pInt) :: elemSet = 0_pInt allocate (mesh_nameElemSet(mesh_NelemSets)) ; mesh_nameElemSet = '' allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt 610 FORMAT(A300) - elemSet = 0_pInt rewind(myUnit) do read (myUnit,610,END=640) line @@ -1904,7 +1971,7 @@ enddo endif enddo -640 endsubroutine +640 end subroutine mesh_marc_map_elementSets !******************************************************************** @@ -1912,27 +1979,30 @@ enddo ! ! allocate globals: mesh_nameElemSet, mesh_mapElemSet !******************************************************************** - subroutine mesh_abaqus_map_elementSets (myUnit) +subroutine mesh_abaqus_map_elementSets(myUnit) - use prec, only: pInt - use IO + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue, & + IO_continousIntValues, & + IO_error implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 4_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos - character(len=300) line + character(len=300) :: line + integer(pInt) :: elemSet = 0_pInt,i + logical :: inPart = .false. - integer(pInt) myUnit,elemSet,i - logical inPart - - allocate (mesh_nameElemSet(mesh_NelemSets)) ; mesh_nameElemSet = '' - allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt + allocate (mesh_nameElemSet(mesh_NelemSets)) ; mesh_nameElemSet = '' + allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt 610 FORMAT(A300) - elemSet = 0_pInt - inPart = .false. + rewind(myUnit) do read (myUnit,610,END=640) line @@ -1955,7 +2025,7 @@ enddo if (mesh_mapElemSet(1,i) == 0_pInt) call IO_error(error_ID=904_pInt,ext_msg=mesh_nameElemSet(i)) enddo - endsubroutine +end subroutine mesh_abaqus_map_elementSets !******************************************************************** @@ -1963,27 +2033,30 @@ enddo ! ! allocate globals: mesh_nameMaterial, mesh_mapMaterial !******************************************************************** - subroutine mesh_abaqus_map_materials (myUnit) +subroutine mesh_abaqus_map_materials(myUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue, & + IO_error - use prec, only: pInt - use IO implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 20_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line - integer(pInt) myUnit,i,c - logical inPart - character(len=64) elemSetName,materialName + integer(pInt) :: i,c = 0_pInt + logical :: inPart = .false. + character(len=64) :: elemSetName,materialName allocate (mesh_nameMaterial(mesh_Nmaterials)) ; mesh_nameMaterial = '' allocate (mesh_mapMaterial(mesh_Nmaterials)) ; mesh_mapMaterial = '' 610 FORMAT(A300) - c = 0_pInt - inPart = .false. rewind(myUnit) do read (myUnit,610,END=620) line @@ -2021,7 +2094,7 @@ enddo if (mesh_nameMaterial(i)=='' .or. mesh_mapMaterial(i)=='') call IO_error(error_ID=905_pInt) enddo - endsubroutine + end subroutine mesh_abaqus_map_materials @@ -2030,19 +2103,17 @@ enddo ! ! allocate globals: mesh_mapFEtoCPnode !******************************************************************** - subroutine mesh_spectral_map_nodes () - - use prec, only: pInt +subroutine mesh_spectral_map_nodes implicit none - integer(pInt) i + integer(pInt) :: i allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt forall (i = 1_pInt:mesh_Nnodes) & mesh_mapFEtoCPnode(1:2,i) = i - endsubroutine +end subroutine mesh_spectral_map_nodes @@ -2051,20 +2122,23 @@ enddo ! ! allocate globals: mesh_mapFEtoCPnode !******************************************************************** - subroutine mesh_marc_map_nodes (myUnit) +subroutine mesh_marc_map_nodes(myUnit) - use prec, only: pInt use math, only: qsort - use IO - + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_fixedIntValue + implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 1_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line integer(pInt), dimension (mesh_Nnodes) :: node_count - integer(pInt) myUnit,i + integer(pInt) :: i allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt @@ -2089,7 +2163,7 @@ enddo 650 call qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) - endsubroutine +end subroutine mesh_marc_map_nodes @@ -2098,27 +2172,30 @@ enddo ! ! allocate globals: mesh_mapFEtoCPnode !******************************************************************** - subroutine mesh_abaqus_map_nodes (myUnit) +subroutine mesh_abaqus_map_nodes(myUnit) - use prec, only: pInt use math, only: qsort - use IO + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countDataLines, & + IO_intValue, & + IO_error implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line - integer(pInt) myUnit,i,c,cpNode - logical inPart + integer(pInt) :: i,c,cpNode = 0_pInt + logical :: inPart = .false. allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt 610 FORMAT(A300) - cpNode = 0_pInt - inPart = .false. rewind(myUnit) do read (myUnit,610,END=650) line @@ -2152,7 +2229,7 @@ enddo if (int(size(mesh_mapFEtoCPnode),pInt) == 0_pInt) call IO_error(error_ID=908_pInt) - endsubroutine +end subroutine mesh_abaqus_map_nodes !******************************************************************** @@ -2160,19 +2237,17 @@ enddo ! ! allocate globals: mesh_mapFEtoCPelem !******************************************************************** - subroutine mesh_spectral_map_elements () - - use prec, only: pInt +subroutine mesh_spectral_map_elements implicit none - integer(pInt) i + integer(pInt) :: i allocate (mesh_mapFEtoCPelem(2_pInt,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt forall (i = 1_pInt:mesh_NcpElems) & mesh_mapFEtoCPelem(1:2,i) = i - endsubroutine +end subroutine mesh_spectral_map_elements @@ -2181,26 +2256,28 @@ enddo ! ! allocate globals: mesh_mapFEtoCPelem !******************************************************************** - subroutine mesh_marc_map_elements (myUnit) +subroutine mesh_marc_map_elements(myUnit) - use prec, only: pInt use math, only: qsort - use IO + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_continousIntValues implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 1_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line integer(pInt), dimension (1_pInt+mesh_NcpElems) :: contInts - integer(pInt) myUnit,i,cpElem + integer(pInt) :: i,cpElem = 0_pInt allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt 610 FORMAT(A300) - cpElem = 0_pInt rewind(myUnit) do read (myUnit,610,END=660) line @@ -2220,7 +2297,7 @@ enddo 660 call qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems - endsubroutine +end subroutine mesh_marc_map_elements !******************************************************************** @@ -2228,27 +2305,29 @@ enddo ! ! allocate globals: mesh_mapFEtoCPelem !******************************************************************** - subroutine mesh_abaqus_map_elements (myUnit) +subroutine mesh_abaqus_map_elements(myUnit) - use prec, only: pInt use math, only: qsort - use IO - + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue, & + IO_error + implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos - character(len=300) line - - integer(pInt) myUnit,i,j,k,cpElem - logical materialFound + character(len=300) :: line + integer(pInt) ::i,j,k,cpElem = 0_pInt + logical :: materialFound = .false. character (len=64) materialName,elemSetName ! why limited to 64? ABAQUS? allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt 610 FORMAT(A300) - cpElem = 0_pInt rewind(myUnit) do read (myUnit,610,END=660) line @@ -2259,15 +2338,15 @@ enddo materialFound = materialName /= '' ! valid name? case('*user') if (IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'material' .and. materialFound) then - do i = 1_pInt,mesh_Nmaterials ! look thru material names - if (materialName == mesh_nameMaterial(i)) then ! found one - elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet - do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions - if (elemSetName == mesh_nameElemSet(k)) then ! matched? + do i = 1_pInt,mesh_Nmaterials ! look thru material names + if (materialName == mesh_nameMaterial(i)) then ! found one + elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet + do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions + if (elemSetName == mesh_nameElemSet(k)) then ! matched? do j = 1_pInt,mesh_mapElemSet(1,k) cpElem = cpElem + 1_pInt - mesh_mapFEtoCPelem(1,cpElem) = mesh_mapElemSet(1_pInt+j,k) ! store FE id - mesh_mapFEtoCPelem(2,cpElem) = cpElem ! store our id + mesh_mapFEtoCPelem(1,cpElem) = mesh_mapElemSet(1_pInt+j,k) ! store FE id + mesh_mapFEtoCPelem(2,cpElem) = cpElem ! store our id enddo endif enddo @@ -2282,7 +2361,7 @@ enddo if (int(size(mesh_mapFEtoCPelem),pInt) < 2_pInt) call IO_error(error_ID=907_pInt) - endsubroutine +end subroutine mesh_abaqus_map_elements !******************************************************************** @@ -2291,12 +2370,10 @@ enddo ! ! _maxNnodes, _maxNips, _maxNipNeighbors, _maxNsubNodes !******************************************************************** -subroutine mesh_spectral_count_cpSizes () +subroutine mesh_spectral_count_cpSizes - use prec, only: pInt implicit none - - integer(pInt) t + integer(pInt) :: t t = FE_mapElemtype('C3D8R') ! fake 3D hexahedral 8 node 1 IP element @@ -2305,7 +2382,7 @@ subroutine mesh_spectral_count_cpSizes () mesh_maxNipNeighbors = FE_NipNeighbors(t) mesh_maxNsubNodes = FE_NsubNodes(t) - endsubroutine +end subroutine mesh_spectral_count_cpSizes !******************************************************************** @@ -2314,17 +2391,21 @@ subroutine mesh_spectral_count_cpSizes () ! ! _maxNnodes, _maxNips, _maxNipNeighbors, _maxNsubNodes !******************************************************************** -subroutine mesh_marc_count_cpSizes (myUnit) +subroutine mesh_marc_count_cpSizes(myUnit) - use prec, only: pInt - use IO + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_intValue, & + IO_skipChunks + implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos - character(len=300) line - - integer(pInt) myUnit,i,t,e + character(len=300) :: line + integer(pInt) :: i,t,e mesh_maxNnodes = 0_pInt mesh_maxNips = 0_pInt @@ -2337,10 +2418,10 @@ subroutine mesh_marc_count_cpSizes (myUnit) read (myUnit,610,END=630) line myPos = IO_stringPos(line,maxNchunks) if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'connectivity' ) then - read (myUnit,610,END=630) line ! Garbage line - do i=1_pInt,mesh_Nelems ! read all elements + read (myUnit,610,END=630) line ! Garbage line + do i=1_pInt,mesh_Nelems ! read all elements read (myUnit,610,END=630) line - myPos = IO_stringPos(line,maxNchunks) ! limit to id and type + myPos = IO_stringPos(line,maxNchunks) ! limit to id and type e = mesh_FEasCP('elem',IO_intValue(line,myPos,1_pInt)) if (e /= 0_pInt) then t = FE_mapElemtype(IO_stringValue(line,myPos,2_pInt)) @@ -2355,7 +2436,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) endif enddo -630 endsubroutine +630 end subroutine mesh_marc_count_cpSizes !******************************************************************** @@ -2364,18 +2445,24 @@ subroutine mesh_marc_count_cpSizes (myUnit) ! ! _maxNnodes, _maxNips, _maxNipNeighbors, _maxNsubNodes !******************************************************************** - subroutine mesh_abaqus_count_cpSizes (myUnit) +subroutine mesh_abaqus_count_cpSizes(myUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue ,& + IO_error, & + IO_countDataLines, & + IO_intValue - use prec, only: pInt - use IO implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos - character(len=300) line - - integer(pInt) myUnit,i,c,t - logical inPart + character(len=300) :: line + integer(pInt) :: i,c,t + logical :: inPart mesh_maxNnodes = 0_pInt mesh_maxNips = 0_pInt @@ -2418,7 +2505,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) endif enddo -620 endsubroutine +620 end subroutine mesh_abaqus_count_cpSizes !******************************************************************** @@ -2427,33 +2514,33 @@ subroutine mesh_marc_count_cpSizes (myUnit) ! allocate globals: ! _node !******************************************************************** - subroutine mesh_spectral_build_nodes (myUnit) +subroutine mesh_spectral_build_nodes(myUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error, & + IO_floatValue, & + IO_intValue - use prec, only: pInt - use IO implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 7_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos - integer(pInt) a,b,c,n,i,j,headerLength - real(pReal) x,y,z - logical gotResolution,gotDimension - - integer(pInt) myUnit - character(len=1024) line, keyword + integer(pInt) :: a = 1_pInt, & + b = 1_pInt, & + c = 1_pInt, & + headerLength = 0_pInt,i,j,n + real(pReal) :: x = 1.0_pReal, & + y = 1.0_pReal, & + z = 1.0_pReal + logical :: gotResolution = .false. ,gotDimension = .false. + character(len=1024) :: line, keyword allocate ( mesh_node0 (3,mesh_Nnodes) ); mesh_node0 = 0.0_pReal allocate ( mesh_node (3,mesh_Nnodes) ); mesh_node = 0.0_pReal - a = 1_pInt - b = 1_pInt - c = 1_pInt - x = 1.0_pReal - y = 1.0_pReal - z = 1.0_pReal - - gotResolution = .false. - gotDimension = .false. rewind(myUnit) read(myUnit,'(a1024)') line myPos = IO_stringPos(line,2_pInt) @@ -2510,7 +2597,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) mesh_node = mesh_node0 !why? - endsubroutine +end subroutine mesh_spectral_build_nodes !******************************************************************** @@ -2519,18 +2606,22 @@ subroutine mesh_marc_count_cpSizes (myUnit) ! allocate globals: ! _node !******************************************************************** - subroutine mesh_marc_build_nodes (myUnit) +subroutine mesh_marc_build_nodes(myUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_fixedIntValue, & + IO_fixedNoEFloatValue - use prec, only: pInt - use IO implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), dimension(5), parameter :: node_ends = int([0,10,30,50,70],pInt) integer(pInt), parameter :: maxNchunks = 1_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos - character(len=300) line - - integer(pInt) myUnit,i,j,m + character(len=300) :: line + integer(pInt) :: i,j,m allocate ( mesh_node0 (3,mesh_Nnodes) ); mesh_node0 = 0.0_pReal allocate ( mesh_node (3,mesh_Nnodes) ); mesh_node = 0.0_pReal @@ -2554,7 +2645,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) 670 mesh_node = mesh_node0 - endsubroutine +end subroutine mesh_marc_build_nodes !******************************************************************** @@ -2563,18 +2654,24 @@ subroutine mesh_marc_count_cpSizes (myUnit) ! allocate globals: ! _node !******************************************************************** - subroutine mesh_abaqus_build_nodes (myUnit) +subroutine mesh_abaqus_build_nodes(myUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_floatValue, & + IO_stringPos, & + IO_error, & + IO_countDataLines, & + IO_intValue - use prec, only: pInt - use IO implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 4_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos - character(len=300) line - - integer(pInt) myUnit,i,j,m,c - logical inPart + character(len=300) :: line + integer(pInt) :: i,j,m,c + logical :: inPart allocate ( mesh_node0 (3,mesh_Nnodes) ); mesh_node0 = 0.0_pReal allocate ( mesh_node (3,mesh_Nnodes) ); mesh_node = 0.0_pReal @@ -2597,9 +2694,9 @@ subroutine mesh_marc_count_cpSizes (myUnit) IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'file' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' ) & ) then - c = IO_countDataLines(myUnit) ! how many nodes are defined here? + c = IO_countDataLines(myUnit) ! how many nodes are defined here? do i = 1_pInt,c - backspace(myUnit) ! rewind to first entry + backspace(myUnit) ! rewind to first entry enddo do i = 1_pInt,c read (myUnit,610,END=670) line @@ -2613,7 +2710,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) 670 if (int(size(mesh_node0,2_pInt),pInt) /= mesh_Nnodes) call IO_error(error_ID=909_pInt) mesh_node = mesh_node0 - endsubroutine +end subroutine mesh_abaqus_build_nodes !******************************************************************** @@ -2622,21 +2719,27 @@ subroutine mesh_marc_count_cpSizes (myUnit) ! allocate globals: ! _element !******************************************************************** - subroutine mesh_spectral_build_elements (myUnit) +subroutine mesh_spectral_build_elements(myUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_floatValue, & + IO_stringPos, & + IO_error, & + IO_continousIntValues, & + IO_intValue, & + IO_countContinousIntValues - use prec, only: pInt - use IO implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 7_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos integer(pInt) :: a = 1_pInt, b = 1_pInt, c = 1_pInt - integer(pInt) :: e, i, j, homog, headerLength, maxIntCount + integer(pInt) :: e, i, j, homog = 0_pInt, headerLength = 0_pInt, maxIntCount integer(pInt), dimension(:), allocatable :: microstructures integer(pInt), dimension(1,1) :: dummySet = 0_pInt - - integer(pInt) myUnit - character(len=65536) line,keyword + character(len=65536) :: line,keyword character(len=64), dimension(1) :: dummyName = '' rewind(myUnit) @@ -2687,23 +2790,23 @@ subroutine mesh_marc_count_cpSizes (myUnit) allocate (microstructures (1_pInt+maxIntCount)) ; microstructures = 2_pInt e = 0_pInt - do while (e < mesh_NcpElems .and. microstructures(1) > 0_pInt) ! fill expected number of elements, stop at end of data (or blank line!) - microstructures = IO_continousIntValues(myUnit,maxIntCount,dummyName,dummySet,0_pInt) ! get affected elements + do while (e < mesh_NcpElems .and. microstructures(1) > 0_pInt) ! fill expected number of elements, stop at end of data (or blank line!) + microstructures = IO_continousIntValues(myUnit,maxIntCount,dummyName,dummySet,0_pInt) ! get affected elements do i = 1_pInt,microstructures(1_pInt) - e = e+1_pInt ! valid element entry - mesh_element( 1,e) = e ! FE id - mesh_element( 2,e) = FE_mapElemtype('C3D8R') ! elem type - mesh_element( 3,e) = homog ! homogenization - mesh_element( 4,e) = microstructures(1_pInt+i) ! microstructure - mesh_element( 5,e) = e + (e-1_pInt)/(a-1_pInt) + ((e-1_pInt)/((a-1_pInt)*(b-1_pInt)))*a ! base node + e = e+1_pInt ! valid element entry + mesh_element( 1,e) = e ! FE id + mesh_element( 2,e) = FE_mapElemtype('C3D8R') ! elem type + mesh_element( 3,e) = homog ! homogenization + mesh_element( 4,e) = microstructures(1_pInt+i) ! microstructure + mesh_element( 5,e) = e + (e-1_pInt)/(a-1_pInt) + ((e-1_pInt)/((a-1_pInt)*(b-1_pInt)))*a ! base node mesh_element( 6,e) = mesh_element(5,e) + 1_pInt mesh_element( 7,e) = mesh_element(5,e) + a + 1_pInt mesh_element( 8,e) = mesh_element(5,e) + a - mesh_element( 9,e) = mesh_element(5,e) + a * b ! second floor base node + mesh_element( 9,e) = mesh_element(5,e) + a * b ! second floor base node mesh_element(10,e) = mesh_element(9,e) + 1_pInt mesh_element(11,e) = mesh_element(9,e) + a + 1_pInt mesh_element(12,e) = mesh_element(9,e) + a - mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),mesh_element(3,e)) !needed for statistics + mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),mesh_element(3,e)) !needed for statistics mesh_maxValStateVar(2) = max(mesh_maxValStateVar(2),mesh_element(4,e)) enddo enddo @@ -2711,8 +2814,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) deallocate(microstructures) if (e /= mesh_NcpElems) call IO_error(880_pInt,e) - endsubroutine - +end subroutine mesh_spectral_build_elements !******************************************************************** @@ -2721,18 +2823,25 @@ subroutine mesh_marc_count_cpSizes (myUnit) ! allocate globals: ! _element !******************************************************************** - subroutine mesh_marc_build_elements (myUnit) +subroutine mesh_marc_build_elements(myUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_fixedNoEFloatValue, & + IO_skipChunks, & + IO_stringPos, & + IO_intValue, & + IO_continousIntValues - use prec, only: pInt - use IO implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 66_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line integer(pInt), dimension(1_pInt+mesh_NcpElems) :: contInts - integer(pInt) myUnit,i,j,sv,val,e + integer(pInt) :: i,j,sv,myVal,e allocate (mesh_element (4_pInt+mesh_maxNnodes,mesh_NcpElems)) ; mesh_element = 0_pInt @@ -2743,16 +2852,16 @@ subroutine mesh_marc_count_cpSizes (myUnit) read (myUnit,610,END=620) line myPos(1:1+2*1) = IO_stringPos(line,1_pInt) if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'connectivity' ) then - read (myUnit,610,END=620) line ! Garbage line + read (myUnit,610,END=620) line ! Garbage line do i = 1_pInt,mesh_Nelems read (myUnit,610,END=620) line - myPos = IO_stringPos(line,maxNchunks) ! limit to 64 nodes max (plus ID, type) + myPos = IO_stringPos(line,maxNchunks) ! limit to 64 nodes max (plus ID, type) e = mesh_FEasCP('elem',IO_intValue(line,myPos,1_pInt)) - if (e /= 0_pInt) then ! disregard non CP elems - mesh_element(1,e) = IO_IntValue (line,myPos,1_pInt) ! FE id - mesh_element(2,e) = FE_mapElemtype(IO_StringValue(line,myPos,2_pInt)) ! elem type + if (e /= 0_pInt) then ! disregard non CP elems + mesh_element(1,e) = IO_IntValue (line,myPos,1_pInt) ! FE id + mesh_element(2,e) = FE_mapElemtype(IO_StringValue(line,myPos,2_pInt)) ! elem type forall (j = 1_pInt:FE_Nnodes(mesh_element(2,e))) & - mesh_element(j+4_pInt,e) = IO_IntValue(line,myPos,j+2_pInt) ! copy FE ids of nodes + mesh_element(j+4_pInt,e) = IO_IntValue(line,myPos,j+2_pInt) ! copy FE ids of nodes call IO_skipChunks(myUnit,FE_NoriginalNodes(mesh_element(2_pInt,e))-(myPos(1_pInt)-2_pInt)) ! read on if FE_Nnodes exceeds node count present on current line endif enddo @@ -2760,32 +2869,33 @@ subroutine mesh_marc_count_cpSizes (myUnit) endif enddo -620 rewind(myUnit) ! just in case "initial state" apears before "connectivity" +620 rewind(myUnit) ! just in case "initial state" apears before "connectivity" read (myUnit,610,END=620) line do myPos(1:1+2*2) = IO_stringPos(line,2_pInt) if( (IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'initial') .and. & (IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'state') ) then - if (initialcondTableStyle == 2_pInt) read (myUnit,610,END=620) line ! read extra line for new style - read (myUnit,610,END=630) line ! read line with index of state var + if (initialcondTableStyle == 2_pInt) read (myUnit,610,END=620) line ! read extra line for new style + read (myUnit,610,END=630) line ! read line with index of state var myPos(1:1+2*1) = IO_stringPos(line,1_pInt) - sv = IO_IntValue(line,myPos,1_pInt) ! figure state variable index - if( (sv == 2_pInt).or.(sv == 3_pInt) ) then ! only state vars 2 and 3 of interest - read (myUnit,610,END=620) line ! read line with value of state var + sv = IO_IntValue(line,myPos,1_pInt) ! figure state variable index + if( (sv == 2_pInt).or.(sv == 3_pInt) ) then ! only state vars 2 and 3 of interest + read (myUnit,610,END=620) line ! read line with value of state var myPos(1:1+2*1) = IO_stringPos(line,1_pInt) - do while (scan(IO_stringValue(line,myPos,1_pInt),'+-',back=.true.)>1) ! is noEfloat value? - val = nint(IO_fixedNoEFloatValue(line,[0_pInt,20_pInt],1_pInt),pInt) ! state var's value - mesh_maxValStateVar(sv-1_pInt) = max(val,mesh_maxValStateVar(sv-1_pInt)) ! remember max val of homogenization and microstructure index + do while (scan(IO_stringValue(line,myPos,1_pInt),'+-',back=.true.)>1) ! is noEfloat value? + myVal = nint(IO_fixedNoEFloatValue(line,[0_pInt,20_pInt],1_pInt),pInt) ! state var's value + mesh_maxValStateVar(sv-1_pInt) = max(myVal,mesh_maxValStateVar(sv-1_pInt)) ! remember max val of homogenization and microstructure index if (initialcondTableStyle == 2_pInt) then - read (myUnit,610,END=630) line ! read extra line - read (myUnit,610,END=630) line ! read extra line + read (myUnit,610,END=630) line ! read extra line + read (myUnit,610,END=630) line ! read extra line endif - contInts = IO_continousIntValues(myUnit,mesh_Nelems,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) ! get affected elements + contInts = IO_continousIntValues& ! get affected elements + (myUnit,mesh_Nelems,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) do i = 1_pInt,contInts(1) e = mesh_FEasCP('elem',contInts(1_pInt+i)) - mesh_element(1_pInt+sv,e) = val + mesh_element(1_pInt+sv,e) = myVal enddo - if (initialcondTableStyle == 0_pInt) read (myUnit,610,END=620) line ! ignore IP range for old table style + if (initialcondTableStyle == 0_pInt) read (myUnit,610,END=620) line ! ignore IP range for old table style read (myUnit,610,END=630) line myPos(1:1+2*1) = IO_stringPos(line,1_pInt) enddo @@ -2795,7 +2905,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) endif enddo -630 endsubroutine +630 end subroutine mesh_marc_build_elements !******************************************************************** ! store FEid, type, mat, tex, and node list per element @@ -2803,19 +2913,28 @@ subroutine mesh_marc_count_cpSizes (myUnit) ! allocate globals: ! _element !******************************************************************** - subroutine mesh_abaqus_build_elements (myUnit) +subroutine mesh_abaqus_build_elements(myUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_skipChunks, & + IO_stringPos, & + IO_intValue, & + IO_extractValue, & + IO_floatValue, & + IO_error, & + IO_countDataLines - use prec, only: pInt - use IO implicit none + integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 65_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos - integer(pInt) myUnit,i,j,k,c,e,t,homog,micro + integer(pInt) :: i,j,k,c,e,t,homog,micro logical inPart,materialFound - character (len=64) materialName,elemSetName - character(len=300) line + character (len=64) :: materialName,elemSetName + character(len=300) :: line allocate (mesh_element (4_pInt+mesh_maxNnodes,mesh_NcpElems)) ; mesh_element = 0_pInt @@ -2858,7 +2977,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) enddo -620 rewind(myUnit) ! just in case "*material" definitions apear before "*element" +620 rewind(myUnit) ! just in case "*material" definitions apear before "*element" materialFound = .false. do @@ -2866,24 +2985,24 @@ subroutine mesh_marc_count_cpSizes (myUnit) myPos = IO_stringPos(line,maxNchunks) select case ( IO_lc(IO_StringValue(line,myPos,1_pInt))) case('*material') - materialName = trim(IO_extractValue(IO_lc(IO_StringValue(line,myPos,2_pInt)),'name')) ! extract name=value - materialFound = materialName /= '' ! valid name? + materialName = trim(IO_extractValue(IO_lc(IO_StringValue(line,myPos,2_pInt)),'name')) ! extract name=value + materialFound = materialName /= '' ! valid name? case('*user') if ( IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'material' .and. & materialFound ) then - read (myUnit,610,END=630) line ! read homogenization and microstructure + read (myUnit,610,END=630) line ! read homogenization and microstructure myPos(1:1+2*2) = IO_stringPos(line,2_pInt) homog = nint(IO_floatValue(line,myPos,1_pInt),pInt) micro = nint(IO_floatValue(line,myPos,2_pInt),pInt) - do i = 1_pInt,mesh_Nmaterials ! look thru material names - if (materialName == mesh_nameMaterial(i)) then ! found one - elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet - do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions - if (elemSetName == mesh_nameElemSet(k)) then ! matched? + do i = 1_pInt,mesh_Nmaterials ! look thru material names + if (materialName == mesh_nameMaterial(i)) then ! found one + elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet + do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions + if (elemSetName == mesh_nameElemSet(k)) then ! matched? do j = 1_pInt,mesh_mapElemSet(1,k) e = mesh_FEasCP('elem',mesh_mapElemSet(1+j,k)) - mesh_element(3,e) = homog ! store homogenization - mesh_element(4,e) = micro ! store microstructure + mesh_element(3,e) = homog ! store homogenization + mesh_element(4,e) = micro ! store microstructure mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),homog) mesh_maxValStateVar(2) = max(mesh_maxValStateVar(2),micro) enddo @@ -2896,7 +3015,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) endselect enddo -630 endsubroutine +630 end subroutine mesh_abaqus_build_elements !******************************************************************** @@ -2906,17 +3025,15 @@ subroutine mesh_marc_count_cpSizes (myUnit) ! _maxNsharedElems ! _sharedElem !******************************************************************** -subroutine mesh_build_sharedElems() +subroutine mesh_build_sharedElems -use prec, only: pInt implicit none - -integer(pint) e, & ! element index - t, & ! element type - node, & ! CP node index - j, & ! node index per element - myDim, & ! dimension index - nodeTwin ! node twin in the specified dimension +integer(pint) e, & ! element index + t, & ! element type + node, & ! CP node index + j, & ! node index per element + myDim, & ! dimension index + nodeTwin ! node twin in the specified dimension integer(pInt), dimension (mesh_Nnodes) :: node_count integer(pInt), dimension (:), allocatable :: node_seen @@ -2926,24 +3043,24 @@ allocate(node_seen(maxval(FE_Nnodes))) node_count = 0_pInt do e = 1_pInt,mesh_NcpElems - t = mesh_element(2,e) ! get element type + t = mesh_element(2,e) ! get element type - node_seen = 0_pInt ! reset node duplicates - do j = 1_pInt,FE_Nnodes(t) ! check each node of element - node = mesh_FEasCP('node',mesh_element(4+j,e)) ! translate to internal (consecutive) numbering + node_seen = 0_pInt ! reset node duplicates + do j = 1_pInt,FE_Nnodes(t) ! check each node of element + node = mesh_FEasCP('node',mesh_element(4+j,e)) ! translate to internal (consecutive) numbering if (all(node_seen /= node)) then - node_count(node) = node_count(node) + 1_pInt ! if FE node not yet encountered -> count it - do myDim = 1_pInt,3_pInt ! check in each dimension... + node_count(node) = node_count(node) + 1_pInt ! if FE node not yet encountered -> count it + do myDim = 1_pInt,3_pInt ! check in each dimension... nodeTwin = mesh_nodeTwins(myDim,node) - if (nodeTwin > 0_pInt) & ! if I am a twin of some node... - node_count(nodeTwin) = node_count(nodeTwin) + 1_pInt ! -> count me again for the twin node + if (nodeTwin > 0_pInt) & ! if I am a twin of some node... + node_count(nodeTwin) = node_count(nodeTwin) + 1_pInt ! -> count me again for the twin node enddo endif - node_seen(j) = node ! remember this node to be counted already + node_seen(j) = node ! remember this node to be counted already enddo enddo -mesh_maxNsharedElems = int(maxval(node_count),pInt) ! most shared node +mesh_maxNsharedElems = int(maxval(node_count),pInt) ! most shared node allocate(mesh_sharedElem(1+mesh_maxNsharedElems,mesh_Nnodes)) mesh_sharedElem = 0_pInt @@ -2954,13 +3071,13 @@ do e = 1_pInt,mesh_NcpElems do j = 1_pInt,FE_Nnodes(t) node = mesh_FEasCP('node',mesh_element(4_pInt+j,e)) if (all(node_seen /= node)) then - mesh_sharedElem(1,node) = mesh_sharedElem(1,node) + 1_pInt ! count for each node the connected elements - mesh_sharedElem(mesh_sharedElem(1,node)+1_pInt,node) = e ! store the respective element id - do myDim = 1_pInt,3_pInt ! check in each dimension... + mesh_sharedElem(1,node) = mesh_sharedElem(1,node) + 1_pInt ! count for each node the connected elements + mesh_sharedElem(mesh_sharedElem(1,node)+1_pInt,node) = e ! store the respective element id + do myDim = 1_pInt,3_pInt ! check in each dimension... nodeTwin = mesh_nodeTwins(myDim,node) - if (nodeTwin > 0_pInt) then ! if i am a twin of some node... - mesh_sharedElem(1,nodeTwin) = mesh_sharedElem(1,nodeTwin) + 1_pInt ! ...count me again for the twin - mesh_sharedElem(mesh_sharedElem(1,nodeTwin)+1,nodeTwin) = e ! store the respective element id + if (nodeTwin > 0_pInt) then ! if i am a twin of some node... + mesh_sharedElem(1,nodeTwin) = mesh_sharedElem(1,nodeTwin) + 1_pInt ! ...count me again for the twin + mesh_sharedElem(mesh_sharedElem(1,nodeTwin)+1,nodeTwin) = e ! store the respective element id endif enddo endif @@ -2970,7 +3087,7 @@ enddo deallocate(node_seen) -endsubroutine +end subroutine mesh_build_sharedElems !*********************************************************** @@ -2979,41 +3096,38 @@ endsubroutine ! allocate globals ! _ipNeighborhood !*********************************************************** -subroutine mesh_build_ipNeighborhood() +subroutine mesh_build_ipNeighborhood -use prec, only: pInt implicit none - -integer(pInt) myElem, & ! my CP element index +integer(pInt) myElem, & ! my CP element index myIP, & - myType, & ! my element type + myType, & ! my element type myFace, & - neighbor, & ! neighor index - neighboringIPkey, & ! positive integer indicating the neighboring IP (for intra-element) and negative integer indicating the face towards neighbor (for neighboring element) + neighbor, & ! neighor index + neighboringIPkey, & ! positive integer indicating the neighboring IP (for intra-element) and negative integer indicating the face towards neighbor (for neighboring element) candidateIP, & - neighboringType, & ! element type of neighbor - NlinkedNodes, & ! number of linked nodes - twin_of_linkedNode, & ! node twin of a specific linkedNode - NmatchingNodes, & ! number of matching nodes - dir, & ! direction of periodicity - matchingElem, & ! CP elem number of matching element - matchingFace, & ! face ID of matching element + neighboringType, & ! element type of neighbor + NlinkedNodes, & ! number of linked nodes + twin_of_linkedNode, & ! node twin of a specific linkedNode + NmatchingNodes, & ! number of matching nodes + dir, & ! direction of periodicity + matchingElem, & ! CP elem number of matching element + matchingFace, & ! face ID of matching element a, anchor integer(pInt), dimension(FE_maxmaxNnodesAtIP) :: & - linkedNodes, & + linkedNodes = 0_pInt, & matchingNodes logical checkTwins allocate(mesh_ipNeighborhood(2,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems)) mesh_ipNeighborhood = 0_pInt -linkedNodes = 0_pInt -do myElem = 1_pInt,mesh_NcpElems ! loop over cpElems - myType = mesh_element(2,myElem) ! get elemType - do myIP = 1_pInt,FE_Nips(myType) ! loop over IPs of elem +do myElem = 1_pInt,mesh_NcpElems ! loop over cpElems + myType = mesh_element(2,myElem) ! get elemType + do myIP = 1_pInt,FE_Nips(myType) ! loop over IPs of elem - do neighbor = 1_pInt,FE_NipNeighbors(myType) ! loop over neighbors of IP + do neighbor = 1_pInt,FE_NipNeighbors(myType) ! loop over neighbors of IP neighboringIPkey = FE_ipNeighbor(neighbor,myIP,myType) !*** if the key is positive, the neighbor is inside the element @@ -3120,7 +3234,7 @@ checkCandidateIP: do candidateIP = 1_pInt,FE_Nips(neighboringType) enddo enddo -endsubroutine +end subroutine mesh_build_ipNeighborhood @@ -3130,11 +3244,9 @@ endsubroutine ! allocate globals ! _subNodeCoord !*********************************************************** - subroutine mesh_build_subNodeCoords() +subroutine mesh_build_subNodeCoords - use prec, only: pInt,pReal implicit none - integer(pInt) e,t,n,p if (.not. allocated(mesh_subNodeCoord)) then @@ -3158,7 +3270,7 @@ endsubroutine enddo enddo - endsubroutine +end subroutine mesh_build_subNodeCoords !*********************************************************** @@ -3167,12 +3279,12 @@ endsubroutine ! allocate globals ! _ipCenterOfGravity !*********************************************************** - subroutine mesh_build_ipCoordinates() +subroutine mesh_build_ipCoordinates + + use prec, only: tol_gravityNodePos - use prec, only: pInt, tol_gravityNodePos implicit none - - integer(pInt) e,f,t,i,j,k,n + integer(pInt) :: e,f,t,i,j,k,n logical, dimension(mesh_maxNnodes+mesh_maxNsubNodes) :: gravityNode ! flagList to find subnodes determining center of grav real(pReal), dimension(3,mesh_maxNnodes+mesh_maxNsubNodes) :: gravityNodePos ! coordinates of subnodes determining center of grav real(pReal), dimension(3) :: centerOfGravity @@ -3209,7 +3321,7 @@ endsubroutine enddo enddo - endsubroutine +end subroutine mesh_build_ipCoordinates !*********************************************************** @@ -3218,13 +3330,12 @@ endsubroutine ! allocate globals ! _ipVolume !*********************************************************** - subroutine mesh_build_ipVolumes() +subroutine mesh_build_ipVolumes - use prec, only: pInt use math, only: math_volTetrahedron implicit none - integer(pInt) e,f,t,i,j,n + integer(pInt) :: e,f,t,i,j,n integer(pInt), parameter :: Ntriangles = FE_NipFaceNodes-2_pInt ! each interface is made up of this many triangles real(pReal), dimension(3,FE_NipFaceNodes) :: nPos ! coordinates of nodes on IP face real(pReal), dimension(Ntriangles,FE_NipFaceNodes) :: volume ! volumes of possible tetrahedra @@ -3251,7 +3362,7 @@ endsubroutine enddo enddo - endsubroutine +end subroutine mesh_build_ipVolumes !*********************************************************** @@ -3260,13 +3371,12 @@ endsubroutine ! allocate globals ! _ipArea, _ipAreaNormal !*********************************************************** - subroutine mesh_build_ipAreas() +subroutine mesh_build_ipAreas + + use math, only: math_vectorproduct - use prec, only: pInt,pReal - use math implicit none - - integer(pInt) e,f,t,i,j,n + integer(pInt) :: e,f,t,i,j,n integer(pInt), parameter :: Ntriangles = FE_NipFaceNodes-2_pInt ! each interface is made up of this many triangles real(pReal), dimension (3,FE_NipFaceNodes) :: nPos ! coordinates of nodes on IP face real(pReal), dimension(3,Ntriangles,FE_NipFaceNodes) :: normal @@ -3294,7 +3404,7 @@ endsubroutine enddo enddo - endsubroutine + end subroutine mesh_build_ipAreas !*********************************************************** @@ -3303,11 +3413,9 @@ endsubroutine ! allocate globals ! _nodeTwins !*********************************************************** -subroutine mesh_build_nodeTwins() +subroutine mesh_build_nodeTwins -use prec, only: pInt, pReal implicit none - integer(pInt) dir, & ! direction of periodicity node, & minimumNode, & @@ -3369,7 +3477,7 @@ do dir = 1_pInt,3_pInt ! check periodicity in endif enddo -endsubroutine +end subroutine mesh_build_nodeTwins @@ -3378,36 +3486,37 @@ endsubroutine ! to the output file ! !*********************************************************** -subroutine mesh_tell_statistics() +subroutine mesh_tell_statistics -use prec, only: pInt -use math, only: math_range -use IO, only: IO_error -use debug, only: debug_verbosity, & - debug_e, & - debug_i, & - debug_selectiveDebugger + use math, only: math_range + use IO, only: IO_error + use debug, only: debug_what, & + debug_mesh, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i -implicit none - -integer(pInt), dimension (:,:), allocatable :: mesh_HomogMicro -character(len=64) fmt - -integer(pInt) i,e,n,f,t - -if (mesh_maxValStateVar(1) < 1_pInt) call IO_error(error_ID=170_pInt) ! no homogenization specified -if (mesh_maxValStateVar(2) < 1_pInt) call IO_error(error_ID=180_pInt) ! no microstructure specified + implicit none + integer(pInt), dimension (:,:), allocatable :: mesh_HomogMicro + character(len=64) :: myFmt + integer(pInt) :: i,e,n,f,t, myDebug -allocate (mesh_HomogMicro(mesh_maxValStateVar(1),mesh_maxValStateVar(2))); mesh_HomogMicro = 0_pInt + myDebug = debug_what(debug_mesh) + + if (mesh_maxValStateVar(1) < 1_pInt) call IO_error(error_ID=170_pInt) ! no homogenization specified + if (mesh_maxValStateVar(2) < 1_pInt) call IO_error(error_ID=180_pInt) ! no microstructure specified + + allocate (mesh_HomogMicro(mesh_maxValStateVar(1),mesh_maxValStateVar(2))); mesh_HomogMicro = 0_pInt do e = 1_pInt,mesh_NcpElems if (mesh_element(3,e) < 1_pInt) call IO_error(error_ID=170_pInt,e=e) ! no homogenization specified if (mesh_element(4,e) < 1_pInt) call IO_error(error_ID=180_pInt,e=e) ! no microstructure specified mesh_HomogMicro(mesh_element(3,e),mesh_element(4,e)) = & mesh_HomogMicro(mesh_element(3,e),mesh_element(4,e)) + 1_pInt ! count combinations of homogenization and microstructure enddo - -if (debug_verbosity > 0_pInt) then - !$OMP CRITICAL (write2out) +!$OMP CRITICAL (write2out) + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then write (6,*) write (6,*) 'Input Parser: STATISTICS' write (6,*) @@ -3425,11 +3534,11 @@ if (debug_verbosity > 0_pInt) then write (6,*) mesh_maxValStateVar(1), ' : maximum homogenization index' write (6,*) mesh_maxValStateVar(2), ' : maximum microstructure index' write (6,*) - write (fmt,'(a,i32.32,a)') '(9x,a2,1x,',mesh_maxValStateVar(2),'(i8))' - write (6,fmt) '+-',math_range(mesh_maxValStateVar(2)) - write (fmt,'(a,i32.32,a)') '(i8,1x,a2,1x,',mesh_maxValStateVar(2),'(i8))' + write (myFmt,'(a,i32.32,a)') '(9x,a2,1x,',mesh_maxValStateVar(2),'(i8))' + write (6,myFmt) '+-',math_range(mesh_maxValStateVar(2)) + write (myFmt,'(a,i32.32,a)') '(i8,1x,a2,1x,',mesh_maxValStateVar(2),'(i8))' do i=1_pInt,mesh_maxValStateVar(1) ! loop over all (possibly assigned) homogenizations - write (6,fmt) i,'| ',mesh_HomogMicro(i,:) ! loop over all (possibly assigned) microstructures + write (6,myFmt) i,'| ',mesh_HomogMicro(i,:) ! loop over all (possibly assigned) microstructures enddo write(6,*) write(6,*) 'Input Parser: ADDITIONAL MPIE OPTIONS' @@ -3437,26 +3546,25 @@ if (debug_verbosity > 0_pInt) then write(6,*) 'periodic surface : ', mesh_periodicSurface write(6,*) call flush(6) - !$OMP END CRITICAL (write2out) -endif + endif -if (debug_verbosity > 1) then - !$OMP CRITICAL (write2out) + if (iand(myDebug,debug_levelExtensive) /= 0_pInt) then write (6,*) write (6,*) 'Input Parser: SUBNODE COORDINATES' write (6,*) - write(6,'(a8,1x,a5,1x,a15,1x,a15,1x,a20,3(1x,a12))') 'elem','IP','IP neighbor','IPFaceNodes','subNodeOnIPFace','x','y','z' + write(6,'(a8,1x,a5,1x,2(a15,1x),a20,3(1x,a12))')& + 'elem','IP','IP neighbor','IPFaceNodes','subNodeOnIPFace','x','y','z' do e = 1_pInt,mesh_NcpElems ! loop over cpElems - if (debug_selectiveDebugger .and. debug_e /= e) cycle + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle t = mesh_element(2,e) ! get elemType do i = 1_pInt,FE_Nips(t) ! loop over IPs of elem - if (debug_selectiveDebugger .and. debug_i /= i) cycle + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle do f = 1_pInt,FE_NipNeighbors(t) ! loop over interfaces of IP do n = 1_pInt,FE_NipFaceNodes ! loop over nodes on interface - write(6,'(i8,1x,i5,1x,i15,1x,i15,1x,i20,3(1x,f12.8))') e,i,f,n,FE_subNodeOnIPFace(n,f,i,t),& - mesh_subNodeCoord(1,FE_subNodeOnIPFace(n,f,i,t),e),& - mesh_subNodeCoord(2,FE_subNodeOnIPFace(n,f,i,t),e),& - mesh_subNodeCoord(3,FE_subNodeOnIPFace(n,f,i,t),e) + write(6,'(i8,1x,i5,2(1x,i15),1x,i20,3(1x,f12.8))') e,i,f,n,FE_subNodeOnIPFace(n,f,i,t),& + mesh_subNodeCoord(1,FE_subNodeOnIPFace(n,f,i,t),e),& + mesh_subNodeCoord(2,FE_subNodeOnIPFace(n,f,i,t),e),& + mesh_subNodeCoord(3,FE_subNodeOnIPFace(n,f,i,t),e) enddo enddo enddo @@ -3465,9 +3573,9 @@ if (debug_verbosity > 1) then write(6,*) 'Input Parser: IP COORDINATES' write(6,'(a8,1x,a5,3(1x,a12))') 'elem','IP','x','y','z' do e = 1_pInt,mesh_NcpElems - if (debug_selectiveDebugger .and. debug_e /= e) cycle + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle do i = 1_pInt,FE_Nips(mesh_element(2,e)) - if (debug_selectiveDebugger .and. debug_i /= i) cycle + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle write (6,'(i8,1x,i5,3(1x,f12.8))') e, i, mesh_ipCenterOfGravity(:,i,e) enddo enddo @@ -3478,9 +3586,9 @@ if (debug_verbosity > 1) then write (6,*) write (6,'(a8,1x,a5,1x,a15,1x,a5,1x,a15,1x,a16)') 'elem','IP','volume','face','area','-- normal --' do e = 1_pInt,mesh_NcpElems - if (debug_selectiveDebugger .and. debug_e /= e) cycle + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle do i = 1_pInt,FE_Nips(mesh_element(2,e)) - if (debug_selectiveDebugger .and. debug_i /= i) cycle + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle write (6,'(i8,1x,i5,1x,e15.8)') e,i,mesh_IPvolume(i,e) do f = 1_pInt,FE_NipNeighbors(mesh_element(2,e)) write (6,'(i33,1x,e15.8,1x,3(f6.3,1x))') f,mesh_ipArea(f,i,e),mesh_ipAreaNormal(:,f,i,e) @@ -3503,21 +3611,20 @@ if (debug_verbosity > 1) then write(6,*) write(6,'(a8,1x,a10,1x,a10,1x,a3,1x,a13,1x,a13)') 'elem','IP','neighbor','','elemNeighbor','ipNeighbor' do e = 1_pInt,mesh_NcpElems ! loop over cpElems - if (debug_selectiveDebugger .and. debug_e /= e) cycle + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle t = mesh_element(2,e) ! get elemType do i = 1_pInt,FE_Nips(t) ! loop over IPs of elem - if (debug_selectiveDebugger .and. debug_i /= i) cycle + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle do n = 1_pInt,FE_NipNeighbors(t) ! loop over neighbors of IP write (6,'(i8,1x,i10,1x,i10,1x,a3,1x,i13,1x,i13)') e,i,n,'-->',mesh_ipNeighborhood(1,n,i,e),mesh_ipNeighborhood(2,n,i,e) enddo enddo enddo - !$OMP END CRITICAL (write2out) -endif + endif +!$OMP END CRITICAL (write2out) deallocate(mesh_HomogMicro) -endsubroutine +end subroutine mesh_tell_statistics - -END MODULE mesh +end module mesh