diff --git a/src/DAMASK_FEM.f90 b/src/DAMASK_FEM.f90 new file mode 100644 index 000000000..60134f861 --- /dev/null +++ b/src/DAMASK_FEM.f90 @@ -0,0 +1,664 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Driver controlling inner and outer load case looping of the various FEM solvers +!> @details doing cutbacking, forwarding in case of restart, reporting statistics, writing +!> results +!-------------------------------------------------------------------------------------------------- +program DAMASK_FEM +#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 + use, intrinsic :: iso_fortran_env, only: & + compiler_version, & + compiler_options +#endif +#include + use PETScsys + use prec, only: & + pInt, & + pLongInt, & + pReal, & + tol_math_check, & + dNeq + use system_routines, only: & + getCWD + use DAMASK_interface, only: & + DAMASK_interface_init, & + loadCaseFile, & + geometryFile, & + getSolverJobName, & + appendToOutFile + use IO, only: & + IO_read, & + IO_isBlank, & + IO_open_file, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_error, & + IO_lc, & + IO_intOut, & + IO_warning, & + IO_timeStamp, & + IO_EOF + use debug, only: & + debug_level, & + debug_spectral, & + debug_levelBasic + use math ! need to include the whole module for FFTW + use mesh, only: & + grid, & + geomSize + use CPFEM2, only: & + CPFEM_initAll + use FEsolving, only: & + restartWrite, & + restartInc + use numerics, only: & + worldrank, & + worldsize, & + stagItMax, & + maxCutBack, & + spectral_solver, & + continueCalculation + use homogenization, only: & + materialpoint_sizeResults, & + materialpoint_results, & + materialpoint_postResults + use material, only: & + thermal_type, & + damage_type, & + THERMAL_conduction_ID, & + DAMAGE_nonlocal_ID + use FEM_utilities + use FEM_mech + + implicit none + +!-------------------------------------------------------------------------------------------------- +! variables related to information from load case and geom file + real(pReal), dimension(9) :: temp_valueVector = 0.0_pReal !< temporarily from loadcase file when reading in tensors (initialize to 0.0) + logical, dimension(9) :: temp_maskVector = .false. !< temporarily from loadcase file when reading in tensors + integer(pInt), parameter :: FILEUNIT = 234_pInt !< file unit, DAMASK IO does not support newunit feature + integer(pInt), allocatable, dimension(:) :: chunkPos + + integer(pInt) :: & + N_t = 0_pInt, & !< # of time indicators found in load case file + N_n = 0_pInt, & !< # of increment specifiers found in load case file + N_def = 0_pInt !< # of rate of deformation specifiers found in load case file + character(len=65536) :: & + line + +!-------------------------------------------------------------------------------------------------- +! loop variables, convergence etc. + real(pReal), dimension(3,3), parameter :: & + ones = 1.0_pReal, & + zeros = 0.0_pReal + integer(pInt), parameter :: & + subStepFactor = 2_pInt !< for each substep, divide the last time increment by 2.0 + real(pReal) :: & + time = 0.0_pReal, & !< elapsed time + time0 = 0.0_pReal, & !< begin of interval + timeinc = 1.0_pReal, & !< current time interval + timeIncOld = 0.0_pReal, & !< previous time interval + remainingLoadCaseTime = 0.0_pReal !< remaining time of current load case + logical :: & + guess, & !< guess along former trajectory + stagIterate + integer(pInt) :: & + i, j, k, l, field, & + errorID, & + cutBackLevel = 0_pInt, & !< cut back level \f$ t = \frac{t_{inc}}{2^l} \f$ + stepFraction = 0_pInt !< fraction of current time interval + integer(pInt) :: & + currentLoadcase = 0_pInt, & !< current load case + inc, & !< current increment in current load case + totalIncsCounter = 0_pInt, & !< total # of increments + convergedCounter = 0_pInt, & !< # of converged increments + notConvergedCounter = 0_pInt, & !< # of non-converged increments + resUnit = 0_pInt, & !< file unit for results writing + statUnit = 0_pInt, & !< file unit for statistics output + lastRestartWritten = 0_pInt, & !< total increment # at which last restart information was written + stagIter + character(len=6) :: loadcase_string + character(len=1024) :: & + incInfo, & !< string parsed to solution with information about current load case + workingDir + type(tLoadCase), allocatable, dimension(:) :: loadCases !< array of all load cases + type(tSolutionState), allocatable, dimension(:) :: solres + integer(MPI_OFFSET_KIND) :: fileOffset + integer(MPI_OFFSET_KIND), dimension(:), allocatable :: outputSize + integer(pInt), parameter :: maxByteOut = 2147483647-4096 !< limit of one file output write https://trac.mpich.org/projects/mpich/ticket/1742 + integer(pInt), parameter :: maxRealOut = maxByteOut/pReal + integer(pLongInt), dimension(2) :: outputIndex + integer :: ierr + + external :: & + quit + + +!-------------------------------------------------------------------------------------------------- +! init DAMASK (all modules) + call CPFEM_initAll(el = 1_pInt, ip = 1_pInt) + write(6,'(/,a)') ' <<<+- DAMASK_spectral init -+>>>' + write(6,'(/,a,/)') ' Roters et al., Computational Materials Science, 2018' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + +!-------------------------------------------------------------------------------------------------- +! initialize field solver information + nActiveFields = 1 + if (any(thermal_type == THERMAL_conduction_ID )) nActiveFields = nActiveFields + 1 + if (any(damage_type == DAMAGE_nonlocal_ID )) nActiveFields = nActiveFields + 1 + allocate(solres(nActiveFields)) + +!-------------------------------------------------------------------------------------------------- +! reading basic information from load case file and allocate data structure containing load cases + call IO_open_file(FILEUNIT,trim(loadCaseFile)) + rewind(FILEUNIT) + do + line = IO_read(FILEUNIT) + if (trim(line) == IO_EOF) exit + if (IO_isBlank(line)) cycle ! skip empty lines + chunkPos = IO_stringPos(line) + do i = 1_pInt, chunkPos(1) ! reading compulsory parameters for loadcase + select case (IO_lc(IO_stringValue(line,chunkPos,i))) + case('l','velocitygrad','velgrad','velocitygradient','fdot','dotf','f') + N_def = N_def + 1_pInt + case('t','time','delta') + N_t = N_t + 1_pInt + case('n','incs','increments','steps','logincs','logincrements','logsteps') + N_n = N_n + 1_pInt + end select + enddo ! count all identifiers to allocate memory and do sanity check + enddo + + if ((N_def /= N_n) .or. (N_n /= N_t) .or. N_n < 1_pInt) & ! sanity check + call IO_error(error_ID=837_pInt,ext_msg = trim(loadCaseFile)) ! error message for incomplete loadcase + allocate (loadCases(N_n)) ! array of load cases + loadCases%stress%myType='stress' + + do i = 1, size(loadCases) + allocate(loadCases(i)%ID(nActiveFields)) + field = 1 + loadCases(i)%ID(field) = FIELD_MECH_ID ! mechanical active by default + thermalActive: if (any(thermal_type == THERMAL_conduction_ID)) then + field = field + 1 + loadCases(i)%ID(field) = FIELD_THERMAL_ID + endif thermalActive + damageActive: if (any(damage_type == DAMAGE_nonlocal_ID)) then + field = field + 1 + loadCases(i)%ID(field) = FIELD_DAMAGE_ID + endif damageActive + enddo + +!-------------------------------------------------------------------------------------------------- +! reading the load case and assign values to the allocated data structure + rewind(FILEUNIT) + do + line = IO_read(FILEUNIT) + if (trim(line) == IO_EOF) exit + if (IO_isBlank(line)) cycle ! skip empty lines + currentLoadCase = currentLoadCase + 1_pInt + chunkPos = IO_stringPos(line) + do i = 1_pInt, chunkPos(1) + select case (IO_lc(IO_stringValue(line,chunkPos,i))) + case('fdot','dotf','l','velocitygrad','velgrad','velocitygradient','f') ! assign values for the deformation BC matrix + temp_valueVector = 0.0_pReal + if (IO_lc(IO_stringValue(line,chunkPos,i)) == 'fdot'.or. & ! in case of Fdot, set type to fdot + IO_lc(IO_stringValue(line,chunkPos,i)) == 'dotf') then + loadCases(currentLoadCase)%deformation%myType = 'fdot' + else if (IO_lc(IO_stringValue(line,chunkPos,i)) == 'f') then + loadCases(currentLoadCase)%deformation%myType = 'f' + else + loadCases(currentLoadCase)%deformation%myType = 'l' + endif + do j = 1_pInt, 9_pInt + temp_maskVector(j) = IO_stringValue(line,chunkPos,i+j) /= '*' ! true if not a * + if (temp_maskVector(j)) temp_valueVector(j) = IO_floatValue(line,chunkPos,i+j) ! read value where applicable + enddo + loadCases(currentLoadCase)%deformation%maskLogical = & ! logical mask in 3x3 notation + transpose(reshape(temp_maskVector,[ 3,3])) + loadCases(currentLoadCase)%deformation%maskFloat = & ! float (1.0/0.0) mask in 3x3 notation + merge(ones,zeros,loadCases(currentLoadCase)%deformation%maskLogical) + loadCases(currentLoadCase)%deformation%values = math_plain9to33(temp_valueVector) ! values in 3x3 notation + case('p','pk1','piolakirchhoff','stress', 's') + temp_valueVector = 0.0_pReal + do j = 1_pInt, 9_pInt + temp_maskVector(j) = IO_stringValue(line,chunkPos,i+j) /= '*' ! true if not an asterisk + if (temp_maskVector(j)) temp_valueVector(j) = IO_floatValue(line,chunkPos,i+j) ! read value where applicable + enddo + loadCases(currentLoadCase)%stress%maskLogical = transpose(reshape(temp_maskVector,[ 3,3])) + loadCases(currentLoadCase)%stress%maskFloat = merge(ones,zeros,& + loadCases(currentLoadCase)%stress%maskLogical) + loadCases(currentLoadCase)%stress%values = math_plain9to33(temp_valueVector) + case('t','time','delta') ! increment time + loadCases(currentLoadCase)%time = IO_floatValue(line,chunkPos,i+1_pInt) + case('n','incs','increments','steps') ! number of increments + loadCases(currentLoadCase)%incs = IO_intValue(line,chunkPos,i+1_pInt) + case('logincs','logincrements','logsteps') ! number of increments (switch to log time scaling) + loadCases(currentLoadCase)%incs = IO_intValue(line,chunkPos,i+1_pInt) + loadCases(currentLoadCase)%logscale = 1_pInt + case('freq','frequency','outputfreq') ! frequency of result writings + loadCases(currentLoadCase)%outputfrequency = IO_intValue(line,chunkPos,i+1_pInt) + case('r','restart','restartwrite') ! frequency of writing restart information + loadCases(currentLoadCase)%restartfrequency = & + max(0_pInt,IO_intValue(line,chunkPos,i+1_pInt)) + case('guessreset','dropguessing') + loadCases(currentLoadCase)%followFormerTrajectory = .false. ! do not continue to predict deformation along former trajectory + case('euler') ! rotation of currentLoadCase given in euler angles + temp_valueVector = 0.0_pReal + l = 1_pInt ! assuming values given in degrees + k = 1_pInt ! assuming keyword indicating degree/radians present + select case (IO_lc(IO_stringValue(line,chunkPos,i+1_pInt))) + case('deg','degree') + case('rad','radian') ! don't convert from degree to radian + l = 0_pInt + case default + k = 0_pInt + end select + do j = 1_pInt, 3_pInt + temp_valueVector(j) = IO_floatValue(line,chunkPos,i+k+j) + enddo + if (l == 1_pInt) temp_valueVector(1:3) = temp_valueVector(1:3) * inRad ! convert to rad + loadCases(currentLoadCase)%rotation = math_EulerToR(temp_valueVector(1:3)) ! convert rad Eulers to rotation matrix + case('rotation','rot') ! assign values for the rotation of currentLoadCase matrix + temp_valueVector = 0.0_pReal + do j = 1_pInt, 9_pInt + temp_valueVector(j) = IO_floatValue(line,chunkPos,i+j) + enddo + loadCases(currentLoadCase)%rotation = math_plain9to33(temp_valueVector) + end select + enddo; enddo + close(FILEUNIT) + +!-------------------------------------------------------------------------------------------------- +! consistency checks and output of load case + loadCases(1)%followFormerTrajectory = .false. ! cannot guess along trajectory for first inc of first currentLoadCase + errorID = 0_pInt + if (worldrank == 0) then + checkLoadcases: do currentLoadCase = 1_pInt, size(loadCases) + write (loadcase_string, '(i6)' ) currentLoadCase + write(6,'(1x,a,i6)') 'load case: ', currentLoadCase + if (.not. loadCases(currentLoadCase)%followFormerTrajectory) & + write(6,'(2x,a)') 'drop guessing along trajectory' + if (loadCases(currentLoadCase)%deformation%myType == 'l') then + do j = 1_pInt, 3_pInt + if (any(loadCases(currentLoadCase)%deformation%maskLogical(j,1:3) .eqv. .true.) .and. & + any(loadCases(currentLoadCase)%deformation%maskLogical(j,1:3) .eqv. .false.)) & + errorID = 832_pInt ! each row should be either fully or not at all defined + enddo + write(6,'(2x,a)') 'velocity gradient:' + else if (loadCases(currentLoadCase)%deformation%myType == 'f') then + write(6,'(2x,a)') 'deformation gradient at end of load case:' + else + write(6,'(2x,a)') 'deformation gradient rate:' + endif + do i = 1_pInt, 3_pInt; do j = 1_pInt, 3_pInt + if(loadCases(currentLoadCase)%deformation%maskLogical(i,j)) then + write(6,'(2x,f12.7)',advance='no') loadCases(currentLoadCase)%deformation%values(i,j) + else + write(6,'(2x,12a)',advance='no') ' * ' + endif + enddo; write(6,'(/)',advance='no') + enddo + if (any(loadCases(currentLoadCase)%stress%maskLogical .eqv. & + loadCases(currentLoadCase)%deformation%maskLogical)) errorID = 831_pInt ! exclusive or masking only + if (any(loadCases(currentLoadCase)%stress%maskLogical .and. & + transpose(loadCases(currentLoadCase)%stress%maskLogical) .and. & + reshape([ .false.,.true.,.true.,.true.,.false.,.true.,.true.,.true.,.false.],[ 3,3]))) & + errorID = 838_pInt ! no rotation is allowed by stress BC + write(6,'(2x,a)') 'stress / GPa:' + do i = 1_pInt, 3_pInt; do j = 1_pInt, 3_pInt + if(loadCases(currentLoadCase)%stress%maskLogical(i,j)) then + write(6,'(2x,f12.7)',advance='no') loadCases(currentLoadCase)%stress%values(i,j)*1e-9_pReal + else + write(6,'(2x,12a)',advance='no') ' * ' + endif + enddo; write(6,'(/)',advance='no') + enddo + if (any(abs(math_mul33x33(loadCases(currentLoadCase)%rotation, & + math_transpose33(loadCases(currentLoadCase)%rotation))-math_I3) > & + reshape(spread(tol_math_check,1,9),[ 3,3]))& + .or. abs(math_det33(loadCases(currentLoadCase)%rotation)) > & + 1.0_pReal + tol_math_check) errorID = 846_pInt ! given rotation matrix contains strain + if (any(dNeq(loadCases(currentLoadCase)%rotation, math_I3))) & + write(6,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'rotation of loadframe:',& + math_transpose33(loadCases(currentLoadCase)%rotation) + if (loadCases(currentLoadCase)%time < 0.0_pReal) errorID = 834_pInt ! negative time increment + write(6,'(2x,a,f12.6)') 'time: ', loadCases(currentLoadCase)%time + if (loadCases(currentLoadCase)%incs < 1_pInt) errorID = 835_pInt ! non-positive incs count + write(6,'(2x,a,i5)') 'increments: ', loadCases(currentLoadCase)%incs + if (loadCases(currentLoadCase)%outputfrequency < 1_pInt) errorID = 836_pInt ! non-positive result frequency + write(6,'(2x,a,i5)') 'output frequency: ', & + loadCases(currentLoadCase)%outputfrequency + write(6,'(2x,a,i5,/)') 'restart frequency: ', & + loadCases(currentLoadCase)%restartfrequency + if (errorID > 0_pInt) call IO_error(error_ID = errorID, ext_msg = loadcase_string) ! exit with error message + enddo checkLoadcases + endif + +!-------------------------------------------------------------------------------------------------- +! doing initialization depending on selected solver + call Utilities_init() + do field = 1, nActiveFields + select case (loadCases(1)%ID(field)) + case(FIELD_MECH_ID) + select case (spectral_solver) + case (DAMASK_spectral_SolverBasic_label) + call basic_init + + case (DAMASK_spectral_SolverPolarisation_label) + if(iand(debug_level(debug_spectral),debug_levelBasic)/= 0) & + call IO_warning(42_pInt, ext_msg='debug Divergence') + call Polarisation_init + + case default + call IO_error(error_ID = 891_pInt, ext_msg = trim(spectral_solver)) + + end select + + case(FIELD_THERMAL_ID) + call spectral_thermal_init + + case(FIELD_DAMAGE_ID) + call spectral_damage_init() + + end select + enddo + +!-------------------------------------------------------------------------------------------------- +! write header of output file + if (worldrank == 0) then + if (.not. appendToOutFile) then ! after restart, append to existing results file + if (getCWD(workingDir)) call IO_error(106_pInt,ext_msg=trim(workingDir)) + open(newunit=resUnit,file=trim(getSolverJobName())//& + '.spectralOut',form='UNFORMATTED',status='REPLACE') + write(resUnit) 'load:', trim(loadCaseFile) ! ... and write header + write(resUnit) 'workingdir:', trim(workingDir) + write(resUnit) 'geometry:', trim(geometryFile) + write(resUnit) 'grid:', grid + write(resUnit) 'size:', geomSize + write(resUnit) 'materialpoint_sizeResults:', materialpoint_sizeResults + write(resUnit) 'loadcases:', size(loadCases) + write(resUnit) 'frequencies:', loadCases%outputfrequency ! one entry per LoadCase + write(resUnit) 'times:', loadCases%time ! one entry per LoadCase + write(resUnit) 'logscales:', loadCases%logscale + write(resUnit) 'increments:', loadCases%incs ! one entry per LoadCase + write(resUnit) 'startingIncrement:', restartInc ! start with writing out the previous inc + write(resUnit) 'eoh' + close(resUnit) ! end of header + open(newunit=statUnit,file=trim(getSolverJobName())//& + '.sta',form='FORMATTED',status='REPLACE') + write(statUnit,'(a)') 'Increment Time CutbackLevel Converged IterationsNeeded' ! statistics file + if (iand(debug_level(debug_spectral),debug_levelBasic) /= 0) & + write(6,'(/,a)') ' header of result and statistics file written out' + flush(6) + else ! open new files ... + open(newunit=statUnit,file=trim(getSolverJobName())//& + '.sta',form='FORMATTED', position='APPEND', status='OLD') + endif + endif + +!-------------------------------------------------------------------------------------------------- +! looping over loadcases + loadCaseLooping: do currentLoadCase = 1_pInt, size(loadCases) + time0 = time ! currentLoadCase start time + guess = loadCases(currentLoadCase)%followFormerTrajectory ! change of load case? homogeneous guess for the first inc + +!-------------------------------------------------------------------------------------------------- +! loop over incs defined in input file for current currentLoadCase + incLooping: do inc = 1_pInt, loadCases(currentLoadCase)%incs + totalIncsCounter = totalIncsCounter + 1_pInt + +!-------------------------------------------------------------------------------------------------- +! forwarding time + timeIncOld = timeinc ! last timeinc that brought former inc to an end + if (loadCases(currentLoadCase)%logscale == 0_pInt) then ! linear scale + timeinc = loadCases(currentLoadCase)%time/real(loadCases(currentLoadCase)%incs,pReal) + else + if (currentLoadCase == 1_pInt) then ! 1st currentLoadCase of logarithmic scale + if (inc == 1_pInt) then ! 1st inc of 1st currentLoadCase of logarithmic scale + timeinc = loadCases(1)%time*(2.0_pReal**real( 1_pInt-loadCases(1)%incs ,pReal)) ! assume 1st inc is equal to 2nd + else ! not-1st inc of 1st currentLoadCase of logarithmic scale + timeinc = loadCases(1)%time*(2.0_pReal**real(inc-1_pInt-loadCases(1)%incs ,pReal)) + endif + else ! not-1st currentLoadCase of logarithmic scale + timeinc = time0 * & + ( (1.0_pReal + loadCases(currentLoadCase)%time/time0 )**(real( inc ,pReal)/& + real(loadCases(currentLoadCase)%incs ,pReal))& + -(1.0_pReal + loadCases(currentLoadCase)%time/time0 )**(real( inc-1_pInt ,pReal)/& + real(loadCases(currentLoadCase)%incs ,pReal))) + endif + endif + timeinc = timeinc * real(subStepFactor,pReal)**real(-cutBackLevel,pReal) ! depending on cut back level, decrease time step + + skipping: if (totalIncsCounter <= restartInc) then ! not yet at restart inc? + time = time + timeinc ! just advance time, skip already performed calculation + guess = .true. ! QUESTION:why forced guessing instead of inheriting loadcase preference + else skipping + stepFraction = 0_pInt ! fraction scaled by stepFactor**cutLevel + +!-------------------------------------------------------------------------------------------------- +! loop over sub step + subStepLooping: do while (stepFraction < subStepFactor**cutBackLevel) + remainingLoadCaseTime = loadCases(currentLoadCase)%time+time0 - time + time = time + timeinc ! forward target time + stepFraction = stepFraction + 1_pInt ! count step + +!-------------------------------------------------------------------------------------------------- +! report begin of new step + write(6,'(/,a)') ' ###########################################################################' + write(6,'(1x,a,es12.5'//& + ',a,'//IO_intOut(inc) //',a,'//IO_intOut(loadCases(currentLoadCase)%incs)//& + ',a,'//IO_intOut(stepFraction) //',a,'//IO_intOut(subStepFactor**cutBackLevel)//& + ',a,'//IO_intOut(currentLoadCase)//',a,'//IO_intOut(size(loadCases))//')') & + 'Time', time, & + 's: Increment ', inc,'/',loadCases(currentLoadCase)%incs,& + '-', stepFraction,'/',subStepFactor**cutBackLevel,& + ' of load case ', currentLoadCase,'/',size(loadCases) + write(incInfo,& + '(a,'//IO_intOut(totalIncsCounter)//& + ',a,'//IO_intOut(sum(loadCases%incs))//& + ',a,'//IO_intOut(stepFraction)//& + ',a,'//IO_intOut(subStepFactor**cutBackLevel)//')') & + 'Increment ',totalIncsCounter,'/',sum(loadCases%incs),& + '-', stepFraction,'/',subStepFactor**cutBackLevel + flush(6) + +!-------------------------------------------------------------------------------------------------- +! forward fields + do field = 1, nActiveFields + select case(loadCases(currentLoadCase)%ID(field)) + case(FIELD_MECH_ID) + select case (spectral_solver) + case (DAMASK_spectral_SolverBasic_label) + call Basic_forward (& + guess,timeinc,timeIncOld,remainingLoadCaseTime, & + deformation_BC = loadCases(currentLoadCase)%deformation, & + stress_BC = loadCases(currentLoadCase)%stress, & + rotation_BC = loadCases(currentLoadCase)%rotation) + + case (DAMASK_spectral_SolverPolarisation_label) + call Polarisation_forward (& + guess,timeinc,timeIncOld,remainingLoadCaseTime, & + deformation_BC = loadCases(currentLoadCase)%deformation, & + stress_BC = loadCases(currentLoadCase)%stress, & + rotation_BC = loadCases(currentLoadCase)%rotation) + end select + + case(FIELD_THERMAL_ID); call spectral_thermal_forward() + case(FIELD_DAMAGE_ID); call spectral_damage_forward() + end select + enddo + +!-------------------------------------------------------------------------------------------------- +! solve fields + stagIter = 0_pInt + stagIterate = .true. + do while (stagIterate) + do field = 1, nActiveFields + select case(loadCases(currentLoadCase)%ID(field)) + case(FIELD_MECH_ID) + select case (spectral_solver) + case (DAMASK_spectral_SolverBasic_label) + solres(field) = Basic_solution (& + incInfo,timeinc,timeIncOld, & + stress_BC = loadCases(currentLoadCase)%stress, & + rotation_BC = loadCases(currentLoadCase)%rotation) + + case (DAMASK_spectral_SolverPolarisation_label) + solres(field) = Polarisation_solution (& + incInfo,timeinc,timeIncOld, & + stress_BC = loadCases(currentLoadCase)%stress, & + rotation_BC = loadCases(currentLoadCase)%rotation) + + end select + + case(FIELD_THERMAL_ID) + solres(field) = spectral_thermal_solution(timeinc,timeIncOld,remainingLoadCaseTime) + + case(FIELD_DAMAGE_ID) + solres(field) = spectral_damage_solution(timeinc,timeIncOld,remainingLoadCaseTime) + + end select + + if (.not. solres(field)%converged) exit ! no solution found + + enddo + stagIter = stagIter + 1_pInt + stagIterate = stagIter < stagItMax & + .and. all(solres(:)%converged) & + .and. .not. all(solres(:)%stagConverged) ! stationary with respect to staggered iteration + enddo + +!-------------------------------------------------------------------------------------------------- +! check solution for either advance or retry + + if ( (continueCalculation .or. all(solres(:)%converged .and. solres(:)%stagConverged)) & ! don't care or did converge + .and. .not. solres(1)%termIll) then ! and acceptable solution found + timeIncOld = timeinc + cutBack = .false. + guess = .true. ! start guessing after first converged (sub)inc + if (worldrank == 0) then + write(statUnit,*) totalIncsCounter, time, cutBackLevel, & + solres%converged, solres%iterationsNeeded + flush(statUnit) + endif + elseif (cutBackLevel < maxCutBack) then ! further cutbacking tolerated? + cutBack = .true. + stepFraction = (stepFraction - 1_pInt) * subStepFactor ! adjust to new denominator + cutBackLevel = cutBackLevel + 1_pInt + time = time - timeinc ! rewind time + timeinc = timeinc/real(subStepFactor,pReal) ! cut timestep + write(6,'(/,a)') ' cutting back ' + else ! no more options to continue + call IO_warning(850_pInt) + call MPI_file_close(resUnit,ierr) + close(statUnit) + call quit(-1_pInt*(lastRestartWritten+1_pInt)) ! quit and provide information about last restart inc written + endif + + enddo subStepLooping + + cutBackLevel = max(0_pInt, cutBackLevel - 1_pInt) ! try half number of subincs next inc + + if (all(solres(:)%converged)) then + convergedCounter = convergedCounter + 1_pInt + write(6,'(/,a,'//IO_intOut(totalIncsCounter)//',a)') & ! report converged inc + ' increment ', totalIncsCounter, ' converged' + else + notConvergedCounter = notConvergedCounter + 1_pInt + write(6,'(/,a,'//IO_intOut(totalIncsCounter)//',a)') & ! report non-converged inc + ' increment ', totalIncsCounter, ' NOT converged' + endif; flush(6) + + if (mod(inc,loadCases(currentLoadCase)%outputFrequency) == 0_pInt) then ! at output frequency + write(6,'(1/,a)') ' ... writing results to file ......................................' + flush(6) + call materialpoint_postResults() + endif + if ( loadCases(currentLoadCase)%restartFrequency > 0_pInt & ! writing of restart info requested ... + .and. mod(inc,loadCases(currentLoadCase)%restartFrequency) == 0_pInt) then ! ... and at frequency of writing restart information + restartWrite = .true. ! set restart parameter for FEsolving + lastRestartWritten = inc ! QUESTION: first call to CPFEM_general will write? + endif + + endif skipping + + enddo incLooping + + enddo loadCaseLooping + + +!-------------------------------------------------------------------------------------------------- +! report summary of whole calculation + write(6,'(/,a)') ' ###########################################################################' + write(6,'(1x,'//IO_intOut(convergedCounter)//',a,'//IO_intOut(notConvergedCounter + convergedCounter)//',a,f5.1,a)') & + convergedCounter, ' out of ', & + notConvergedCounter + convergedCounter, ' (', & + real(convergedCounter, pReal)/& + real(notConvergedCounter + convergedCounter,pReal)*100.0_pReal, & + ' %) increments converged!' + flush(6) + call MPI_file_close(resUnit,ierr) + close(statUnit) + + if (notConvergedCounter > 0_pInt) call quit(3_pInt) ! error if some are not converged + call quit(0_pInt) ! no complains ;) + +end program DAMASK_FEM + + +!-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief quit subroutine to mimic behavior of FEM solvers +!> @details exits the Spectral solver and reports time and duration. Exit code 0 signals +!> everything went fine. Exit code 1 signals an error, message according to IO_error. Exit code +!> 2 signals no converged solution and increment of last saved restart information is written to +!> stderr. Exit code 3 signals no severe problems, but some increments did not converge +!-------------------------------------------------------------------------------------------------- +subroutine quit(stop_id) +#include + use MPI + use prec, only: & + pInt + + implicit none + integer(pInt), intent(in) :: stop_id + integer, dimension(8) :: dateAndTime ! type default integer + integer(pInt) :: error = 0_pInt + PetscErrorCode :: ierr = 0 + logical :: ErrorInQuit + + external :: & + PETScFinalize + + call PETScFinalize(ierr) + if (ierr /= 0) write(6,'(a)') ' Error in PETScFinalize' +#ifdef _OPENMP + call MPI_finalize(error) + if (error /= 0) write(6,'(a)') ' Error in MPI_finalize' +#endif + ErrorInQuit = (ierr /= 0 .or. error /= 0_pInt) + + call date_and_time(values = dateAndTime) + write(6,'(/,a)') 'DAMASK terminated on:' + write(6,'(a,2(i2.2,a),i4.4)') 'Date: ',dateAndTime(3),'/',& + dateAndTime(2),'/',& + dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') 'Time: ',dateAndTime(5),':',& + dateAndTime(6),':',& + dateAndTime(7) + + if (stop_id == 0_pInt .and. .not. ErrorInQuit) stop 0 ! normal termination + if (stop_id < 0_pInt .and. .not. ErrorInQuit) then ! terminally ill, restart might help + write(0,'(a,i6)') 'restart information available at ', stop_id*(-1_pInt) + stop 2 + endif + if (stop_id == 3_pInt .and. .not. ErrorInQuit) stop 3 ! not all incs converged + + stop 1 ! error (message from IO_error) + +end subroutine quit diff --git a/src/FEM_interface.f90 b/src/FEM_interface.f90 new file mode 100644 index 000000000..4a369dd9c --- /dev/null +++ b/src/FEM_interface.f90 @@ -0,0 +1,470 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Interfacing between the FEM solvers and the material subroutines provided +!! by DAMASK +!> @details Interfacing between the FEM solvers and the material subroutines provided +!> by DAMASK. Interpretating the command line arguments to the init routine to +!> get load case, geometry file, working directory, etc. +!-------------------------------------------------------------------------------------------------- +module DAMASK_interface + use prec, only: & + pInt + + implicit none + private + logical, public, protected :: appendToOutFile = .false. !< Append to existing output file + integer(pInt), public, protected :: FEMRestartInc = 0_pInt !< Increment at which calculation starts + character(len=1024), public, protected :: & + geometryFile = '', & !< parameter given for geometry file + loadCaseFile = '' !< parameter given for load case file + character(len=1024), private :: workingDirectory + + public :: & + getSolverJobName, & + DAMASK_interface_init + private :: & + setWorkingDirectory, & + getGeometryFile, & + getLoadCaseFile, & + rectifyPath, & + makeRelativePath, & + IIO_stringValue, & + IIO_intValue, & + IIO_stringPos +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief initializes the solver by interpreting the command line arguments. Also writes +!! information on computation to screen +!-------------------------------------------------------------------------------------------------- +subroutine DAMASK_interface_init() + use, intrinsic :: & + iso_fortran_env +#include +#if PETSC_VERSION_MAJOR!=3 || PETSC_VERSION_MINOR!=9 +=================================================================================================== +========================= THIS VERSION OF DAMASK REQUIRES PETSc 3.9.x ========================= +=================================================================================================== +#endif + use PETScSys + use system_routines, only: & + getHostName + + implicit none + character(len=1024) :: & + commandLine, & !< command line call as string + loadcaseArg = '', & !< -l argument given to DAMASK_FEM.exe + geometryArg = '', & !< -g argument given to DAMASK_FEM.exe + workingDirArg = '', & !< -w argument given to DAMASK_FEM.exe + hostName, & !< name of machine on which DAMASK_FEM.exe is execute (might require export HOSTNAME) + userName, & !< name of user calling DAMASK_FEM.exe + tag + integer :: & + i, & +#ifdef _OPENMP + threadLevel, & +#endif + worldrank = 0, & + worldsize = 0 + integer, allocatable, dimension(:) :: & + chunkPos + integer, dimension(8) :: & + dateAndTime ! type default integer + PetscErrorCode :: ierr + logical :: error + external :: & + quit,& + PETScErrorF, & ! is called in the CHKERRQ macro + PETScInitialize + + open(6, encoding='UTF-8') ! for special characters in output + +!-------------------------------------------------------------------------------------------------- +! PETSc Init +#ifdef _OPENMP + ! If openMP is enabled, check if the MPI libary supports it and initialize accordingly. + ! Otherwise, the first call to PETSc will do the initialization. + call MPI_Init_Thread(MPI_THREAD_FUNNELED,threadLevel,ierr);CHKERRQ(ierr) + if (threadLevel>>' + write(6,'(a,/)') ' Roters et al., Computational Materials Science, 2018' + write(6,'(/,a)') ' Version: '//DAMASKVERSION + write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',& + dateAndTime(2),'/',& + dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',& + dateAndTime(6),':',& + dateAndTime(7) + write(6,'(/,a,i4.1)') ' MPI processes: ',worldsize + write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' +#include "compilation_info.f90" + + call get_command(commandLine) + chunkPos = IIO_stringPos(commandLine) + do i = 2_pInt, chunkPos(1) + select case(IIO_stringValue(commandLine,chunkPos,i)) ! extract key + case ('-h','--help') + write(6,'(a)') ' #######################################################################' + write(6,'(a)') ' DAMASK_FEM:' + write(6,'(a)') ' FEM solvers for the Düsseldorf Advanced Material Simulation Kit' + write(6,'(a,/)')' #######################################################################' + write(6,'(a,/)')' Valid command line switches:' + write(6,'(a)') ' --geom (-g, --geometry)' + write(6,'(a)') ' --load (-l, --loadcase)' + write(6,'(a)') ' --workingdir (-w, --wd, --workingdirectory, -d, --directory)' + write(6,'(a)') ' --restart (-r, --rs)' + write(6,'(a)') ' --help (-h)' + write(6,'(/,a)')' -----------------------------------------------------------------------' + write(6,'(a)') ' Mandatory arguments:' + write(6,'(/,a)')' --geom PathToGeomFile/NameOfGeom.geom' + write(6,'(a)') ' Specifies the location of the geometry definition file,' + write(6,'(a)') ' if no extension is given, .geom will be appended.' + write(6,'(a)') ' "PathToGeomFile" will be the working directory if not specified' + write(6,'(a)') ' via --workingdir.' + write(6,'(a)') ' Make sure the file "material.config" exists in the working' + write(6,'(a)') ' directory.' + write(6,'(a)') ' For further configuration place "numerics.config"' + write(6,'(a)')' and "numerics.config" in that directory.' + write(6,'(/,a)')' --load PathToLoadFile/NameOfLoadFile.load' + write(6,'(a)') ' Specifies the location of the load case definition file,' + write(6,'(a)') ' if no extension is given, .load will be appended.' + write(6,'(/,a)')' -----------------------------------------------------------------------' + write(6,'(a)') ' Optional arguments:' + write(6,'(/,a)')' --workingdirectory PathToWorkingDirectory' + write(6,'(a)') ' Specifies the working directory and overwrites the default' + write(6,'(a)') ' "PathToGeomFile".' + write(6,'(a)') ' Make sure the file "material.config" exists in the working' + write(6,'(a)') ' directory.' + write(6,'(a)') ' For further configuration place "numerics.config"' + write(6,'(a)')' and "debug.config" in that directory.' + write(6,'(/,a)')' --restart XX' + write(6,'(a)') ' Reads in increment XX and continues with calculating' + write(6,'(a)') ' increment XX+1 based on this.' + write(6,'(a)') ' Appends to existing results file' + write(6,'(a)') ' "NameOfGeom_NameOfLoadFile.YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY".' + write(6,'(a)') ' Works only if the restart information for increment XX' + write(6,'(a)') ' is available in the working directory.' + write(6,'(/,a)')' -----------------------------------------------------------------------' + write(6,'(a)') ' Help:' + write(6,'(/,a)')' --help' + write(6,'(a,/)')' Prints this message and exits' + call quit(0_pInt) ! normal Termination + case ('-l', '--load', '--loadcase') + if ( i < chunkPos(1)) loadcaseArg = trim(IIO_stringValue(commandLine,chunkPos,i+1_pInt)) + case ('-g', '--geom', '--geometry') + if (i < chunkPos(1)) geometryArg = trim(IIO_stringValue(commandLine,chunkPos,i+1_pInt)) + case ('-w', '-d', '--wd', '--directory', '--workingdir', '--workingdirectory') + if (i < chunkPos(1)) workingDirArg = trim(IIO_stringValue(commandLine,chunkPos,i+1_pInt)) + case ('-r', '--rs', '--restart') + if (i < chunkPos(1)) then + FEMRestartInc = IIO_IntValue(commandLine,chunkPos,i+1_pInt) + appendToOutFile = .true. + endif + end select + enddo + + if (len_trim(loadcaseArg) == 0 .or. len_trim(geometryArg) == 0) then + write(6,'(a)') ' Please specify geometry AND load case (-h for help)' + call quit(1_pInt) + endif + + workingDirectory = trim(setWorkingDirectory(trim(workingDirArg))) + geometryFile = getGeometryFile(geometryArg) + loadCaseFile = getLoadCaseFile(loadCaseArg) + + call get_environment_variable('USER',userName) + error = getHostName(hostName) + write(6,'(a,a)') ' Host name: ', trim(hostName) + write(6,'(a,a)') ' User name: ', trim(userName) + write(6,'(a,a)') ' Command line call: ', trim(commandLine) + if (len(trim(workingDirArg)) > 0) & + write(6,'(a,a)') ' Working dir argument: ', trim(workingDirArg) + write(6,'(a,a)') ' Geometry argument: ', trim(geometryArg) + write(6,'(a,a)') ' Loadcase argument: ', trim(loadcaseArg) + write(6,'(a,a)') ' Working directory: ', trim(workingDirectory) + write(6,'(a,a)') ' Geometry file: ', trim(geometryFile) + write(6,'(a,a)') ' Loadcase file: ', trim(loadCaseFile) + write(6,'(a,a)') ' Solver job name: ', trim(getSolverJobName()) + if (SpectralRestartInc > 0_pInt) & + write(6,'(a,i6.6)') ' Restart from increment: ', FEMRestartInc + write(6,'(a,l1,/)') ' Append to result file: ', appendToOutFile + +end subroutine DAMASK_interface_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief extract working directory from given argument or from location of geometry file, +!! possibly converting relative arguments to absolut path +!-------------------------------------------------------------------------------------------------- +character(len=1024) function setWorkingDirectory(workingDirectoryArg) + use system_routines, only: & + getCWD, & + setCWD + + implicit none + character(len=*), intent(in) :: workingDirectoryArg !< working directory argument + logical :: error + external :: quit + + wdGiven: if (len(workingDirectoryArg)>0) then + absolutePath: if (workingDirectoryArg(1:1) == '/') then + setWorkingDirectory = workingDirectoryArg + else absolutePath + error = getCWD(setWorkingDirectory) + if (error) call quit(1_pInt) + setWorkingDirectory = trim(setWorkingDirectory)//'/'//workingDirectoryArg + endif absolutePath + else wdGiven + error = getCWD(setWorkingDirectory) ! relative path given as command line argument + if (error) call quit(1_pInt) + endif wdGiven + + setWorkingDirectory = trim(rectifyPath(setWorkingDirectory)) + + error = setCWD(trim(setWorkingDirectory)) + if(error) then + write(6,'(a20,a,a16)') ' working directory "',trim(setWorkingDirectory),'" does not exist' + call quit(1_pInt) + endif + +end function setWorkingDirectory + + +!-------------------------------------------------------------------------------------------------- +!> @brief solver job name (no extension) as combination of geometry and load case name +!-------------------------------------------------------------------------------------------------- +character(len=1024) function getSolverJobName() + + implicit none + integer :: posExt,posSep + character(len=1024) :: tempString + + + tempString = geometryFile + posExt = scan(tempString,'.',back=.true.) + posSep = scan(tempString,'/',back=.true.) + + getSolverJobName = tempString(posSep+1:posExt-1) + + tempString = loadCaseFile + posExt = scan(tempString,'.',back=.true.) + posSep = scan(tempString,'/',back=.true.) + + getSolverJobName = trim(getSolverJobName)//'_'//tempString(posSep+1:posExt-1) + +end function getSolverJobName + + +!-------------------------------------------------------------------------------------------------- +!> @brief basename of geometry file with extension from command line arguments +!-------------------------------------------------------------------------------------------------- +character(len=1024) function getGeometryFile(geometryParameter) + + implicit none + character(len=1024), intent(in) :: & + geometryParameter + integer :: posExt, posSep + external :: quit + + getGeometryFile = trim(geometryParameter) + posExt = scan(getGeometryFile,'.',back=.true.) + posSep = scan(getGeometryFile,'/',back=.true.) + + if (posExt <= posSep) getGeometryFile = trim(getGeometryFile)//('.geom') + if (scan(getGeometryFile,'/') /= 1) & + getGeometryFile = trim(workingDirectory)//'/'//trim(getGeometryFile) + + getGeometryFile = makeRelativePath(workingDirectory, getGeometryFile) + + +end function getGeometryFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief relative path of loadcase from command line arguments +!-------------------------------------------------------------------------------------------------- +character(len=1024) function getLoadCaseFile(loadCaseParameter) + + implicit none + character(len=1024), intent(in) :: & + loadCaseParameter + integer :: posExt, posSep + external :: quit + + getLoadCaseFile = trim(loadCaseParameter) + posExt = scan(getLoadCaseFile,'.',back=.true.) + posSep = scan(getLoadCaseFile,'/',back=.true.) + + if (posExt <= posSep) getLoadCaseFile = trim(getLoadCaseFile)//('.load') + if (scan(getLoadCaseFile,'/') /= 1) & + getLoadCaseFile = trim(workingDirectory)//'/'//trim(getLoadCaseFile) + + getLoadCaseFile = makeRelativePath(workingDirectory, getLoadCaseFile) + +end function getLoadCaseFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief remove ../, /./, and // from path. +!> @details works only if absolute path is given +!-------------------------------------------------------------------------------------------------- +function rectifyPath(path) + + implicit none + character(len=*) :: path + character(len=len_trim(path)) :: rectifyPath + integer :: i,j,k,l ! no pInt + +!-------------------------------------------------------------------------------------------------- +! remove /./ from path + l = len_trim(path) + rectifyPath = path + do i = l,3,-1 + if (rectifyPath(i-2:i) == '/./') rectifyPath(i-1:l) = rectifyPath(i+1:l)//' ' + enddo + +!-------------------------------------------------------------------------------------------------- +! remove // from path + l = len_trim(path) + rectifyPath = path + do i = l,2,-1 + if (rectifyPath(i-1:i) == '//') rectifyPath(i-1:l) = rectifyPath(i:l)//' ' + enddo + +!-------------------------------------------------------------------------------------------------- +! remove ../ and corresponding directory from rectifyPath + l = len_trim(rectifyPath) + i = index(rectifyPath(i:l),'../') + j = 0 + do while (i > j) + j = scan(rectifyPath(1:i-2),'/',back=.true.) + rectifyPath(j+1:l) = rectifyPath(i+3:l)//repeat(' ',2+i-j) + if (rectifyPath(j+1:j+1) == '/') then !search for '//' that appear in case of XXX/../../XXX + k = len_trim(rectifyPath) + rectifyPath(j+1:k-1) = rectifyPath(j+2:k) + rectifyPath(k:k) = ' ' + endif + i = j+index(rectifyPath(j+1:l),'../') + enddo + if(len_trim(rectifyPath) == 0) rectifyPath = '/' + +end function rectifyPath + + +!-------------------------------------------------------------------------------------------------- +!> @brief relative path from absolute a to absolute b +!-------------------------------------------------------------------------------------------------- +character(len=1024) function makeRelativePath(a,b) + + implicit none + character (len=*), intent(in) :: a,b + character (len=1024) :: a_cleaned,b_cleaned + integer :: i,posLastCommonSlash,remainingSlashes !no pInt + + posLastCommonSlash = 0 + remainingSlashes = 0 + a_cleaned = rectifyPath(trim(a)//'/') + b_cleaned = rectifyPath(b) + + do i = 1, min(1024,len_trim(a_cleaned),len_trim(rectifyPath(b_cleaned))) + if (a_cleaned(i:i) /= b_cleaned(i:i)) exit + if (a_cleaned(i:i) == '/') posLastCommonSlash = i + enddo + do i = posLastCommonSlash+1,len_trim(a_cleaned) + if (a_cleaned(i:i) == '/') remainingSlashes = remainingSlashes + 1 + enddo + + makeRelativePath = repeat('..'//'/',remainingSlashes)//b_cleaned(posLastCommonSlash+1:len_trim(b_cleaned)) + +end function makeRelativePath + + +!-------------------------------------------------------------------------------------------------- +!> @brief taken from IO, check IO_stringValue for documentation +!-------------------------------------------------------------------------------------------------- +pure function IIO_stringValue(string,chunkPos,myChunk) + + implicit none + integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string + integer(pInt), intent(in) :: myChunk !< position number of desired chunk + character(len=chunkPos(myChunk*2+1)-chunkPos(myChunk*2)+1) :: IIO_stringValue + character(len=*), intent(in) :: string !< raw input with known start and end of each chunk + + IIO_stringValue = string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)) + +end function IIO_stringValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief taken from IO, check IO_intValue for documentation +!-------------------------------------------------------------------------------------------------- +integer(pInt) pure function IIO_intValue(string,chunkPos,myChunk) + + implicit none + character(len=*), intent(in) :: string !< raw input with known start and end of each chunk + integer(pInt), intent(in) :: myChunk !< position number of desired sub string + integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string + + + valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1_pInt) then + IIO_intValue = 0_pInt + else valuePresent + read(UNIT=string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)),ERR=100,FMT=*) IIO_intValue + endif valuePresent + return +100 IIO_intValue = huge(1_pInt) + +end function IIO_intValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief taken from IO, check IO_stringPos for documentation +!-------------------------------------------------------------------------------------------------- +pure function IIO_stringPos(string) + + implicit none + integer(pInt), dimension(:), allocatable :: IIO_stringPos + character(len=*), intent(in) :: string !< string in which chunks are searched for + + character(len=*), parameter :: SEP=achar(44)//achar(32)//achar(9)//achar(10)//achar(13) ! comma and whitespaces + integer :: left, right ! no pInt (verify and scan return default integer) + + allocate(IIO_stringPos(1), source=0_pInt) + right = 0 + + do while (verify(string(right+1:),SEP)>0) + left = right + verify(string(right+1:),SEP) + right = left + scan(string(left:),SEP) - 2 + if ( string(left:left) == '#' ) exit + IIO_stringPos = [IIO_stringPos,int(left, pInt), int(right, pInt)] + IIO_stringPos(1) = IIO_stringPos(1)+1_pInt + enddo + +end function IIO_stringPos + +end module diff --git a/src/FEM_mech.f90 b/src/FEM_mech.f90 new file mode 100755 index 000000000..aa967bec5 --- /dev/null +++ b/src/FEM_mech.f90 @@ -0,0 +1,992 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief FEM PETSc solver +!-------------------------------------------------------------------------------------------------- +module FEM_mech + use prec, only: & + pInt, & + pReal + use math, only: & + math_I3 + use FEM_utilities, only: & + tSolutionState, & + tFieldBC, & + tComponentBC + use numerics, only: & + worldrank, & + worldsize + use mesh, only: & + mesh_Nboundaries, & + mesh_boundaries + + implicit none + private +#include + +!-------------------------------------------------------------------------------------------------- +! derived types + type tSolutionParams + type(tFieldBC) :: fieldBC + real(pReal) :: timeinc + real(pReal) :: timeincOld + end type tSolutionParams + + type(tSolutionParams), private :: params + +!-------------------------------------------------------------------------------------------------- +! PETSc data + SNES, private :: mech_snes + Vec, private :: solution, solution_rate, solution_local + PetscInt, private :: dimPlex, cellDof, nQuadrature, nBasis + PetscReal, allocatable, target, private :: qPoints(:), qWeights(:) + MatNullSpace, private :: matnull + +!-------------------------------------------------------------------------------------------------- +! stress, stiffness and compliance average etc. + character(len=1024), private :: incInfo + real(pReal), private, dimension(3,3) :: & + P_av = 0.0_pReal + logical, private :: ForwardData + real(pReal), parameter, private :: eps = 1.0e-18_pReal + + public :: & + FEM_mech_init, & + FEM_mech_solution ,& + FEM_mech_forward, & + FEM_mech_output, & + FEM_mech_destroy + + external :: & + MPI_abort, & + MPI_Allreduce, & + VecCopy, & + VecSet, & + VecISSet, & + VecScale, & + VecWAXPY, & + VecAXPY, & + VecGetSize, & + VecAssemblyBegin, & + VecAssemblyEnd, & + VecView, & + VecDestroy, & + MatSetOption, & + MatSetLocalToGlobalMapping, & + MatSetNearNullSpace, & + MatZeroEntries, & + MatZeroRowsColumnsLocalIS, & + MatAssemblyBegin, & + MatAssemblyEnd, & + MatScale, & + MatNullSpaceCreateRigidBody, & + PetscQuadratureCreate, & + PetscFECreateDefault, & + PetscFESetQuadrature, & + PetscFEGetDimension, & + PetscFEDestroy, & + PetscFEGetDualSpace, & + PetscQuadratureDestroy, & + PetscDSSetDiscretization, & + PetscDSGetTotalDimension, & + PetscDSGetDiscretization, & + PetscDualSpaceGetFunctional, & + DMClone, & + DMCreateGlobalVector, & + DMGetDS, & + DMGetDimension, & + DMGetDefaultSection, & + DMGetDefaultGlobalSection, & + DMGetLocalToGlobalMapping, & + DMGetLocalVector, & + DMGetLabelSize, & + DMPlexCopyCoordinates, & + DMPlexGetHeightStratum, & + DMPlexGetDepthStratum, & + DMLocalToGlobalBegin, & + DMLocalToGlobalEnd, & + DMGlobalToLocalBegin, & + DMGlobalToLocalEnd, & + DMRestoreLocalVector, & + DMSNESSetFunctionLocal, & + DMSNESSetJacobianLocal, & + SNESCreate, & + SNESSetOptionsPrefix, & + SNESSetDM, & + SNESSetMaxLinearSolveFailures, & + SNESSetConvergenceTest, & + SNESSetTolerances, & + SNESSetFromOptions, & + SNESGetDM, & + SNESGetConvergedReason, & + SNESGetIterationNumber, & + SNESSolve, & + SNESDestroy, & + PetscViewerHDF5PushGroup, & + PetscViewerHDF5PopGroup, & + PetscObjectSetName + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields and fills them with data, potentially from restart info +!-------------------------------------------------------------------------------------------------- +subroutine FEM_mech_init(fieldBC) + 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_timeStamp, & + IO_error + use DAMASK_interface, only: & + getSolverJobName + use mesh, only: & + geomMesh + use numerics, only: & + worldrank, & + itmax, & + integrationOrder + use FEM_Zoo, only: & + FEM_Zoo_nQuadrature, & + FEM_Zoo_QuadraturePoints, & + FEM_Zoo_QuadratureWeights + + implicit none + type(tFieldBC), intent(in) :: fieldBC + DM :: mech_mesh + PetscFE :: mechFE + PetscQuadrature :: mechQuad, functional + PetscDS :: mechDS + PetscDualSpace :: mechDualSpace + DMLabel :: BCLabel + PetscInt, allocatable, target :: numComp(:), numDoF(:), bcField(:) + PetscInt, pointer :: pNumComp(:), pNumDof(:), pBcField(:), pBcPoint(:) + PetscInt :: numBC, bcSize + IS :: bcPoint + IS, allocatable, target :: bcComps(:), bcPoints(:) + IS, pointer :: pBcComps(:), pBcPoints(:) + PetscSection :: section + PetscInt :: field, faceSet, topologDim, nNodalPoints + PetscReal, pointer :: qPointsP(:), qWeightsP(:), & + nodalPointsP(:), nodalWeightsP(:) + PetscReal, allocatable, target :: nodalPoints(:), nodalWeights(:) + PetscScalar, pointer :: px_scal(:) + PetscScalar, allocatable, target :: x_scal(:) + PetscReal :: detJ + PetscReal, allocatable, target :: v0(:), cellJ(:), invcellJ(:), cellJMat(:,:) + PetscReal, pointer :: pV0(:), pCellJ(:), pInvcellJ(:) + PetscInt :: cellStart, cellEnd, cell, basis + character(len=7) :: prefix = 'mechFE_' + PetscErrorCode :: ierr + + if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- FEM_mech init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif + +!-------------------------------------------------------------------------------------------------- +! Setup FEM mech mesh + call DMClone(geomMesh,mech_mesh,ierr); CHKERRQ(ierr) + call DMGetDimension(mech_mesh,dimPlex,ierr); CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! Setup FEM mech discretization + allocate(qPoints(dimPlex*FEM_Zoo_nQuadrature(dimPlex,integrationOrder))) + allocate(qWeights(FEM_Zoo_nQuadrature(dimPlex,integrationOrder))) + qPoints = FEM_Zoo_QuadraturePoints(dimPlex,integrationOrder)%p + qWeights = FEM_Zoo_QuadratureWeights(dimPlex,integrationOrder)%p + nQuadrature = FEM_Zoo_nQuadrature(dimPlex,integrationOrder) + qPointsP => qPoints + qWeightsP => qWeights + call PetscQuadratureCreate(PETSC_COMM_SELF,mechQuad,ierr); CHKERRQ(ierr) + call PetscQuadratureSetData(mechQuad,dimPlex,nQuadrature,qPointsP,qWeightsP,ierr) + CHKERRQ(ierr) + call PetscFECreateDefault(mech_mesh,dimPlex,dimPlex,PETSC_TRUE,prefix, & + integrationOrder,mechFE,ierr); CHKERRQ(ierr) + call PetscFESetQuadrature(mechFE,mechQuad,ierr); CHKERRQ(ierr) + call PetscFEGetDimension(mechFE,nBasis,ierr); CHKERRQ(ierr) + call DMGetDS(mech_mesh,mechDS,ierr); CHKERRQ(ierr) + call PetscDSAddDiscretization(mechDS,mechFE,ierr); CHKERRQ(ierr) + call PetscDSGetTotalDimension(mechDS,cellDof,ierr); CHKERRQ(ierr) + call PetscFEDestroy(mechFE,ierr); CHKERRQ(ierr) + call PetscQuadratureDestroy(mechQuad,ierr); CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! Setup FEM mech boundary conditions + call DMGetLabel(mech_mesh,'Face Sets',BCLabel,ierr); CHKERRQ(ierr) + call DMPlexLabelComplete(mech_mesh,BCLabel,ierr); CHKERRQ(ierr) + call DMGetDefaultSection(mech_mesh,section,ierr); CHKERRQ(ierr) + allocate(numComp(1), source=dimPlex); pNumComp => numComp + allocate(numDof(dimPlex+1), source = 0); pNumDof => numDof + do topologDim = 0, dimPlex + call DMPlexGetDepthStratum(mech_mesh,topologDim,cellStart,cellEnd,ierr) + CHKERRQ(ierr) + call PetscSectionGetDof(section,cellStart,numDof(topologDim+1),ierr) + CHKERRQ(ierr) + enddo + numBC = 0 + do field = 1, dimPlex; do faceSet = 1, mesh_Nboundaries + if (fieldBC%componentBC(field)%Mask(faceSet)) numBC = numBC + 1 + enddo; enddo + allocate(bcField(numBC), source=0); pBcField => bcField + allocate(bcComps(numBC)); pBcComps => bcComps + allocate(bcPoints(numBC)); pBcPoints => bcPoints + numBC = 0 + do field = 1, dimPlex; do faceSet = 1, mesh_Nboundaries + if (fieldBC%componentBC(field)%Mask(faceSet)) then + numBC = numBC + 1 + call ISCreateGeneral(PETSC_COMM_WORLD,1,field-1,PETSC_COPY_VALUES,bcComps(numBC),ierr) + CHKERRQ(ierr) + call DMGetStratumSize(mech_mesh,'Face Sets',mesh_boundaries(faceSet),bcSize,ierr) + CHKERRQ(ierr) + if (bcSize > 0) then + call DMGetStratumIS(mech_mesh,'Face Sets',mesh_boundaries(faceSet),bcPoint,ierr) + CHKERRQ(ierr) + call ISGetIndicesF90(bcPoint,pBcPoint,ierr); CHKERRQ(ierr) + call ISCreateGeneral(PETSC_COMM_WORLD,bcSize,pBcPoint,PETSC_COPY_VALUES,bcPoints(numBC),ierr) + CHKERRQ(ierr) + call ISRestoreIndicesF90(bcPoint,pBcPoint,ierr); CHKERRQ(ierr) + call ISDestroy(bcPoint,ierr); CHKERRQ(ierr) + else + call ISCreateGeneral(PETSC_COMM_WORLD,0,0,PETSC_COPY_VALUES,bcPoints(numBC),ierr) + CHKERRQ(ierr) + endif + endif + enddo; enddo + call DMPlexCreateSection(mech_mesh,dimPlex,1,pNumComp,pNumDof, & + numBC,pBcField,pBcComps,pBcPoints,PETSC_NULL_OBJECT, & + section,ierr) + CHKERRQ(ierr) + call DMSetDefaultSection(mech_mesh,section,ierr); CHKERRQ(ierr) + do faceSet = 1, numBC + call ISDestroy(bcPoints(faceSet),ierr); CHKERRQ(ierr) + enddo + +!-------------------------------------------------------------------------------------------------- +! initialize solver specific parts of PETSc + call SNESCreate(PETSC_COMM_WORLD,mech_snes,ierr);CHKERRQ(ierr) + call SNESSetOptionsPrefix(mech_snes,'mech_',ierr);CHKERRQ(ierr) + call SNESSetDM(mech_snes,mech_mesh,ierr); CHKERRQ(ierr) !< set the mesh for non-linear solver + call DMCreateGlobalVector(mech_mesh,solution ,ierr); CHKERRQ(ierr) !< locally owned displacement Dofs + call DMCreateGlobalVector(mech_mesh,solution_rate ,ierr); CHKERRQ(ierr) !< locally owned velocity Dofs to guess solution at next load step + call DMCreateLocalVector (mech_mesh,solution_local ,ierr); CHKERRQ(ierr) !< locally owned velocity Dofs to guess solution at next load step + call DMSNESSetFunctionLocal(mech_mesh,FEM_mech_formResidual,PETSC_NULL_OBJECT,ierr) !< function to evaluate residual forces + CHKERRQ(ierr) + call DMSNESSetJacobianLocal(mech_mesh,FEM_mech_formJacobian,PETSC_NULL_OBJECT,ierr) !< function to evaluate stiffness matrix + CHKERRQ(ierr) + call SNESSetMaxLinearSolveFailures(mech_snes, huge(1), ierr); CHKERRQ(ierr) !< ignore linear solve failures + call SNESSetConvergenceTest(mech_snes,FEM_mech_converged,PETSC_NULL_OBJECT,PETSC_NULL_FUNCTION,ierr) + CHKERRQ(ierr) + call SNESSetTolerances(mech_snes,1.0,0.0,0.0,itmax,itmax,ierr) + CHKERRQ(ierr) + call SNESSetFromOptions(mech_snes,ierr); CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! init fields + call VecSet(solution ,0.0,ierr); CHKERRQ(ierr) + call VecSet(solution_rate ,0.0,ierr); CHKERRQ(ierr) + allocate(x_scal(cellDof)) + allocate(nodalPoints (dimPlex)) + allocate(nodalWeights(1)) + nodalPointsP => nodalPoints + nodalWeightsP => nodalWeights + allocate(v0(dimPlex)) + allocate(cellJ(dimPlex*dimPlex)) + allocate(invcellJ(dimPlex*dimPlex)) + allocate(cellJMat(dimPlex,dimPlex)) + pV0 => v0 + pCellJ => cellJ + pInvcellJ => invcellJ + call DMGetDefaultSection(mech_mesh,section,ierr); CHKERRQ(ierr) + call DMGetDS(mech_mesh,mechDS,ierr); CHKERRQ(ierr) + call PetscDSGetDiscretization(mechDS,0,mechFE,ierr) + CHKERRQ(ierr) + call PetscFEGetDualSpace(mechFE,mechDualSpace,ierr); CHKERRQ(ierr) + call DMPlexGetHeightStratum(mech_mesh,0,cellStart,cellEnd,ierr) + CHKERRQ(ierr) + do cell = cellStart, cellEnd-1 !< loop over all elements + x_scal = 0.0 + call DMPlexComputeCellGeometryAffineFEM(mech_mesh,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) + CHKERRQ(ierr) + cellJMat = reshape(pCellJ,shape=[dimPlex,dimPlex]) + do basis = 0, nBasis-1 + call PetscDualSpaceGetFunctional(mechDualSpace,basis,functional,ierr) + CHKERRQ(ierr) + call PetscQuadratureGetData(functional,dimPlex,nNodalPoints,nodalPointsP,nodalWeightsP,ierr) + CHKERRQ(ierr) + x_scal(basis*dimPlex+1:(basis+1)*dimPlex) = pV0 + matmul(transpose(cellJMat),nodalPointsP + 1.0) + enddo + px_scal => x_scal + call DMPlexVecSetClosure(mech_mesh,section,solution_local,cell,px_scal,INSERT_ALL_VALUES,ierr) + CHKERRQ(ierr) + enddo + +end subroutine FEM_mech_init + +!-------------------------------------------------------------------------------------------------- +!> @brief solution for the FEM load step +!-------------------------------------------------------------------------------------------------- +type(tSolutionState) function FEM_mech_solution( & + incInfoIn,timeinc,timeinc_old,fieldBC) + use numerics, only: & + itmax + use FEsolving, only: & + terminallyIll + + implicit none +!-------------------------------------------------------------------------------------------------- +! input data for solution + real(pReal), intent(in) :: & + timeinc, & !< increment in time for current solution + timeinc_old !< increment in time of last increment + type(tFieldBC), intent(in) :: & + fieldBC + character(len=*), intent(in) :: & + incInfoIn + +!-------------------------------------------------------------------------------------------------- +! + PetscErrorCode :: ierr + SNESConvergedReason :: reason + + incInfo = incInfoIn + FEM_mech_solution%converged =.false. +!-------------------------------------------------------------------------------------------------- +! set module wide availabe data + params%timeinc = timeinc + params%timeincOld = timeinc_old + params%fieldBC = fieldBC + + call SNESSolve(mech_snes,PETSC_NULL_OBJECT,solution,ierr); CHKERRQ(ierr) ! solve mech_snes based on solution guess (result in solution) + call SNESGetConvergedReason(mech_snes,reason,ierr); CHKERRQ(ierr) ! solution converged? + terminallyIll = .false. + + if (reason < 1) then ! 0: still iterating (will not occur), negative -> convergence error + FEM_mech_solution%converged = .false. + FEM_mech_solution%iterationsNeeded = itmax + else ! >= 1 proper convergence (or terminally ill) + FEM_mech_solution%converged = .true. + call SNESGetIterationNumber(mech_snes,FEM_mech_solution%iterationsNeeded,ierr) + CHKERRQ(ierr) + endif + + if (worldrank == 0) then + write(6,'(/,a)') ' ===========================================================================' + flush(6) + endif + +end function FEM_mech_solution + + +!-------------------------------------------------------------------------------------------------- +!> @brief forms the FEM residual vector +!-------------------------------------------------------------------------------------------------- +subroutine FEM_mech_formResidual(dm_local,xx_local,f_local,dummy,ierr) + use numerics, only: & + BBarStabilisation + use FEM_utilities, only: & + utilities_projectBCValues, & + utilities_constitutiveResponse + use homogenization, only: & + materialpoint_F, & + materialpoint_P + use math, only: & + math_det33, & + math_inv33 + use FEsolving, only: & + terminallyIll + + implicit none + DM :: dm_local + PetscDS :: prob + Vec :: x_local, f_local, xx_local + PetscSection :: section + PetscScalar, dimension(:), pointer :: x_scal, pf_scal + PetscScalar, target :: f_scal(cellDof) + PetscReal :: detJ, IcellJMat(dimPlex,dimPlex) + PetscReal, target :: v0(dimPlex), cellJ(dimPlex*dimPlex), & + invcellJ(dimPlex*dimPlex) + PetscReal, pointer :: pV0(:), pCellJ(:), pInvcellJ(:) + PetscReal, pointer :: basisField(:), basisFieldDer(:) + PetscInt :: cellStart, cellEnd, cell, field, face, & + qPt, basis, comp, cidx + PetscReal :: detFAvg + PetscReal :: BMat(dimPlex*dimPlex,cellDof) + PetscObject :: dummy + PetscInt :: bcSize + IS :: bcPoints + PetscErrorCode :: ierr + + pV0 => v0 + pCellJ => cellJ + pInvcellJ => invcellJ + call DMGetDefaultSection(dm_local,section,ierr); CHKERRQ(ierr) + call DMGetDS(dm_local,prob,ierr); CHKERRQ(ierr) + call PetscDSGetTabulation(prob,0,basisField,basisFieldDer,ierr) + CHKERRQ(ierr) + call DMPlexGetHeightStratum(dm_local,0,cellStart,cellEnd,ierr); CHKERRQ(ierr) + call DMGetLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + call VecWAXPY(x_local,1.0,xx_local,solution_local,ierr); CHKERRQ(ierr) + do field = 1, dimPlex; do face = 1, mesh_Nboundaries + if (params%fieldBC%componentBC(field)%Mask(face)) then + call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,ierr) + if (bcSize > 0) then + call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,ierr) + CHKERRQ(ierr) + call utilities_projectBCValues(x_local,section,0,field-1,bcPoints, & + 0.0,params%fieldBC%componentBC(field)%Value(face),params%timeinc) + call ISDestroy(bcPoints,ierr); CHKERRQ(ierr) + endif + endif + enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! evaluate field derivatives + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,ierr) !< get Dofs belonging to element + CHKERRQ(ierr) + call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) + CHKERRQ(ierr) + IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex]) + do qPt = 0, nQuadrature-1 + BMat = 0.0 + do basis = 0, nBasis-1 + do comp = 0, dimPlex-1 + cidx = basis*dimPlex+comp + BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = & + matmul(IcellJMat,basisFieldDer((qPt*nBasis*dimPlex+cidx )*dimPlex+1: & + (qPt*nBasis*dimPlex+cidx+1)*dimPlex )) + enddo + enddo + materialpoint_F(1:dimPlex,1:dimPlex,qPt+1,cell+1) = & + reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1]) + enddo + if (BBarStabilisation) then + detFAvg = math_det33(sum(materialpoint_F(1:3,1:3,1:nQuadrature,cell+1),dim=3)/real(nQuadrature)) + do qPt = 1, nQuadrature + materialpoint_F(1:dimPlex,1:dimPlex,qPt,cell+1) = & + materialpoint_F(1:dimPlex,1:dimPlex,qPt,cell+1)* & + (detFAvg/math_det33(materialpoint_F(1:3,1:3,qPt,cell+1)))**(1.0/real(dimPlex)) + + enddo + endif + call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,ierr) + CHKERRQ(ierr) + enddo + +!-------------------------------------------------------------------------------------------------- +! evaluate constitutive response + call Utilities_constitutiveResponse(params%timeinc,P_av,ForwardData) + call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) + ForwardData = .false. + +!-------------------------------------------------------------------------------------------------- +! integrating residual + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,ierr) !< get Dofs belonging to element + CHKERRQ(ierr) + call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) + CHKERRQ(ierr) + IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex]) + f_scal = 0.0 + do qPt = 0, nQuadrature-1 + BMat = 0.0 + do basis = 0, nBasis-1 + do comp = 0, dimPlex-1 + cidx = basis*dimPlex+comp + BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = & + matmul(IcellJMat,basisFieldDer((qPt*nBasis*dimPlex+cidx )*dimPlex+1: & + (qPt*nBasis*dimPlex+cidx+1)*dimPlex )) + enddo + enddo + f_scal = f_scal + & + matmul(transpose(BMat), & + reshape(transpose(materialpoint_P(1:dimPlex,1:dimPlex,qPt+1,cell+1)), & + shape=[dimPlex*dimPlex]))*qWeights(qPt+1) + enddo + f_scal = f_scal*abs(detJ) + pf_scal => f_scal + call DMPlexVecSetClosure(dm_local,section,f_local,cell,pf_scal,ADD_VALUES,ierr) + CHKERRQ(ierr) + call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,ierr) + CHKERRQ(ierr) + enddo + call DMRestoreLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + +end subroutine FEM_mech_formResidual + + +!-------------------------------------------------------------------------------------------------- +!> @brief forms the FEM stiffness matrix +!-------------------------------------------------------------------------------------------------- +subroutine FEM_mech_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,ierr) + use numerics, only: & + BBarStabilisation + use homogenization, only: & + materialpoint_dPdF, & + materialpoint_F + use math, only: & + math_inv33, & + math_identity2nd, & + math_det33 + use FEM_utilities, only: & + utilities_projectBCValues + + implicit none + + DM :: dm_local + PetscDS :: prob + Vec :: x_local, xx_local + Mat :: Jac_pre, Jac + PetscSection :: section, gSection + PetscReal :: detJ, IcellJMat(dimPlex,dimPlex) + PetscReal, target :: v0(dimPlex), cellJ(dimPlex*dimPlex), & + invcellJ(dimPlex*dimPlex) + PetscReal, pointer :: pV0(:), pCellJ(:), pInvcellJ(:) + PetscReal, dimension(:), pointer :: basisField, basisFieldDer + PetscInt :: cellStart, cellEnd, cell, field, face, & + qPt, basis, comp, cidx + PetscScalar, target :: K_e (cellDof,cellDof), & + K_eA (cellDof,cellDof), & + K_eB (cellDof,cellDof), & + K_eVec(cellDof*cellDof) + PetscReal :: BMat (dimPlex*dimPlex,cellDof), & + BMatAvg(dimPlex*dimPlex,cellDof), & + MatA (dimPlex*dimPlex,cellDof), & + MatB (1 ,cellDof) + PetscScalar, dimension(:), pointer :: pK_e, x_scal + PetscReal, dimension(3,3) :: F = math_I3, FAvg, FInv + PetscObject :: dummy + PetscInt :: bcSize + IS :: bcPoints + PetscErrorCode :: ierr + + pV0 => v0 + pCellJ => cellJ + pInvcellJ => invcellJ + call MatSetOption(Jac,MAT_KEEP_NONZERO_PATTERN,PETSC_TRUE,ierr); CHKERRQ(ierr) + call MatSetOption(Jac,MAT_NEW_NONZERO_ALLOCATION_ERR,PETSC_FALSE,ierr); CHKERRQ(ierr) + call MatZeroEntries(Jac,ierr); CHKERRQ(ierr) + call DMGetDS(dm_local,prob,ierr); CHKERRQ(ierr) + call PetscDSGetTabulation(prob,0,basisField,basisFieldDer,ierr) + call DMGetDefaultSection(dm_local,section,ierr); CHKERRQ(ierr) + call DMGetDefaultGlobalSection(dm_local,gSection,ierr); CHKERRQ(ierr) + + call DMGetLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + call VecWAXPY(x_local,1.0,xx_local,solution_local,ierr); CHKERRQ(ierr) + do field = 1, dimPlex; do face = 1, mesh_Nboundaries + if (params%fieldBC%componentBC(field)%Mask(face)) then + call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,ierr) + if (bcSize > 0) then + call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,ierr) + CHKERRQ(ierr) + call utilities_projectBCValues(x_local,section,0,field-1,bcPoints, & + 0.0,params%fieldBC%componentBC(field)%Value(face),params%timeinc) + call ISDestroy(bcPoints,ierr); CHKERRQ(ierr) + endif + endif + enddo; enddo + call DMPlexGetHeightStratum(dm_local,0,cellStart,cellEnd,ierr); CHKERRQ(ierr) + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,ierr) !< get Dofs belonging to element + CHKERRQ(ierr) + call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) + CHKERRQ(ierr) + IcellJMat = reshape(pInvcellJ, shape = [dimPlex,dimPlex]) + K_eA = 0.0 + K_eB = 0.0 + MatB = 0.0 + FAvg = 0.0 + BMatAvg = 0.0 + do qPt = 0, nQuadrature-1 + BMat = 0.0 + do basis = 0, nBasis-1 + do comp = 0, dimPlex-1 + cidx = basis*dimPlex+comp + BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = & + matmul(IcellJMat,basisFieldDer((qPt*nBasis*dimPlex+cidx )*dimPlex+1: & + (qPt*nBasis*dimPlex+cidx+1)*dimPlex )) + enddo + enddo + MatA = matmul(reshape(reshape(materialpoint_dPdF(1:dimPlex,1:dimPlex,1:dimPlex,1:dimPlex,qPt+1,cell+1), & + shape=[dimPlex,dimPlex,dimPlex,dimPlex], order=[2,1,4,3]), & + shape=[dimPlex*dimPlex,dimPlex*dimPlex]),BMat)*qWeights(qPt+1) + if (BBarStabilisation) then + F(1:dimPlex,1:dimPlex) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex]) + FInv = math_inv33(F) + K_eA = K_eA + matmul(transpose(BMat),MatA)*math_det33(FInv)**(1.0/real(dimPlex)) + K_eB = K_eB - & + matmul(transpose(matmul(reshape(materialpoint_F(1:dimPlex,1:dimPlex,qPt+1,cell+1), & + shape=[dimPlex*dimPlex,1]), & + matmul(reshape(FInv(1:dimPlex,1:dimPlex), & + shape=[1,dimPlex*dimPlex],order=[2,1]),BMat))),MatA) + MatB = MatB + & + matmul(reshape(materialpoint_F(1:dimPlex,1:dimPlex,qPt+1,cell+1),shape=[1,dimPlex*dimPlex]),MatA) + FAvg = FAvg + F + BMatAvg = BMatAvg + BMat + else + K_eA = K_eA + matmul(transpose(BMat),MatA) + endif + enddo + if (BBarStabilisation) then + FInv = math_inv33(FAvg) + K_e = K_eA*math_det33(FAvg/real(nQuadrature))**(1.0/real(dimPlex)) + & + (matmul(matmul(transpose(BMatAvg), & + reshape(FInv(1:dimPlex,1:dimPlex),shape=[dimPlex*dimPlex,1],order=[2,1])),MatB) + & + K_eB)/real(dimPlex) + + else + K_e = K_eA + endif + K_e = K_e + eps*math_identity2nd(cellDof) + K_eVec = reshape(K_e, [cellDof*cellDof])*abs(detJ) + pK_e => K_eVec + call DMPlexMatSetClosure(dm_local,section,gSection,Jac,cell,pK_e,ADD_VALUES,ierr) + CHKERRQ(ierr) + call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,ierr) + CHKERRQ(ierr) + enddo + call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyBegin(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyEnd(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call DMRestoreLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! apply boundary conditions + call DMPlexCreateRigidBody(dm_local,matnull,ierr); CHKERRQ(ierr) + call MatSetNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) + call MatSetNearNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) + call MatNullSpaceDestroy(matnull,ierr); CHKERRQ(ierr) + +end subroutine FEM_mech_formJacobian + +!-------------------------------------------------------------------------------------------------- +!> @brief forwarding routine +!-------------------------------------------------------------------------------------------------- +subroutine FEM_mech_forward(guess,timeinc,timeinc_old,fieldBC) + use FEM_utilities, only: & + cutBack + use homogenization, only: & + materialpoint_F0, & + materialpoint_F + use FEM_utilities, only: & + utilities_projectBCValues + + implicit none + type(tFieldBC), intent(in) :: & + fieldBC + real(pReal), intent(in) :: & + timeinc_old, & + timeinc + logical, intent(in) :: & + guess + PetscInt :: field, face + DM :: dm_local + Vec :: x_local + PetscSection :: section + PetscInt :: bcSize + IS :: bcPoints + PetscErrorCode :: ierr + +!-------------------------------------------------------------------------------------------------- +! forward last inc + if (guess .and. .not. cutBack) then + ForwardData = .True. + materialpoint_F0 = materialpoint_F + call SNESGetDM(mech_snes,dm_local,ierr); CHKERRQ(ierr) !< retrieve mesh info from mech_snes into dm_local + call DMGetDefaultSection(dm_local,section,ierr); CHKERRQ(ierr) + call DMGetLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + call VecSet(x_local,0.0,ierr); CHKERRQ(ierr) + call DMGlobalToLocalBegin(dm_local,solution,INSERT_VALUES,x_local,ierr) !< retrieve my partition of global solution vector + CHKERRQ(ierr) + call DMGlobalToLocalEnd(dm_local,solution,INSERT_VALUES,x_local,ierr) + CHKERRQ(ierr) + call VecAXPY(solution_local,1.0,x_local,ierr); CHKERRQ(ierr) + do field = 1, dimPlex; do face = 1, mesh_Nboundaries + if (fieldBC%componentBC(field)%Mask(face)) then + call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,ierr) + if (bcSize > 0) then + call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,ierr) + CHKERRQ(ierr) + call utilities_projectBCValues(solution_local,section,0,field-1,bcPoints, & + 0.0,fieldBC%componentBC(field)%Value(face),timeinc_old) + call ISDestroy(bcPoints,ierr); CHKERRQ(ierr) + endif + endif + enddo; enddo + call DMRestoreLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! update rate and forward last inc + call VecCopy(solution,solution_rate,ierr); CHKERRQ(ierr) + call VecScale(solution_rate,1.0/timeinc_old,ierr); CHKERRQ(ierr) + endif + call VecCopy(solution_rate,solution,ierr); CHKERRQ(ierr) + call VecScale(solution,timeinc,ierr); CHKERRQ(ierr) + +end subroutine FEM_mech_forward + + +!-------------------------------------------------------------------------------------------------- +!> @brief reporting +!-------------------------------------------------------------------------------------------------- +subroutine FEM_mech_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) + use numerics, only: & + err_struct_tolAbs, & + err_struct_tolRel + use IO, only: & + IO_intOut + use FEsolving, only: & + terminallyIll + + implicit none + SNES :: snes_local + PetscInt :: PETScIter + PetscReal :: xnorm,snorm,fnorm,divTol + SNESConvergedReason :: reason + PetscObject :: dummy + PetscErrorCode :: ierr + +!-------------------------------------------------------------------------------------------------- +! report + divTol = max(maxval(abs(P_av(1:dimPlex,1:dimPlex)))*err_struct_tolRel,err_struct_tolAbs) + call SNESConvergedDefault(snes_local,PETScIter,xnorm,snorm,fnorm/divTol,reason,dummy,ierr) + CHKERRQ(ierr) + if (terminallyIll) reason = SNES_DIVERGED_FUNCTION_DOMAIN + if (worldrank == 0) then + write(6,'(1/,1x,a,a,i0,a,i0,f0.3)') trim(incInfo), & + ' @ Iteration ',PETScIter,' mechanical residual norm = ', & + int(fnorm/divTol),fnorm/divTol-int(fnorm/divTol) + write(6,'(/,a,/,3(3(2x,f12.4,1x)/))',advance='no') ' Piola--Kirchhoff stress / MPa =',& + transpose(P_av)*1.e-6_pReal + flush(6) + endif + +end subroutine FEM_mech_converged + +!-------------------------------------------------------------------------------------------------- +!> @brief output routine +!-------------------------------------------------------------------------------------------------- +subroutine FEM_mech_output(inc,fieldBC) + use material, only: & + material_Nhomogenization, & + material_Ncrystallite, & + material_Nphase, & + homogenization_maxNgrains, & + homogenization_name, & + crystallite_name, & + phase_name + use homogenization, only: & + homogOutput, & + crystalliteOutput, & + phaseOutput + use numerics, only: & + integrationOrder + use FEM_utilities, only: & + resUnit, & + coordinatesVec, & + homogenizationResultsVec, & + crystalliteResultsVec, & + phaseResultsVec + + implicit none + integer(pInt), intent(in) :: inc + type(tFieldBC),intent(in) :: fieldBC + DM :: dm_local + PetscDS :: prob + Vec :: localVec + PetscScalar, dimension(:), pointer :: x_scal, coordinates, results + PetscSection :: section + PetscReal, pointer :: basisField(:), basisFieldDer(:) + PetscInt :: nodeStart, nodeEnd, node + PetscInt :: faceStart, faceEnd, face + PetscInt :: cellStart, cellEnd, cell + PetscInt :: field, qPt, qOffset, fOffset, dim, gType, cSize + PetscInt :: homog, cryst, grain, phase, res, resSize + PetscErrorCode :: ierr + character(len=1024) :: resultPartition, incPartition, homogPartition, & + crystPartition, phasePartition, & + grainStr + integer(pInt) :: ctr + + write(incPartition,'(a11,i0)') '/Increment_',inc + call PetscViewerHDF5PushGroup(resUnit, trim(incPartition), ierr); CHKERRQ(ierr) + call SNESGetDM(mech_snes,dm_local,ierr); CHKERRQ(ierr) !< retrieve mesh info from mech_snes into dm_local + call DMGetDS(dm_local,prob,ierr); CHKERRQ(ierr) !< retrieve discretization from mesh and store in prob + call DMGetDefaultSection(dm_local,section,ierr); CHKERRQ(ierr) !< retrieve section (degrees of freedom) + call DMGetLocalVector(dm_local,localVec,ierr); CHKERRQ(ierr) !< retrieve local vector + call VecCopy(solution_local,localVec,ierr); CHKERRQ(ierr) + + call VecGetArrayF90(coordinatesVec, coordinates, ierr); CHKERRQ(ierr) + ctr = 1_pInt + select case (integrationOrder) + case(1_pInt) !< first order quadrature + call DMPlexGetDepthStratum(dm_local,0,nodeStart,nodeEnd,ierr); CHKERRQ(ierr) !< get index range of entities at dimension 0 (i.e., all nodes) + do node = nodeStart, nodeEnd-1 !< loop over all nodes in mesh + call DMPlexVecGetClosure(dm_local,section,localVec,node,x_scal,ierr) !< x_scal = localVec (i.e. solution) at node + CHKERRQ(ierr) + do dim = 1, dimPlex + coordinates(ctr) = x_scal(dim); ctr = ctr + 1_pInt !< coordinates of node + enddo + call DMPlexVecRestoreClosure(dm_local,section,localVec,node,x_scal,ierr) !< disassociate x_scal pointer + CHKERRQ(ierr) + enddo + case(2_pInt) !< second order quadrature + call DMPlexGetHeightStratum(dm_local,0,cellStart,cellEnd,ierr) !< get index range of highest dimension object (i.e. cells of mesh) TODO 3D assumption!! + CHKERRQ(ierr) + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexVecGetClosure(dm_local,section,localVec,cell,x_scal,ierr) + CHKERRQ(ierr) + do dim = 1, dimPlex + coordinates(ctr) = sum(x_scal(dim:cellDof:dimPlex))/real(nBasis) !< coordinates of cell center + ctr = ctr + 1_pInt + enddo + call DMPlexVecRestoreClosure(dm_local,section,localVec,cell,x_scal,ierr) + CHKERRQ(ierr) + enddo + call DMPlexGetDepthStratum(dm_local,0,nodeStart,nodeEnd,ierr) !< get index range of entities at dimension 0 (i.e., all nodes) + CHKERRQ(ierr) + do node = nodeStart, nodeEnd-1 !< loop over all nodes + call DMPlexVecGetClosure(dm_local,section,localVec,node,x_scal,ierr) + CHKERRQ(ierr) + do dim = 1, dimPlex + coordinates(ctr) = x_scal(dim) !< coordinates of cell corners + ctr = ctr + 1_pInt + enddo + call DMPlexVecRestoreClosure(dm_local,section,localVec,node,x_scal,ierr) + CHKERRQ(ierr) + enddo + do gType = 1, dimPlex-1 + call DMPlexGetHeightStratum(dm_local,gType,faceStart,faceEnd,ierr) !< get index range of entities at dimension N-1 (i.e., all faces) + CHKERRQ(ierr) + do face = faceStart, faceEnd-1 !< loop over all elements + call DMPlexVecGetClosure(dm_local,section,localVec,face,x_scal,ierr) + CHKERRQ(ierr) + cSize = size(x_scal) + do dim = 1, dimPlex + coordinates(ctr) = sum(x_scal(dim:cSize:dimPlex))/real(cSize/dimPlex) !< coordinates of edge/face centers TODO quadratic element assumption used here! + ctr = ctr + 1_pInt + enddo + call DMPlexVecRestoreClosure(dm_local,section,localVec,face,x_scal,ierr) + CHKERRQ(ierr) + enddo + enddo + case default + call DMPlexGetHeightStratum(dm_local,0,cellStart,cellEnd,ierr) !< get index range of elements (mesh cells) + CHKERRQ(ierr) + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexVecGetClosure(dm_local, & !< mesh + section, & !< distribution of DoF on mesh + localVec, & !< overall solution vector (i.e. all DoFs)... + cell, & !< ...at this cell + x_scal, & !< store all DoFs of closure (faces, edges, nodes if present) into x_scal + ierr) !< --> get coordinates of closure entities with DoFs + CHKERRQ(ierr) + qOffset = 0 + do qPt = 1, nQuadrature !< loop over each quad point in cell + fOffset = 0 + do field = 0, dimPlex-1 !< loop over each solution field (e.g., x,y,z coordinates) + call PetscDSGetTabulation(prob,field,basisField,basisFieldDer,ierr) !< retrieve shape function at each quadrature point for field + CHKERRQ(ierr) + coordinates(ctr) = real(sum(basisField(qOffset+1:qOffset+nBasis)* & + x_scal(fOffset+1:fOffset+nBasis)), pReal) !< interpolate field value (in x_scal) to quad points + ctr = ctr + 1_pInt + fOffset = fOffset + nBasis !< wind forward by one field + enddo + qOffset = qOffset + nBasis !< wind forward by one quad point + enddo + call DMPlexVecRestoreClosure(dm_local,section,localVec,cell,x_scal,ierr) + CHKERRQ(ierr) + enddo + end select + call VecRestoreArrayF90(coordinatesVec, coordinates, ierr); CHKERRQ(ierr) + call VecAssemblyBegin(coordinatesVec, ierr); CHKERRQ(ierr) + call VecAssemblyEnd (coordinatesVec, ierr); CHKERRQ(ierr) + call VecView(coordinatesVec, resUnit, ierr); CHKERRQ(ierr) + call DMRestoreLocalVector(dm_local,localVec,ierr); CHKERRQ(ierr) + + do homog = 1, material_Nhomogenization + call VecGetSize(homogenizationResultsVec(homog),resSize,ierr) + if (resSize > 0) then + homogPartition = trim(incPartition)//'/Homog_'//trim(homogenization_name(homog)) + call PetscViewerHDF5PushGroup(resUnit, homogPartition, ierr) + CHKERRQ(ierr) + do res = 1, homogOutput(homog)%sizeResults + write(resultPartition,'(a12,i0)') 'homogResult_',res + call PetscObjectSetName(homogenizationResultsVec(homog),trim(resultPartition),ierr) + CHKERRQ(ierr) + call VecGetArrayF90(homogenizationResultsVec(homog),results,ierr);CHKERRQ(ierr) + results = homogOutput(homog)%output(res,:) + call VecRestoreArrayF90(homogenizationResultsVec(homog), results, ierr) + CHKERRQ(ierr) + call VecAssemblyBegin(homogenizationResultsVec(homog), ierr); CHKERRQ(ierr) + call VecAssemblyEnd (homogenizationResultsVec(homog), ierr); CHKERRQ(ierr) + call VecView(homogenizationResultsVec(homog), resUnit, ierr); CHKERRQ(ierr) + enddo + call PetscViewerHDF5PopGroup(resUnit, ierr); CHKERRQ(ierr) + endif + enddo + do cryst = 1, material_Ncrystallite; do grain = 1, homogenization_maxNgrains + call VecGetSize(crystalliteResultsVec(cryst,grain),resSize,ierr) + if (resSize > 0) then + write(grainStr,'(a,i0)') 'Grain',grain + crystPartition = trim(incPartition)//'/Crystallite_'//trim(crystallite_name(cryst))//'_'//trim(grainStr) + call PetscViewerHDF5PushGroup(resUnit, crystPartition, ierr) + CHKERRQ(ierr) + do res = 1, crystalliteOutput(cryst,grain)%sizeResults + write(resultPartition,'(a18,i0)') 'crystalliteResult_',res + call PetscObjectSetName(crystalliteResultsVec(cryst,grain),trim(resultPartition),ierr) + CHKERRQ(ierr) + call VecGetArrayF90(crystalliteResultsVec(cryst,grain),results,ierr) + CHKERRQ(ierr) + results = crystalliteOutput(cryst,grain)%output(res,:) + call VecRestoreArrayF90(crystalliteResultsVec(cryst,grain), results, ierr) + CHKERRQ(ierr) + call VecAssemblyBegin(crystalliteResultsVec(cryst,grain), ierr);CHKERRQ(ierr) + call VecAssemblyEnd (crystalliteResultsVec(cryst,grain), ierr);CHKERRQ(ierr) + call VecView(crystalliteResultsVec(cryst,grain), resUnit, ierr);CHKERRQ(ierr) + enddo + call PetscViewerHDF5PopGroup(resUnit, ierr); CHKERRQ(ierr) + endif + enddo; enddo + do phase = 1, material_Nphase; do grain = 1, homogenization_maxNgrains + call VecGetSize(phaseResultsVec(phase,grain),resSize,ierr) + if (resSize > 0) then + write(grainStr,'(a,i0)') 'Grain',grain + phasePartition = trim(incPartition)//'/Phase_'//trim(phase_name(phase))//'_'//trim(grainStr) + call PetscViewerHDF5PushGroup(resUnit, phasePartition, ierr) + CHKERRQ(ierr) + do res = 1, phaseOutput(phase,grain)%sizeResults + write(resultPartition,'(a12,i0)') 'phaseResult_',res + call PetscObjectSetName(phaseResultsVec(phase,grain),trim(resultPartition),ierr) + CHKERRQ(ierr) + call VecGetArrayF90(phaseResultsVec(phase,grain),results,ierr);CHKERRQ(ierr) + results = phaseOutput(phase,grain)%output(res,:) + call VecRestoreArrayF90(phaseResultsVec(phase,grain), results, ierr) + CHKERRQ(ierr) + call VecAssemblyBegin(phaseResultsVec(phase,grain), ierr); CHKERRQ(ierr) + call VecAssemblyEnd (phaseResultsVec(phase,grain), ierr); CHKERRQ(ierr) + call VecView(phaseResultsVec(phase,grain), resUnit, ierr); CHKERRQ(ierr) + enddo + call PetscViewerHDF5PopGroup(resUnit, ierr); CHKERRQ(ierr) + endif + enddo; enddo + +end subroutine FEM_mech_output + +!-------------------------------------------------------------------------------------------------- +!> @brief destroy routine +!-------------------------------------------------------------------------------------------------- +subroutine FEM_mech_destroy() + + implicit none + PetscErrorCode :: ierr + + call VecDestroy(solution,ierr); CHKERRQ(ierr) + call VecDestroy(solution_rate,ierr); CHKERRQ(ierr) + call SNESDestroy(mech_snes,ierr); CHKERRQ(ierr) + +end subroutine FEM_mech_destroy + +end module FEM_mech diff --git a/src/FEM_mesh.f90 b/src/FEM_mesh.f90 new file mode 100644 index 000000000..82b91ddc9 --- /dev/null +++ b/src/FEM_mesh.f90 @@ -0,0 +1,446 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Driver controlling inner and outer load case looping of the FEM solver +!> @details doing cutbacking, forwarding in case of restart, reporting statistics, writing +!> results +!-------------------------------------------------------------------------------------------------- +module mesh + use, intrinsic :: iso_c_binding + use prec, only: pReal, pInt + + implicit none +#include + private + integer(pInt), public, protected :: & + mesh_Nboundaries, & + mesh_NcpElems, & !< total number of CP elements in mesh + mesh_NcpElemsGlobal, & + 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, & + mesh_Nelems !< total number of elements in mesh + + real(pReal), public, protected :: charLength + + integer(pInt), dimension(:,:), allocatable, public, protected :: & + mesh_element !< FEid, type(internal representation), material, texture, node indices as CP IDs + + real(pReal), dimension(:,:), allocatable, public :: & + mesh_node !< node x,y,z coordinates (after deformation! ONLY FOR MARC!!!) + + real(pReal), dimension(:,:), allocatable, public, protected :: & + mesh_ipVolume, & !< volume associated with IP (initially!) + mesh_node0 !< node x,y,z coordinates (initially!) + + real(pReal), dimension(:,:,:), allocatable, public :: & + mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!) + + real(pReal), dimension(:,:,:), allocatable, public, protected :: & + mesh_ipArea !< area of interface to neighboring IP (initially!) + + real(pReal),dimension(:,:,:,:), allocatable, public, protected :: & + mesh_ipAreaNormal !< area normal of interface to neighboring IP (initially!) + + integer(pInt), dimension(:,:,:,:), allocatable, public, protected :: & + mesh_ipNeighborhood !< 6 or less neighboring IPs as [element_num, IP_index, neighbor_index that points to me] + + logical, dimension(3), public, protected :: mesh_periodicSurface !< flag indicating periodic outer surfaces (used for fluxes) + + integer(pInt), dimension(:,:), allocatable, target, private :: & + mesh_mapFEtoCPelem, & !< [sorted FEid, corresponding CPid] + mesh_mapFEtoCPnode !< [sorted FEid, corresponding CPid] + + DM, public :: geomMesh + + integer(pInt), dimension(:), allocatable, public, protected :: & + mesh_boundaries + +! These definitions should actually reside in the FE-solver specific part (different for MARC/ABAQUS) +! Hence, I suggest to prefix with "FE_" + + integer(pInt), parameter, public :: & + FE_Nelemtypes = 1_pInt, & + FE_Ngeomtypes = 1_pInt, & + FE_Ncelltypes = 1_pInt, & + FE_maxNnodes = 1_pInt, & + FE_maxNips = 14_pInt + + integer(pInt), dimension(FE_Nelemtypes), parameter, public :: FE_geomtype = & !< geometry type of particular element type + int([1],pInt) + + integer(pInt), dimension(FE_Ngeomtypes), parameter, public :: FE_celltype = & !< cell type that is used by each geometry type + int([1],pInt) + + integer(pInt), dimension(FE_Nelemtypes), parameter, public :: FE_Nnodes = & !< number of nodes that constitute a specific type of element + int([0],pInt) + + integer(pInt), dimension(FE_Ngeomtypes), public :: FE_Nips = & !< number of IPs in a specific type of element + int([0],pInt) + + integer(pInt), dimension(FE_Ncelltypes), parameter, public :: FE_NipNeighbors = & !< number of ip neighbors / cell faces in a specific cell type + int([6],pInt) + + + public :: & + mesh_init, & + mesh_FEasCP, & + mesh_FEM_build_ipVolumes, & + mesh_FEM_build_ipCoordinates, & + mesh_cellCenterCoordinates + + external :: & + MPI_abort, & + MPI_Bcast, & + DMClone, & + DMGetDimension, & + DMPlexCreateFromFile, & + DMPlexDistribute, & + DMPlexCopyCoordinates, & + DMGetStratumSize, & + DMPlexGetHeightStratum, & + DMPlexGetLabelValue, & + DMPlexSetLabelValue, & + DMDestroy + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief initializes the mesh by calling all necessary private routines the mesh module +!! Order and routines strongly depend on type of solver +!-------------------------------------------------------------------------------------------------- +subroutine mesh_init(ip,el) + 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 IO, only: & + IO_timeStamp, & + IO_error, & + IO_open_file, & + IO_stringPos, & + IO_intValue, & + IO_EOF, & + IO_read, & + IO_isBlank + use debug, only: & + debug_e, & + debug_i + use numerics, only: & + usePingPong, & + integrationOrder, & + worldrank, & + worldsize + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP, & + calcMode + use FEM_Zoo, only: & + FEM_Zoo_nQuadrature, & + FEM_Zoo_QuadraturePoints + + implicit none + integer(pInt), parameter :: FILEUNIT = 222_pInt + integer(pInt), intent(in) :: el, ip + integer(pInt) :: j + integer(pInt), allocatable, dimension(:) :: chunkPos + integer :: dimPlex + character(len=512) :: & + line + logical :: flag + PetscSF :: sf + DM :: globalMesh + PetscInt :: face, nFaceSets + PetscInt, pointer :: pFaceSets(:) + IS :: faceSetIS + PetscErrorCode :: ierr + + + if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- mesh init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif + + if (allocated(mesh_mapFEtoCPelem)) deallocate(mesh_mapFEtoCPelem) + if (allocated(mesh_mapFEtoCPnode)) deallocate(mesh_mapFEtoCPnode) + if (allocated(mesh_node0)) deallocate(mesh_node0) + if (allocated(mesh_node)) deallocate(mesh_node) + if (allocated(mesh_element)) deallocate(mesh_element) + if (allocated(mesh_ipCoordinates)) deallocate(mesh_ipCoordinates) + if (allocated(mesh_ipVolume)) deallocate(mesh_ipVolume) + + call DMPlexCreateFromFile(PETSC_COMM_WORLD,geometryFile,PETSC_TRUE,globalMesh,ierr) + CHKERRQ(ierr) + call DMGetDimension(globalMesh,dimPlex,ierr) + CHKERRQ(ierr) + call DMGetStratumSize(globalMesh,'depth',dimPlex,mesh_NcpElemsGlobal,ierr) + CHKERRQ(ierr) + call DMGetLabelSize(globalMesh,'Face Sets',mesh_Nboundaries,ierr) + CHKERRQ(ierr) + call MPI_Bcast(mesh_Nboundaries,1,MPI_INTEGER,0,PETSC_COMM_WORLD,ierr) + call MPI_Bcast(mesh_NcpElemsGlobal,1,MPI_INTEGER,0,PETSC_COMM_WORLD,ierr) + call MPI_Bcast(dimPlex,1,MPI_INTEGER,0,PETSC_COMM_WORLD,ierr) + + allocate(mesh_boundaries(mesh_Nboundaries), source = 0_pInt) + call DMGetLabelSize(globalMesh,'Face Sets',nFaceSets,ierr) + CHKERRQ(ierr) + call DMGetLabelIdIS(globalMesh,'Face Sets',faceSetIS,ierr) + CHKERRQ(ierr) + if (nFaceSets > 0) call ISGetIndicesF90(faceSetIS,pFaceSets,ierr) + do face = 1, nFaceSets + mesh_boundaries(face) = pFaceSets(face) + enddo + if (nFaceSets > 0) call ISRestoreIndicesF90(faceSetIS,pFaceSets,ierr) + call MPI_Bcast(mesh_boundaries,mesh_Nboundaries,MPI_INTEGER,0,PETSC_COMM_WORLD,ierr) + + if (worldrank == 0) then + j = 0 + flag = .false. + call IO_open_file(FILEUNIT,trim(geometryFile)) + do + read(FILEUNIT,'(a512)') line + if (trim(line) == IO_EOF) exit ! skip empty lines + if (trim(line) == '$Elements') then + read(FILEUNIT,'(a512)') line + read(FILEUNIT,'(a512)') line + flag = .true. + endif + if (trim(line) == '$EndElements') exit + if (flag) then + chunkPos = IO_stringPos(line) + if (chunkPos(1) == 3+IO_intValue(line,chunkPos,3)+dimPlex+1) then + call DMSetLabelValue(globalMesh,'material',j,IO_intValue(line,chunkPos,4),ierr) + CHKERRQ(ierr) + j = j + 1 + endif ! count all identifiers to allocate memory and do sanity check + endif + enddo + close (FILEUNIT) + endif + + if (worldsize > 1) then + call DMPlexDistribute(globalMesh,0,sf,geomMesh,ierr) + CHKERRQ(ierr) + else + call DMClone(globalMesh,geomMesh,ierr) + CHKERRQ(ierr) + endif + call DMDestroy(globalMesh,ierr); CHKERRQ(ierr) + + call DMGetStratumSize(geomMesh,'depth',dimPlex,mesh_Nelems,ierr) + CHKERRQ(ierr) + call DMGetStratumSize(geomMesh,'depth',0,mesh_Nnodes,ierr) + CHKERRQ(ierr) + mesh_NcpElems = mesh_Nelems + call mesh_FEM_mapNodesAndElems + + FE_Nips(FE_geomtype(1_pInt)) = FEM_Zoo_nQuadrature(dimPlex,integrationOrder) + mesh_maxNnodes = FE_Nnodes(1_pInt) + mesh_maxNips = FE_Nips(1_pInt) + call mesh_FEM_build_ipCoordinates(dimPlex,FEM_Zoo_QuadraturePoints(dimPlex,integrationOrder)%p) + call mesh_FEM_build_ipVolumes(dimPlex) + + allocate (mesh_element (4_pInt+mesh_maxNnodes,mesh_NcpElems)); mesh_element = 0_pInt + do j = 1, mesh_NcpElems + mesh_element( 1,j) = j + mesh_element( 2,j) = 1_pInt ! elem type + mesh_element( 3,j) = 1_pInt ! homogenization + call DMGetLabelValue(geomMesh,'material',j-1,mesh_element(4,j),ierr) + CHKERRQ(ierr) + end do + + if (usePingPong .and. (mesh_Nelems /= mesh_NcpElems)) & + call IO_error(600_pInt) ! ping-pong must be disabled when having non-DAMASK elements + if (debug_e < 1 .or. debug_e > mesh_NcpElems) & + call IO_error(602_pInt,ext_msg='element') ! selected element does not exist + if (debug_i < 1 .or. debug_i > FE_Nips(FE_geomtype(mesh_element(2_pInt,debug_e)))) & + call IO_error(602_pInt,ext_msg='IP') ! selected element does not have requested IP + + FEsolving_execElem = [ 1_pInt,mesh_NcpElems ] ! parallel loop bounds set to comprise all DAMASK elements + if (allocated(FEsolving_execIP)) deallocate(FEsolving_execIP) + allocate(FEsolving_execIP(2_pInt,mesh_NcpElems)); FEsolving_execIP = 1_pInt ! parallel loop bounds set to comprise from first IP... + forall (j = 1_pInt:mesh_NcpElems) FEsolving_execIP(2,j) = FE_Nips(FE_geomtype(mesh_element(2,j))) ! ...up to own IP count for each element + + if (allocated(calcMode)) deallocate(calcMode) + allocate(calcMode(mesh_maxNips,mesh_NcpElems)) + calcMode = .false. ! pretend to have collected what first call is asking (F = I) + calcMode(ip,mesh_FEasCP('elem',el)) = .true. ! first ip,el needs to be already pingponged to "calc" + +end subroutine mesh_init + +!-------------------------------------------------------------------------------------------------- +!> @brief Gives the FE to CP ID mapping by binary search through lookup array +!! valid questions (what) are 'elem', 'node' +!-------------------------------------------------------------------------------------------------- +integer(pInt) function mesh_FEasCP(what,myID) + use IO, only: & + IO_lc + + implicit none + character(len=*), intent(in) :: what + integer(pInt), intent(in) :: myID + + integer(pInt), dimension(:,:), pointer :: lookupMap + integer(pInt) :: lower,upper,center + + mesh_FEasCP = 0_pInt + select case(IO_lc(what(1:4))) + case('elem') + lookupMap => mesh_mapFEtoCPelem + case('node') + lookupMap => mesh_mapFEtoCPnode + case default + return + endselect + + lower = 1_pInt + upper = int(size(lookupMap,2_pInt),pInt) + + if (lookupMap(1_pInt,lower) == myID) then ! check at bounds QUESTION is it valid to extend bounds by 1 and just do binary search w/o init check at bounds? + mesh_FEasCP = lookupMap(2_pInt,lower) + return + elseif (lookupMap(1_pInt,upper) == myID) then + mesh_FEasCP = lookupMap(2_pInt,upper) + return + endif + + binarySearch: do while (upper-lower > 1_pInt) + center = (lower+upper)/2_pInt + if (lookupMap(1_pInt,center) < myID) then + lower = center + elseif (lookupMap(1_pInt,center) > myID) then + upper = center + else + mesh_FEasCP = lookupMap(2_pInt,center) + exit + endif + enddo binarySearch + +end function mesh_FEasCP + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates cell center coordinates. +!-------------------------------------------------------------------------------------------------- +pure function mesh_cellCenterCoordinates(ip,el) + + implicit none + integer(pInt), intent(in) :: el, & !< element number + ip !< integration point number + real(pReal), dimension(3) :: mesh_cellCenterCoordinates !< x,y,z coordinates of the cell center of the requested IP cell + + end function mesh_cellCenterCoordinates + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates IP volume. Allocates global array 'mesh_ipVolume' +!> @details The IP volume is calculated differently depending on the cell type. +!> 2D cells assume an element depth of one in order to calculate the volume. +!> For the hexahedral cell we subdivide the cell into subvolumes of pyramidal +!> shape with a cell face as basis and the central ip at the tip. This subvolume is +!> calculated as an average of four tetrahedals with three corners on the cell face +!> and one corner at the central ip. +!-------------------------------------------------------------------------------------------------- +subroutine mesh_FEM_build_ipVolumes(dimPlex) + use math, only: & + math_I3, & + math_det33 + + implicit none + PetscInt :: dimPlex + PetscReal :: vol + PetscReal, target :: cent(dimPlex), norm(dimPlex) + PetscReal, pointer :: pCent(:), pNorm(:) + PetscInt :: cellStart, cellEnd, cell + PetscErrorCode :: ierr + + if (.not. allocated(mesh_ipVolume)) then + allocate(mesh_ipVolume(mesh_maxNips,mesh_NcpElems)) + mesh_ipVolume = 0.0_pReal + endif + + call DMPlexGetHeightStratum(geomMesh,0,cellStart,cellEnd,ierr); CHKERRQ(ierr) + pCent => cent + pNorm => norm + do cell = cellStart, cellEnd-1 + call DMPlexComputeCellGeometryFVM(geomMesh,cell,vol,pCent,pNorm,ierr) + CHKERRQ(ierr) + mesh_ipVolume(:,cell+1) = vol/real(mesh_maxNips,pReal) + enddo + +end subroutine mesh_FEM_build_ipVolumes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates IP Coordinates. Allocates global array 'mesh_ipCoordinates' +! Called by all solvers in mesh_init in order to initialize the ip coordinates. +! Later on the current ip coordinates are directly prvided by the spectral solver and by Abaqus, +! so no need to use this subroutine anymore; Marc however only provides nodal displacements, +! so in this case the ip coordinates are always calculated on the basis of this subroutine. +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FOR THE MOMENT THIS SUBROUTINE ACTUALLY CALCULATES THE CELL CENTER AND NOT THE IP COORDINATES, +! AS THE IP IS NOT (ALWAYS) LOCATED IN THE CENTER OF THE IP VOLUME. +! HAS TO BE CHANGED IN A LATER VERSION. +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!-------------------------------------------------------------------------------------------------- +subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints) + + implicit none + PetscInt, intent(in) :: dimPlex + PetscReal, intent(in) :: qPoints(mesh_maxNips*dimPlex) + PetscReal, target :: v0(dimPlex), cellJ(dimPlex*dimPlex), invcellJ(dimPlex*dimPlex) + PetscReal, pointer :: pV0(:), pCellJ(:), pInvcellJ(:) + PetscReal :: detJ + PetscInt :: cellStart, cellEnd, cell, qPt, dirI, dirJ, qOffset + PetscErrorCode :: ierr + + if (.not. allocated(mesh_ipCoordinates)) then + allocate(mesh_ipCoordinates(3,mesh_maxNips,mesh_NcpElems)) + mesh_ipCoordinates = 0.0_pReal + endif + + pV0 => v0 + pCellJ => cellJ + pInvcellJ => invcellJ + call DMPlexGetHeightStratum(geomMesh,0,cellStart,cellEnd,ierr); CHKERRQ(ierr) + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexComputeCellGeometryAffineFEM(geomMesh,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) + CHKERRQ(ierr) + qOffset = 0 + do qPt = 1, mesh_maxNips + do dirI = 1, dimPlex + mesh_ipCoordinates(dirI,qPt,cell+1) = pV0(dirI) + do dirJ = 1, dimPlex + mesh_ipCoordinates(dirI,qPt,cell+1) = mesh_ipCoordinates(dirI,qPt,cell+1) + & + pCellJ((dirI-1)*dimPlex+dirJ)*(qPoints(qOffset+dirJ) + 1.0) + enddo + enddo + qOffset = qOffset + dimPlex + enddo + enddo + +end subroutine mesh_FEM_build_ipCoordinates + + +!-------------------------------------------------------------------------------------------------- +!> @brief fake map node from FE ID to internal (consecutive) representation for node and element +!! Allocates global array 'mesh_mapFEtoCPnode' and 'mesh_mapFEtoCPelem' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_FEM_mapNodesAndElems + use math, only: & + math_range + + implicit none + allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes), source = 0_pInt) + allocate (mesh_mapFEtoCPelem(2_pInt,mesh_NcpElems), source = 0_pInt) + + mesh_mapFEtoCPnode = spread(math_range(mesh_Nnodes),1,2) + mesh_mapFEtoCPelem = spread(math_range(mesh_NcpElems),1,2) + +end subroutine mesh_FEM_mapNodesAndElems + + +end module mesh diff --git a/src/FEM_utilities.f90 b/src/FEM_utilities.f90 new file mode 100644 index 000000000..621a32508 --- /dev/null +++ b/src/FEM_utilities.f90 @@ -0,0 +1,819 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Utilities used by the FEM solver +!-------------------------------------------------------------------------------------------------- +module FEM_utilities + use, intrinsic :: iso_c_binding + use prec, only: & + pReal, & + pInt + + implicit none + private +#include +!-------------------------------------------------------------------------------------------------- +! + logical, public :: cutBack = .false. !< cut back of BVP solver in case convergence is not achieved or a material point is terminally ill + integer(pInt), public, parameter :: maxFields = 6_pInt + integer(pInt), public :: nActiveFields = 0_pInt + +!-------------------------------------------------------------------------------------------------- +! grid related information information + real(pReal), public :: wgt !< weighting factor 1/Nelems + real(pReal), public :: wgtDof !< weighting factor 1/Nelems + real(pReal), public :: C_volAvg(3,3,3,3) + +!-------------------------------------------------------------------------------------------------- +! output data + PetscViewer, public :: resUnit + Vec, public :: coordinatesVec + Vec, allocatable, public :: homogenizationResultsVec(:), & + crystalliteResultsVec(:,:), & + phaseResultsVec(:,:) + +!-------------------------------------------------------------------------------------------------- +! field labels information + character(len=*), parameter, public :: & + FIELD_MECH_label = 'mechanical', & + FIELD_THERMAL_label = 'thermal', & + FIELD_DAMAGE_label = 'damage', & + FIELD_SOLUTE_label = 'solute', & + FIELD_MGTWIN_label = 'mgtwin' + + enum, bind(c) + enumerator :: FIELD_UNDEFINED_ID, & + FIELD_MECH_ID, & + FIELD_THERMAL_ID, & + FIELD_DAMAGE_ID, & + FIELD_SOLUTE_ID, & + FIELD_MGTWIN_ID + end enum + enum, bind(c) + enumerator :: COMPONENT_UNDEFINED_ID, & + COMPONENT_MECH_X_ID, & + COMPONENT_MECH_Y_ID, & + COMPONENT_MECH_Z_ID, & + COMPONENT_THERMAL_T_ID, & + COMPONENT_DAMAGE_PHI_ID, & + COMPONENT_SOLUTE_CV_ID, & + COMPONENT_SOLUTE_CVPOT_ID, & + COMPONENT_SOLUTE_CH_ID, & + COMPONENT_SOLUTE_CHPOT_ID, & + COMPONENT_SOLUTE_CVaH_ID, & + COMPONENT_SOLUTE_CVaHPOT_ID, & + COMPONENT_MGTWIN_PHI_ID + end enum + +!-------------------------------------------------------------------------------------------------- +! variables controlling debugging + logical, private :: & + debugGeneral, & !< general debugging of FEM solver + debugRotation, & !< also printing out results in lab frame + debugPETSc !< use some in debug defined options for more verbose PETSc solution + +!-------------------------------------------------------------------------------------------------- +! derived types + type, public :: tSolutionState !< return type of solution from FEM solver variants + logical :: converged = .true. + logical :: stagConverged = .true. + logical :: regrid = .false. + integer(pInt) :: iterationsNeeded = 0_pInt + end type tSolutionState + + type, public :: tComponentBC + integer(kind(COMPONENT_UNDEFINED_ID)) :: ID + real(pReal), allocatable :: Value(:) + logical, allocatable :: Mask(:) + end type tComponentBC + + type, public :: tFieldBC + integer(kind(FIELD_UNDEFINED_ID)) :: ID + integer(pInt) :: nComponents = 0_pInt + type(tComponentBC), allocatable :: componentBC(:) + end type tFieldBC + + type, public :: tLoadCase + real(pReal) :: time = 0.0_pReal !< length of increment + integer(pInt) :: incs = 0_pInt, & !< number of increments + outputfrequency = 1_pInt, & !< frequency of result writes + restartfrequency = 0_pInt, & !< frequency of restart writes + logscale = 0_pInt !< linear/logarithmic time inc flag + logical :: followFormerTrajectory = .true. !< follow trajectory of former loadcase + integer(pInt), allocatable :: faceID(:) + type(tFieldBC), allocatable :: fieldBC(:) + end type tLoadCase + + type, public :: tFEMInterpolation + integer(pInt) :: n + real(pReal), dimension(:,:) , allocatable :: shapeFunc, shapeDerivReal, geomShapeDerivIso + real(pReal), dimension(:,:,:), allocatable :: shapeDerivIso + end type tFEMInterpolation + + type, public :: tQuadrature + integer(pInt) :: n + real(pReal), dimension(:) , allocatable :: Weights + real(pReal), dimension(:,:), allocatable :: Points + end type tQuadrature + + public :: & + utilities_init, & + utilities_constitutiveResponse, & + utilities_indexBoundaryDofs, & + utilities_projectBCValues, & + utilities_indexActiveSet, & + utilities_destroy, & + FIELD_MECH_ID, & + FIELD_THERMAL_ID, & + FIELD_DAMAGE_ID, & + FIELD_SOLUTE_ID, & + FIELD_MGTWIN_ID, & + COMPONENT_MECH_X_ID, & + COMPONENT_MECH_Y_ID, & + COMPONENT_MECH_Z_ID, & + COMPONENT_THERMAL_T_ID, & + COMPONENT_DAMAGE_PHI_ID, & + COMPONENT_SOLUTE_CV_ID, & + COMPONENT_SOLUTE_CVPOT_ID, & + COMPONENT_SOLUTE_CH_ID, & + COMPONENT_SOLUTE_CHPOT_ID, & + COMPONENT_SOLUTE_CVaH_ID, & + COMPONENT_SOLUTE_CVaHPOT_ID, & + COMPONENT_MGTWIN_PHI_ID + + external :: & + MPI_abort, & + MPI_Allreduce, & + PetscOptionsClear, & + PetscOptionsInsertString, & + PetscObjectSetName, & + VecCreateMPI, & + VecSetFromOptions, & + VecGetSize, & + VecAssemblyBegin, & + VecAssemblyEnd, & + VecView, & + VecDestroy, & + ISCreateGeneral, & + ISDuplicate, & + ISDifference, & + ISGetSize, & + ISLocalToGlobalMappingApplyIS, & + ISDestroy, & + DMGetDimension, & + DMGetLocalToGlobalMapping, & + DMGetLabel, & + DMGetStratumSize, & + DMGetStratumIS, & + DMPlexGetHeightStratum, & + DMGetLabelIdIS, & + DMPlexGetChart, & + DMPlexLabelComplete, & + PetscSectionGetStorageSize, & + PetscSectionGetFieldDof, & + PetscSectionGetFieldOffset, & + PetscViewerHDF5Open, & + PetscViewerHDF5PushGroup, & + PetscViewerHDF5PopGroup, & + PetscViewerDestroy + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, sets debug flags +!-------------------------------------------------------------------------------------------------- +subroutine utilities_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran >4.6 at the moment) + use DAMASK_interface, only: & + getSolverJobName + use IO, only: & + IO_error, & + IO_warning, & + IO_timeStamp, & + IO_open_file + use numerics, only: & + integrationOrder, & + worldsize, & + worldrank, & + petsc_defaultOptions, & + petsc_options, & + structOrder, & + thermalOrder, & + damageOrder, & + soluteOrder, & + mgtwinOrder + use debug, only: & + debug_level, & + debug_SPECTRAL, & + debug_LEVELBASIC, & + debug_SPECTRALPETSC, & + debug_SPECTRALROTATION + use debug, only: & + PETSCDEBUG + use math ! must use the whole module for use of FFTW + use mesh, only: & + mesh_NcpElemsGlobal, & + mesh_maxNips, & + geomMesh, & + mesh_element + use homogenization, only: & + homogOutput, & + crystalliteOutput, & + phaseOutput + use material, only: & + material_Nhomogenization, & + material_Ncrystallite, & + material_Nphase, & + homogenization_Ngrains, & + homogenization_maxNgrains, & + material_homog, & + material_phase, & + microstructure_crystallite, & + homogenization_name, & + crystallite_name, & + phase_name + + implicit none + + character(len=1024) :: petsc_optionsPhysics, grainStr + integer(pInt) :: dimPlex + integer(pInt) :: headerID = 205_pInt + PetscInt, dimension(:), pointer :: points + PetscInt, allocatable :: nEntities(:), nOutputCells(:), nOutputNodes(:), mappingCells(:) + PetscInt :: cellStart, cellEnd, cell, ip, dim, ctr, qPt + PetscInt :: homog, cryst, grain, phase + PetscInt, allocatable :: connectivity(:,:) + Vec :: connectivityVec + PetscScalar, dimension(:), pointer :: results + PetscErrorCode :: ierr + + if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- DAMASK_FEM_utilities init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif + +!-------------------------------------------------------------------------------------------------- +! set debugging parameters + debugGeneral = iand(debug_level(debug_SPECTRAL),debug_LEVELBASIC) /= 0 + debugRotation = iand(debug_level(debug_SPECTRAL),debug_SPECTRALROTATION) /= 0 + debugPETSc = iand(debug_level(debug_SPECTRAL),debug_SPECTRALPETSC) /= 0 + if(debugPETSc) write(6,'(3(/,a),/)') & + ' Initializing PETSc with debug options: ', & + trim(PETScDebug), & + ' add more using the PETSc_Options keyword in numerics.config ' + flush(6) + call PetscOptionsClear(PETSC_NULL_OBJECT,ierr) + CHKERRQ(ierr) + if(debugPETSc) call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(PETSCDEBUG),ierr) + CHKERRQ(ierr) + call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(petsc_defaultOptions),ierr) + call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(petsc_options),ierr) + CHKERRQ(ierr) + write(petsc_optionsPhysics,'(a,i0)') '-mechFE_petscspace_order ' , structOrder + call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(petsc_optionsPhysics),ierr) + CHKERRQ(ierr) + write(petsc_optionsPhysics,'(a,i0)') '-thermalFE_petscspace_order ', thermalOrder + call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(petsc_optionsPhysics),ierr) + CHKERRQ(ierr) + write(petsc_optionsPhysics,'(a,i0)') '-damageFE_petscspace_order ' , damageOrder + call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(petsc_optionsPhysics),ierr) + CHKERRQ(ierr) + write(petsc_optionsPhysics,'(a,i0)') '-soluteFE_petscspace_order ', soluteOrder + call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(petsc_optionsPhysics),ierr) + CHKERRQ(ierr) + write(petsc_optionsPhysics,'(a,i0)') '-mgtwinFE_petscspace_order ', mgtwinOrder + call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(petsc_optionsPhysics),ierr) + CHKERRQ(ierr) + + wgt = 1.0/real(mesh_maxNips*mesh_NcpElemsGlobal,pReal) + + call PetscViewerHDF5Open(PETSC_COMM_WORLD, trim(getSolverJobName())//'.h5', & + FILE_MODE_WRITE, resUnit, ierr); CHKERRQ(ierr) + call PetscViewerHDF5PushGroup(resUnit, '/', ierr); CHKERRQ(ierr) + call DMGetDimension(geomMesh,dimPlex,ierr); CHKERRQ(ierr) + allocate(nEntities(dimPlex+1), source=0) + allocate(nOutputNodes(worldsize), source = 0) + allocate(nOutputCells(worldsize), source = 0) + do dim = 0, dimPlex + call DMGetStratumSize(geomMesh,'depth',dim,nEntities(dim+1),ierr) + CHKERRQ(ierr) + enddo + select case (integrationOrder) + case(1_pInt) + nOutputNodes(worldrank+1) = nEntities(1) + case(2_pInt) + nOutputNodes(worldrank+1) = sum(nEntities) + case default + nOutputNodes(worldrank+1) = mesh_maxNips*nEntities(dimPlex+1) + end select + nOutputCells(worldrank+1) = count(material_homog > 0_pInt) + call MPI_Allreduce(MPI_IN_PLACE,nOutputNodes,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) + call MPI_Allreduce(MPI_IN_PLACE,nOutputCells,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) + if (worldrank == 0_pInt) then + open(unit=headerID, file=trim(getSolverJobName())//'.header', & + form='FORMATTED', status='REPLACE') + write(headerID, '(a,i0)') 'dimension : ', dimPlex + write(headerID, '(a,i0)') 'number of nodes : ', sum(nOutputNodes) + write(headerID, '(a,i0)') 'number of cells : ', sum(nOutputCells) + endif + + allocate(connectivity(2**dimPlex,nOutputCells(worldrank+1))) + call DMPlexGetHeightStratum(geomMesh,0,cellStart,cellEnd,ierr) + CHKERRQ(ierr) + ctr = 0 + select case (integrationOrder) + case(1_pInt) + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexGetTransitiveClosure(geomMesh,cell,PETSC_TRUE,points,ierr) + CHKERRQ(ierr) + if (dimPlex == 2) then + connectivity(:,ctr+1) = [points( 9), points(11), points(13), points(13)] - nEntities(dimPlex+1) + ctr = ctr + 1 + else + connectivity(:,ctr+1) = [points(23), points(25), points(27), points(27), & + points(29), points(29), points(29), points(29)] - nEntities(dimPlex+1) + ctr = ctr + 1 + endif + enddo + + case(2_pInt) + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexGetTransitiveClosure(geomMesh,cell,PETSC_TRUE,points,ierr) + CHKERRQ(ierr) + if (dimPlex == 2) then + connectivity(:,ctr+1) = [points(9 ), points(3), points(1), points(7)] + connectivity(:,ctr+2) = [points(11), points(5), points(1), points(3)] + connectivity(:,ctr+3) = [points(13), points(7), points(1), points(5)] + ctr = ctr + 3 + else + connectivity(:,ctr+1) = [points(23), points(11), points(3), points(15), points(17), points(5), points(1), points(7)] + connectivity(:,ctr+2) = [points(25), points(13), points(3), points(11), points(19), points(9), points(1), points(5)] + connectivity(:,ctr+3) = [points(27), points(15), points(3), points(13), points(21), points(7), points(1), points(9)] + connectivity(:,ctr+4) = [points(29), points(17), points(7), points(21), points(19), points(5), points(1), points(9)] + ctr = ctr + 4_pInt + endif + enddo + + case default + do cell = cellStart, cellEnd-1; do ip = 0, mesh_maxNips-1 + connectivity(:,ctr+1) = cell*mesh_maxNips + ip + ctr = ctr + 1 + enddo; enddo + + end select + connectivity = connectivity + sum(nOutputNodes(1:worldrank)) + + call VecCreateMPI(PETSC_COMM_WORLD,dimPlex*nOutputNodes(worldrank+1),dimPlex*sum(nOutputNodes), & + coordinatesVec,ierr);CHKERRQ(ierr) + call PetscObjectSetName(coordinatesVec, 'NodalCoordinates',ierr) + call VecSetFromOptions(coordinatesVec, ierr); CHKERRQ(ierr) + + allocate(mappingCells(worldsize), source = 0) + allocate(homogenizationResultsVec(material_Nhomogenization )) + allocate(crystalliteResultsVec (material_Ncrystallite, homogenization_maxNgrains)) + allocate(phaseResultsVec (material_Nphase, homogenization_maxNgrains)) + do homog = 1, material_Nhomogenization + mappingCells = 0_pInt; mappingCells(worldrank+1) = homogOutput(homog)%sizeIpCells + call MPI_Allreduce(MPI_IN_PLACE,mappingCells,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) + call VecCreateMPI(PETSC_COMM_WORLD,mappingCells(worldrank+1),sum(mappingCells), & + homogenizationResultsVec(homog),ierr);CHKERRQ(ierr) + if (sum(mappingCells) > 0) then + call VecCreateMPI(PETSC_COMM_WORLD,mappingCells(worldrank+1)*2**dimPlex,sum(mappingCells)*2**dimPlex, & + connectivityVec,ierr);CHKERRQ(ierr) + call PetscObjectSetName(connectivityVec,'mapping_'//trim(homogenization_name(homog)),ierr) + CHKERRQ(ierr) + call VecGetArrayF90(connectivityVec,results,ierr); CHKERRQ(ierr) + results = 0.0_pReal; ctr = 1_pInt + do cell = cellStart, cellEnd-1; do qPt = 1, mesh_maxNips + if (material_homog(qPt,cell+1) == homog) then + results(ctr:ctr+2**dimPlex-1) = real(reshape(connectivity(1:2**dimPlex,mesh_maxNips*cell+qPt), & + shape=[2**dimPlex])) + ctr = ctr + 2**dimPlex + endif + enddo; enddo + call VecRestoreArrayF90(connectivityVec, results, ierr); CHKERRQ(ierr) + call VecAssemblyBegin(connectivityVec, ierr); CHKERRQ(ierr) + call VecAssemblyEnd (connectivityVec, ierr); CHKERRQ(ierr) + call VecView(connectivityVec, resUnit, ierr); CHKERRQ(ierr) + call VecDestroy(connectivityVec, ierr); CHKERRQ(ierr) + endif + enddo + do cryst = 1, material_Ncrystallite; do grain = 1, homogenization_maxNgrains + mappingCells = 0_pInt + mappingCells(worldrank+1) = crystalliteOutput(cryst,grain)%sizeIpCells + call MPI_Allreduce(MPI_IN_PLACE,mappingCells,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) + call VecCreateMPI(PETSC_COMM_WORLD,mappingCells(worldrank+1),sum(mappingCells), & + crystalliteResultsVec(cryst,grain),ierr);CHKERRQ(ierr) + if (sum(mappingCells) > 0) then + call VecCreateMPI(PETSC_COMM_WORLD,mappingCells(worldrank+1)*2**dimPlex,sum(mappingCells)*2**dimPlex, & + connectivityVec,ierr);CHKERRQ(ierr) + write(grainStr,'(a,i0)') 'Grain',grain + call PetscObjectSetName(connectivityVec,'mapping_'// & + trim(crystallite_name(cryst))//'_'// & + trim(grainStr),ierr) + CHKERRQ(ierr) + call VecGetArrayF90(connectivityVec, results, ierr); CHKERRQ(ierr) + results = 0.0_pReal; ctr = 1_pInt + do cell = cellStart, cellEnd-1; do qPt = 1, mesh_maxNips + if (homogenization_Ngrains (mesh_element(3,cell+1)) >= grain .and. & + microstructure_crystallite(mesh_element(4,cell+1)) == cryst) then + results(ctr:ctr+2**dimPlex-1) = real(reshape(connectivity(1:2**dimPlex,mesh_maxNips*cell+qPt), & + shape=[2**dimPlex])) + ctr = ctr + 2**dimPlex + endif + enddo; enddo + call VecRestoreArrayF90(connectivityVec, results, ierr); CHKERRQ(ierr) + call VecAssemblyBegin(connectivityVec, ierr); CHKERRQ(ierr) + call VecAssemblyEnd (connectivityVec, ierr); CHKERRQ(ierr) + call VecView(connectivityVec, resUnit, ierr); CHKERRQ(ierr) + call VecDestroy(connectivityVec, ierr); CHKERRQ(ierr) + endif + enddo; enddo + do phase = 1, material_Nphase; do grain = 1, homogenization_maxNgrains + mappingCells = 0_pInt + mappingCells(worldrank+1) = phaseOutput(phase,grain)%sizeIpCells + call MPI_Allreduce(MPI_IN_PLACE,mappingCells,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) + call VecCreateMPI(PETSC_COMM_WORLD,mappingCells(worldrank+1),sum(mappingCells), & + phaseResultsVec(phase,grain),ierr);CHKERRQ(ierr) + if (sum(mappingCells) > 0) then + call VecCreateMPI(PETSC_COMM_WORLD,mappingCells(worldrank+1)*2**dimPlex,sum(mappingCells)*2**dimPlex, & + connectivityVec,ierr);CHKERRQ(ierr) + write(grainStr,'(a,i0)') 'Grain',grain + call PetscObjectSetName(connectivityVec,& + 'mapping_'//trim(phase_name(phase))//'_'// & + trim(grainStr),ierr) + CHKERRQ(ierr) + call VecGetArrayF90(connectivityVec, results, ierr) + CHKERRQ(ierr) + results = 0.0_pReal; ctr = 1_pInt + do cell = cellStart, cellEnd-1; do qPt = 1, mesh_maxNips + if (material_phase(grain,qPt,cell+1) == phase) then + results(ctr:ctr+2**dimPlex-1) = real(reshape(connectivity(1:2**dimPlex,mesh_maxNips*cell+qPt), & + shape=[2**dimPlex])) + ctr = ctr + 2**dimPlex + endif + enddo; enddo + call VecRestoreArrayF90(connectivityVec, results, ierr) + CHKERRQ(ierr) + call VecAssemblyBegin(connectivityVec, ierr);CHKERRQ(ierr) + call VecAssemblyEnd (connectivityVec, ierr);CHKERRQ(ierr) + call VecView(connectivityVec, resUnit, ierr);CHKERRQ(ierr) + call VecDestroy(connectivityVec, ierr); CHKERRQ(ierr) + endif + enddo; enddo + if (worldrank == 0_pInt) then + do homog = 1, material_Nhomogenization + call VecGetSize(homogenizationResultsVec(homog),mappingCells(1),ierr) + CHKERRQ(ierr) + if (mappingCells(1) > 0) & + write(headerID, '(a,i0)') 'number of homog_'// & + trim(homogenization_name(homog))//'_'// & + 'cells : ', mappingCells(1) + enddo + do cryst = 1, material_Ncrystallite; do grain = 1, homogenization_maxNgrains + call VecGetSize(crystalliteResultsVec(cryst,grain),mappingCells(1),ierr) + CHKERRQ(ierr) + write(grainStr,'(a,i0)') 'Grain',grain + if (mappingCells(1) > 0) & + write(headerID, '(a,i0)') 'number of cryst_'// & + trim(crystallite_name(cryst))//'_'// & + trim(grainStr)//'_'// & + 'cells : ', mappingCells(1) + enddo; enddo + do phase = 1, material_Nphase; do grain = 1, homogenization_maxNgrains + call VecGetSize(phaseResultsVec(phase,grain),mappingCells(1),ierr) + CHKERRQ(ierr) + write(grainStr,'(a,i0)') 'Grain',grain + if (mappingCells(1) > 0) & + write(headerID, '(a,i0)') 'number of phase_'// & + trim(phase_name(phase))//'_'//trim(grainStr)//'_'// & + 'cells : ', mappingCells(1) + enddo; enddo + close(headerID) + endif + +end subroutine utilities_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates constitutive response +!-------------------------------------------------------------------------------------------------- +subroutine utilities_constitutiveResponse(timeinc,P_av,forwardData) + use debug, only: & + debug_reset, & + debug_info + use numerics, only: & + worldrank + use math, only: & + math_transpose33, & + math_rotate_forward33, & + math_det33 + use FEsolving, only: & + restartWrite + use CPFEM2, only: & + CPFEM_general + use homogenization, only: & + materialpoint_F0, & + materialpoint_F, & + materialpoint_P, & + materialpoint_dPdF + use mesh, only: & + mesh_NcpElems + + implicit none + real(pReal), intent(in) :: timeinc !< loading time + logical, intent(in) :: forwardData !< age results + + real(pReal),intent(out), dimension(3,3) :: P_av !< average PK stress + + logical :: & + age + + integer(pInt) :: & + j + real(pReal) :: defgradDetMin, defgradDetMax, defgradDet + PetscErrorCode :: ierr + + if (worldrank == 0) & + write(6,'(/,a)') ' ... evaluating constitutive response ......................................' + + age = .False. + if (forwardData) then ! aging results + age = .True. + endif + if (cutBack) then ! restore saved variables + age = .False. + endif + call debug_reset() + +!-------------------------------------------------------------------------------------------------- +! calculate bounds of det(F) and report + if(debugGeneral) then + defgradDetMax = -huge(1.0_pReal) + defgradDetMin = +huge(1.0_pReal) + do j = 1_pInt, mesh_NcpElems + defgradDet = math_det33(materialpoint_F(1:3,1:3,1,j)) + defgradDetMax = max(defgradDetMax,defgradDet) + defgradDetMin = min(defgradDetMin,defgradDet) + end do + write(6,'(a,1x,es11.4)') ' max determinant of deformation =', defgradDetMax + write(6,'(a,1x,es11.4)') ' min determinant of deformation =', defgradDetMin + flush(6) + endif + + call CPFEM_general(age,timeinc) + + call debug_info() + + restartWrite = .false. ! reset restartWrite status + cutBack = .false. ! reset cutBack status + + P_av = sum(sum(materialpoint_P,dim=4),dim=3) * wgt ! average of P + C_volAvg = sum(sum(materialpoint_dPdF,dim=6),dim=5) * wgt + call MPI_Allreduce(MPI_IN_PLACE,P_av,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + call MPI_Allreduce(MPI_IN_PLACE,C_volAvg,81,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD, ierr) + +end subroutine utilities_constitutiveResponse + +!-------------------------------------------------------------------------------------------------- +!> @brief Create index sets of boundary dofs (in local and global numbering) +!-------------------------------------------------------------------------------------------------- +subroutine utilities_indexBoundaryDofs(dm_local,nFaceSets,numFields,local2global,section,localIS,globalIS) + + implicit none + + DM :: dm_local + ISLocalToGlobalMapping :: local2global + PetscSection :: section + PetscInt :: nFaceSets, numFields, nDof + IS, dimension(nFaceSets,numFields) :: localIS, globalIS + PetscInt :: field, faceSet, point, dof, offset + PetscInt :: localSize, storageSize, ISSize + PetscInt, dimension(:) , allocatable :: localIndices + IS :: faceSetIS, BC_IS, dummyIS + PetscInt, dimension(:) , pointer :: pFaceSets, pBCvertex, pBCvertexlc + DMLabel :: BCLabel + PetscErrorCode :: ierr + + call DMGetLabel(dm_local,'Face Sets',BCLabel,ierr); CHKERRQ(ierr) + call DMPlexLabelComplete(dm_local,BCLabel,ierr); CHKERRQ(ierr) + call PetscSectionGetStorageSize(section,storageSize,ierr); CHKERRQ(ierr) + call DMGetLabelIdIS(dm_local,'Face Sets',faceSetIS,ierr); CHKERRQ(ierr) + call ISGetIndicesF90(faceSetIS,pFaceSets,ierr); CHKERRQ(ierr) + allocate(localIndices (storageSize)) + do faceSet = 1, nFaceSets + call DMGetStratumSize(dm_local,'Face Sets',pFaceSets(faceSet),ISSize,ierr) + CHKERRQ(ierr) + call DMGetStratumIS(dm_local,'Face Sets',pFaceSets(faceSet),BC_IS,ierr) + CHKERRQ(ierr) + if (ISSize > 0) call ISGetIndicesF90(BC_IS,pBCvertex,ierr) + do field = 1, numFields + localSize = 0 + do point = 1, ISSize + call PetscSectionGetFieldDof(section,pBCvertex(point),field-1,nDof,ierr) + CHKERRQ(ierr) + call PetscSectionGetFieldOffset(section,pBCvertex(point),field-1,offset,ierr) + CHKERRQ(ierr) + do dof = 1, nDof + localSize = localSize + 1 + localIndices(localSize) = offset + dof - 1 + enddo + enddo + call ISCreateGeneral(PETSC_COMM_SELF,localSize,localIndices,PETSC_COPY_VALUES, & + localIS(faceSet,field),ierr) + CHKERRQ(ierr) + call ISLocalToGlobalMappingApplyIS(local2global,localIS(faceSet,field), & + globalIS(faceSet,field),ierr) + CHKERRQ(ierr) + enddo + if (ISSize > 0) call ISRestoreIndicesF90(BC_IS,pBCvertex,ierr) + call ISDestroy(BC_IS,ierr); CHKERRQ(ierr) + enddo + call ISRestoreIndicesF90(faceSetIS,pFaceSets,ierr); CHKERRQ(ierr) + call ISDestroy(faceSetIS,ierr); CHKERRQ(ierr) + + do faceSet = 1, nFaceSets; do field = 1, numFields + call ISGetSize(globalIS(faceSet,field),ISSize,ierr); CHKERRQ(ierr) + if (ISSize > 0) then + call ISGetIndicesF90(localIS(faceSet,field),pBCvertexlc,ierr); CHKERRQ(ierr) + call ISGetIndicesF90(globalIS(faceSet,field),pBCvertex,ierr); CHKERRQ(ierr) + endif + localSize = 0 + do point = 1, ISSize + if (pBCvertex(point) >= 0) then + localSize = localSize + 1 + localIndices(localSize) = pBCvertexlc(point) + endif + enddo + if (ISSize > 0) then + call ISRestoreIndicesF90(localIS(faceSet,field),pBCvertexlc,ierr); CHKERRQ(ierr) + call ISRestoreIndicesF90(globalIS(faceSet,field),pBCvertex,ierr); CHKERRQ(ierr) + endif + call ISDestroy(globalIS(faceSet,field),ierr); CHKERRQ(ierr) + call ISCreateGeneral(PETSC_COMM_SELF,localSize,localIndices,PETSC_COPY_VALUES, & + globalIS(faceSet,field),ierr) + CHKERRQ(ierr) + if (ISSize > 0) then + call ISDuplicate(localIS(faceSet,field),dummyIS,ierr); CHKERRQ(ierr) + call ISDestroy(localIS(faceSet,field),ierr); CHKERRQ(ierr) + call ISDifference(dummyIS,globalIS(faceSet,field),localIS(faceSet,field),ierr) + CHKERRQ(ierr) + call ISDestroy(dummyIS,ierr); CHKERRQ(ierr) + endif + enddo; enddo + deallocate(localIndices) + +end subroutine utilities_indexBoundaryDofs + +!-------------------------------------------------------------------------------------------------- +!> @brief Project BC values to local vector +!-------------------------------------------------------------------------------------------------- +subroutine utilities_projectBCValues(localVec,section,field,comp,bcPointsIS,BCValue,BCDotValue,timeinc) + + implicit none + + Vec :: localVec + PetscInt :: field, comp, nBcPoints, point, dof, numDof, numComp, offset + PetscSection :: section + IS :: bcPointsIS + PetscInt, pointer :: bcPoints(:) + PetscScalar, pointer :: localArray(:) + PetscScalar :: BCValue,BCDotValue,timeinc + PetscErrorCode :: ierr + + call PetscSectionGetFieldComponents(section,field,numComp,ierr); CHKERRQ(ierr) + call ISGetSize(bcPointsIS,nBcPoints,ierr); CHKERRQ(ierr) + if (nBcPoints > 0) call ISGetIndicesF90(bcPointsIS,bcPoints,ierr) + call VecGetArrayF90(localVec,localArray,ierr); CHKERRQ(ierr) + do point = 1, nBcPoints + call PetscSectionGetFieldDof(section,bcPoints(point),field,numDof,ierr) + CHKERRQ(ierr) + call PetscSectionGetFieldOffset(section,bcPoints(point),field,offset,ierr) + CHKERRQ(ierr) + do dof = offset+comp+1, offset+numDof, numComp + localArray(dof) = localArray(dof) + BCValue + BCDotValue*timeinc + enddo + enddo + call VecRestoreArrayF90(localVec,localArray,ierr); CHKERRQ(ierr) + call VecAssemblyBegin(localVec, ierr); CHKERRQ(ierr) + call VecAssemblyEnd (localVec, ierr); CHKERRQ(ierr) + if (nBcPoints > 0) call ISRestoreIndicesF90(bcPointsIS,bcPoints,ierr) + +end subroutine utilities_projectBCValues + +!-------------------------------------------------------------------------------------------------- +!> @brief Create index sets of boundary dofs (in local and global numbering) +!-------------------------------------------------------------------------------------------------- +subroutine utilities_indexActiveSet(field,section,x_local,f_local,localIS,globalIS) + use mesh, only: & + geomMesh + + implicit none + + ISLocalToGlobalMapping :: local2global + PetscSection :: section + Vec :: x_local, f_local + PetscInt :: field + IS :: localIS, globalIS, dummyIS + PetscScalar, dimension(:) , pointer :: x_scal, f_scal + PetscInt :: ISSize + PetscInt :: chart, chartStart, chartEnd, nDof, dof, offset + PetscInt :: localSize + PetscInt, dimension(:) , allocatable :: localIndices + PetscInt, dimension(:) , pointer :: pBCvertex, pBCvertexlc + PetscErrorCode :: ierr + + call DMGetLocalToGlobalMapping(geomMesh,local2global,ierr) + CHKERRQ(ierr) + call DMPlexGetChart(geomMesh,chartStart,chartEnd,ierr) + CHKERRQ(ierr) + call VecGetArrayF90(x_local,x_scal,ierr); CHKERRQ(ierr) + call VecGetArrayF90(f_local,f_scal,ierr); CHKERRQ(ierr) + localSize = 0 + do chart = chartStart, chartEnd-1 + call PetscSectionGetFieldDof(section,chart,field-1,nDof,ierr); CHKERRQ(ierr) + call PetscSectionGetFieldOffset(section,chart,field-1,offset,ierr); CHKERRQ(ierr) + do dof = offset+1, offset+nDof + if (((x_scal(dof) < 1.0e-8) .and. (f_scal(dof) > 0.0)) .or. & + ((x_scal(dof) > 1.0 - 1.0e-8) .and. (f_scal(dof) < 0.0))) localSize = localSize + 1 + enddo + enddo + allocate(localIndices(localSize)) + localSize = 0 + do chart = chartStart, chartEnd-1 + call PetscSectionGetFieldDof(section,chart,field-1,nDof,ierr); CHKERRQ(ierr) + call PetscSectionGetFieldOffset(section,chart,field-1,offset,ierr); CHKERRQ(ierr) + do dof = offset+1, offset+nDof + if (((x_scal(dof) < 1.0e-8) .and. (f_scal(dof) > 0.0)) .or. & + ((x_scal(dof) > 1.0 - 1.0e-8) .and. (f_scal(dof) < 0.0))) then + localSize = localSize + 1 + localIndices(localSize) = dof-1 + endif + enddo + enddo + call VecRestoreArrayF90(x_local,x_scal,ierr); CHKERRQ(ierr) + call VecRestoreArrayF90(f_local,f_scal,ierr); CHKERRQ(ierr) + call ISCreateGeneral(PETSC_COMM_SELF,localSize,localIndices,PETSC_COPY_VALUES,localIS,ierr) + CHKERRQ(ierr) + call ISLocalToGlobalMappingApplyIS(local2global,localIS,globalIS,ierr) + CHKERRQ(ierr) + call ISGetSize(globalIS,ISSize,ierr); CHKERRQ(ierr) + if (ISSize > 0) then + call ISGetIndicesF90(localIS,pBCvertexlc,ierr); CHKERRQ(ierr) + call ISGetIndicesF90(globalIS,pBCvertex,ierr); CHKERRQ(ierr) + endif + localSize = 0 + do chart = 1, ISSize + if (pBCvertex(chart) >= 0) then + localSize = localSize + 1 + localIndices(localSize) = pBCvertexlc(chart) + endif + enddo + if (ISSize > 0) then + call ISRestoreIndicesF90(localIS,pBCvertexlc,ierr); CHKERRQ(ierr) + call ISRestoreIndicesF90(globalIS,pBCvertex,ierr); CHKERRQ(ierr) + endif + call ISDestroy(globalIS,ierr); CHKERRQ(ierr) + call ISCreateGeneral(PETSC_COMM_SELF,localSize,localIndices,PETSC_COPY_VALUES,globalIS,ierr) + CHKERRQ(ierr) + if (ISSize > 0) then + call ISDuplicate(localIS,dummyIS,ierr); CHKERRQ(ierr) + call ISDestroy(localIS,ierr); CHKERRQ(ierr) + call ISDifference(dummyIS,globalIS,localIS,ierr) + CHKERRQ(ierr) + call ISDestroy(dummyIS,ierr); CHKERRQ(ierr) + endif + deallocate(localIndices) + +end subroutine utilities_indexActiveSet + +!-------------------------------------------------------------------------------------------------- +!> @brief cleans up +!-------------------------------------------------------------------------------------------------- +subroutine utilities_destroy() + use material, only: & + material_Nhomogenization, & + material_Ncrystallite, & + material_Nphase, & + homogenization_Ngrains + + implicit none + PetscInt :: homog, cryst, grain, phase + PetscErrorCode :: ierr + + call PetscViewerHDF5PopGroup(resUnit, ierr); CHKERRQ(ierr) + call VecDestroy(coordinatesVec,ierr); CHKERRQ(ierr) + do homog = 1, material_Nhomogenization + call VecDestroy(homogenizationResultsVec(homog),ierr);CHKERRQ(ierr) + do cryst = 1, material_Ncrystallite; do grain = 1, homogenization_Ngrains(homog) + call VecDestroy(crystalliteResultsVec(cryst,grain),ierr);CHKERRQ(ierr) + enddo; enddo + do phase = 1, material_Nphase; do grain = 1, homogenization_Ngrains(homog) + call VecDestroy(phaseResultsVec(phase,grain),ierr);CHKERRQ(ierr) + enddo; enddo + enddo + call PetscViewerDestroy(resUnit, ierr); CHKERRQ(ierr) + +end subroutine utilities_destroy + + +end module FEM_utilities diff --git a/src/FEM_zoo.f90 b/src/FEM_zoo.f90 new file mode 100644 index 000000000..2c4250098 --- /dev/null +++ b/src/FEM_zoo.f90 @@ -0,0 +1,356 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Interpolation data used by the FEM solver +!-------------------------------------------------------------------------------------------------- +module FEM_Zoo + use prec, only: pReal, pInt, p_vec + + implicit none +#include + private + integer(pInt), parameter, public:: & + maxOrder = 5 !< current max interpolation set at cubic (intended to be arbitrary) + real(pReal), dimension(2,3), private, protected :: & + triangle = reshape([-1.0_pReal, -1.0_pReal, & + 1.0_pReal, -1.0_pReal, & + -1.0_pReal, 1.0_pReal], shape=[2,3]) + real(pReal), dimension(3,4), private, protected :: & + tetrahedron = reshape([-1.0_pReal, -1.0_pReal, -1.0_pReal, & + 1.0_pReal, -1.0_pReal, -1.0_pReal, & + -1.0_pReal, 1.0_pReal, -1.0_pReal, & + -1.0_pReal, -1.0_pReal, 1.0_pReal], shape=[3,4]) + integer(pInt), dimension(3,maxOrder), public, protected :: & + FEM_Zoo_nQuadrature !< number of quadrature points for a given spatial dimension(1-3) and interpolation order(1-maxOrder) + type(p_vec), dimension(3,maxOrder), public, protected :: & + FEM_Zoo_QuadratureWeights, & !< quadrature weights for each quadrature rule + FEM_Zoo_QuadraturePoints !< quadrature point coordinates (in simplical system) for each quadrature rule + + public :: & + FEM_Zoo_init + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief initializes FEM interpolation data +!-------------------------------------------------------------------------------------------------- +subroutine FEM_Zoo_init + use, intrinsic :: iso_fortran_env + use IO, only: & + IO_timeStamp + use math, only: & + math_binomial + + implicit none + PetscInt :: worldrank + PetscErrorCode :: ierr + external :: & + MPI_Comm_rank, & + MPI_abort + + call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) + if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- FEM_Zoo init -+>>>' + write(6,'(a)') ' $Id: FEM_Zoo.f90 4354 2015-08-04 15:04:53Z MPIE\p.shanthraj $' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif +!-------------------------------------------------------------------------------------------------- +! 2D linear + FEM_Zoo_nQuadrature(2,1) = 1 + allocate(FEM_Zoo_QuadratureWeights(2,1)%p(1)) + allocate(FEM_Zoo_QuadraturePoints (2,1)%p(2)) + FEM_Zoo_QuadratureWeights(2,1)%p(1) = 1.0_pReal + call FEM_Zoo_permutationStar3([1.0_pReal/3.0_pReal], & + FEM_Zoo_QuadraturePoints(2,1)%p(1:2)) + +!-------------------------------------------------------------------------------------------------- +! 2D quadratic + FEM_Zoo_nQuadrature(2,2) = 3 + allocate(FEM_Zoo_QuadratureWeights(2,2)%p(3)) + allocate(FEM_Zoo_QuadraturePoints (2,2)%p(6)) + FEM_Zoo_QuadratureWeights(2,2)%p(1:3) = 1.0_pReal/3.0_pReal + call FEM_Zoo_permutationStar21([1.0_pReal/6.0_pReal], & + FEM_Zoo_QuadraturePoints(2,2)%p(1:6)) + +!-------------------------------------------------------------------------------------------------- +! 2D cubic + FEM_Zoo_nQuadrature(2,3) = 6 + allocate(FEM_Zoo_QuadratureWeights(2,3)%p(6 )) + allocate(FEM_Zoo_QuadraturePoints (2,3)%p(12)) + FEM_Zoo_QuadratureWeights(2,3)%p(1:3) = 0.22338158967801146570_pReal + call FEM_Zoo_permutationStar21([0.44594849091596488632_pReal], & + FEM_Zoo_QuadraturePoints(2,3)%p(1:6)) + FEM_Zoo_QuadratureWeights(2,3)%p(4:6) = 0.10995174365532186764_pReal + call FEM_Zoo_permutationStar21([0.091576213509770743460_pReal], & + FEM_Zoo_QuadraturePoints(2,3)%p(7:12)) + +!-------------------------------------------------------------------------------------------------- +! 2D quartic + FEM_Zoo_nQuadrature(2,4) = 12 + allocate(FEM_Zoo_QuadratureWeights(2,4)%p(12)) + allocate(FEM_Zoo_QuadraturePoints (2,4)%p(24)) + FEM_Zoo_QuadratureWeights(2,4)%p(1:3) = 0.11678627572638_pReal + call FEM_Zoo_permutationStar21([0.24928674517091_pReal], & + FEM_Zoo_QuadraturePoints(2,4)%p(1:6)) + FEM_Zoo_QuadratureWeights(2,4)%p(4:6) = 0.05084490637021_pReal + call FEM_Zoo_permutationStar21([0.06308901449150_pReal], & + FEM_Zoo_QuadraturePoints(2,4)%p(7:12)) + FEM_Zoo_QuadratureWeights(2,4)%p(7:12) = 0.08285107561837_pReal + call FEM_Zoo_permutationStar111([0.31035245103378_pReal, 0.63650249912140_pReal], & + FEM_Zoo_QuadraturePoints(2,4)%p(13:24)) + +!-------------------------------------------------------------------------------------------------- +! 2D order 5 + FEM_Zoo_nQuadrature(2,5) = 16 + allocate(FEM_Zoo_QuadratureWeights(2,5)%p(16)) + allocate(FEM_Zoo_QuadraturePoints (2,5)%p(32)) + FEM_Zoo_QuadratureWeights(2,5)%p(1 ) = 0.14431560767779_pReal + call FEM_Zoo_permutationStar3([0.33333333333333_pReal], & + FEM_Zoo_QuadraturePoints(2,5)%p(1:2)) + FEM_Zoo_QuadratureWeights(2,5)%p(2:4) = 0.09509163426728_pReal + call FEM_Zoo_permutationStar21([0.45929258829272_pReal], & + FEM_Zoo_QuadraturePoints(2,5)%p(3:8)) + FEM_Zoo_QuadratureWeights(2,5)%p(5:7) = 0.10321737053472_pReal + call FEM_Zoo_permutationStar21([0.17056930775176_pReal], & + FEM_Zoo_QuadraturePoints(2,5)%p(9:14)) + FEM_Zoo_QuadratureWeights(2,5)%p(8:10) = 0.03245849762320_pReal + call FEM_Zoo_permutationStar21([0.05054722831703_pReal], & + FEM_Zoo_QuadraturePoints(2,5)%p(15:20)) + FEM_Zoo_QuadratureWeights(2,5)%p(11:16) = 0.02723031417443_pReal + call FEM_Zoo_permutationStar111([0.26311282963464_pReal, 0.72849239295540_pReal], & + FEM_Zoo_QuadraturePoints(2,5)%p(21:32)) + +!-------------------------------------------------------------------------------------------------- +! 3D linear + FEM_Zoo_nQuadrature(3,1) = 1 + allocate(FEM_Zoo_QuadratureWeights(3,1)%p(1)) + allocate(FEM_Zoo_QuadraturePoints (3,1)%p(3)) + FEM_Zoo_QuadratureWeights(3,1)%p(1) = 1.0_pReal + call FEM_Zoo_permutationStar4([0.25_pReal], & + FEM_Zoo_QuadraturePoints(3,1)%p(1:3)) + +!-------------------------------------------------------------------------------------------------- +! 3D quadratic + FEM_Zoo_nQuadrature(3,2) = 4 + allocate(FEM_Zoo_QuadratureWeights(3,2)%p(4 )) + allocate(FEM_Zoo_QuadraturePoints (3,2)%p(12)) + FEM_Zoo_QuadratureWeights(3,2)%p(1:4) = 0.25_pReal + call FEM_Zoo_permutationStar31([0.13819660112501051518_pReal], & + FEM_Zoo_QuadraturePoints(3,2)%p(1:12)) + +!-------------------------------------------------------------------------------------------------- +! 3D cubic + FEM_Zoo_nQuadrature(3,3) = 14 + allocate(FEM_Zoo_QuadratureWeights(3,3)%p(14)) + allocate(FEM_Zoo_QuadraturePoints (3,3)%p(42)) + FEM_Zoo_QuadratureWeights(3,3)%p(1:4) = 0.073493043116361949544_pReal + call FEM_Zoo_permutationStar31([0.092735250310891226402_pReal], & + FEM_Zoo_QuadraturePoints(3,3)%p(1:12)) + FEM_Zoo_QuadratureWeights(3,3)%p(5:8) = 0.11268792571801585080_pReal + call FEM_Zoo_permutationStar31([0.31088591926330060980_pReal], & + FEM_Zoo_QuadraturePoints(3,3)%p(13:24)) + FEM_Zoo_QuadratureWeights(3,3)%p(9:14) = 0.042546020777081466438_pReal + call FEM_Zoo_permutationStar22([0.045503704125649649492_pReal], & + FEM_Zoo_QuadraturePoints(3,3)%p(25:42)) + +!-------------------------------------------------------------------------------------------------- +! 3D quartic + FEM_Zoo_nQuadrature(3,4) = 35 + allocate(FEM_Zoo_QuadratureWeights(3,4)%p(35)) + allocate(FEM_Zoo_QuadraturePoints (3,4)%p(105)) + FEM_Zoo_QuadratureWeights(3,4)%p(1:4) = 0.0021900463965388_pReal + call FEM_Zoo_permutationStar31([0.0267367755543735_pReal], & + FEM_Zoo_QuadraturePoints(3,4)%p(1:12)) + FEM_Zoo_QuadratureWeights(3,4)%p(5:16) = 0.0143395670177665_pReal + call FEM_Zoo_permutationStar211([0.0391022406356488_pReal, 0.7477598884818090_pReal], & + FEM_Zoo_QuadraturePoints(3,4)%p(13:48)) + FEM_Zoo_QuadratureWeights(3,4)%p(17:22) = 0.0250305395686746_pReal + call FEM_Zoo_permutationStar22([0.4547545999844830_pReal], & + FEM_Zoo_QuadraturePoints(3,4)%p(49:66)) + FEM_Zoo_QuadratureWeights(3,4)%p(23:34) = 0.0479839333057554_pReal + call FEM_Zoo_permutationStar211([0.2232010379623150_pReal, 0.0504792790607720_pReal], & + FEM_Zoo_QuadraturePoints(3,4)%p(67:102)) + FEM_Zoo_QuadratureWeights(3,4)%p(35) = 0.0931745731195340_pReal + call FEM_Zoo_permutationStar4([0.25_pReal], & + FEM_Zoo_QuadraturePoints(3,4)%p(103:105)) +!-------------------------------------------------------------------------------------------------- +! 3D quintic + FEM_Zoo_nQuadrature(3,5) = 56 + allocate(FEM_Zoo_QuadratureWeights(3,5)%p(56)) + allocate(FEM_Zoo_QuadraturePoints (3,5)%p(168)) + FEM_Zoo_QuadratureWeights(3,5)%p(1:4) = 0.0010373112336140_pReal + call FEM_Zoo_permutationStar31([0.0149520651530592_pReal], & + FEM_Zoo_QuadraturePoints(3,5)%p(1:12)) + FEM_Zoo_QuadratureWeights(3,5)%p(5:16) = 0.0096016645399480_pReal + call FEM_Zoo_permutationStar211([0.0340960211962615_pReal, 0.1518319491659370_pReal], & + FEM_Zoo_QuadraturePoints(3,5)%p(13:48)) + FEM_Zoo_QuadratureWeights(3,5)%p(17:28) = 0.0164493976798232_pReal + call FEM_Zoo_permutationStar211([0.0462051504150017_pReal, 0.3549340560639790_pReal], & + FEM_Zoo_QuadraturePoints(3,5)%p(49:84)) + FEM_Zoo_QuadratureWeights(3,5)%p(29:40) = 0.0153747766513310_pReal + call FEM_Zoo_permutationStar211([0.2281904610687610_pReal, 0.0055147549744775_pReal], & + FEM_Zoo_QuadraturePoints(3,5)%p(85:120)) + FEM_Zoo_QuadratureWeights(3,5)%p(41:52) = 0.0293520118375230_pReal + call FEM_Zoo_permutationStar211([0.3523052600879940_pReal, 0.0992057202494530_pReal], & + FEM_Zoo_QuadraturePoints(3,5)%p(121:156)) + FEM_Zoo_QuadratureWeights(3,5)%p(53:56) = 0.0366291366405108_pReal + call FEM_Zoo_permutationStar31([0.1344783347929940_pReal], & + FEM_Zoo_QuadraturePoints(3,5)%p(157:168)) + +end subroutine FEM_Zoo_init + +!-------------------------------------------------------------------------------------------------- +!> @brief star 3 permutation of input +!-------------------------------------------------------------------------------------------------- +subroutine FEM_Zoo_permutationStar3(point,qPt) + + implicit none + real(pReal) :: point(1), qPt(2,1), temp(3,1) + + temp(:,1) = [point(1), point(1), point(1)] + qPt = matmul(triangle, temp) + +end subroutine FEM_Zoo_permutationStar3 + +!-------------------------------------------------------------------------------------------------- +!> @brief star 21 permutation of input +!-------------------------------------------------------------------------------------------------- +subroutine FEM_Zoo_permutationStar21(point,qPt) + + implicit none + real(pReal) :: point(1), qPt(2,3), temp(3,3) + + temp(:,1) = [point(1), point(1), 1.0_pReal - 2.0_pReal*point(1)] + temp(:,2) = [point(1), 1.0_pReal - 2.0_pReal*point(1), point(1)] + temp(:,3) = [1.0_pReal - 2.0_pReal*point(1), point(1), point(1)] + qPt = matmul(triangle, temp) + +end subroutine FEM_Zoo_permutationStar21 + +!-------------------------------------------------------------------------------------------------- +!> @brief star 111 permutation of input +!-------------------------------------------------------------------------------------------------- +subroutine FEM_Zoo_permutationStar111(point,qPt) + + implicit none + real(pReal) :: point(2), qPt(2,6), temp(3,6) + + temp(:,1) = [point(1), point(2), 1.0_pReal - point(1) - point(2)] + temp(:,2) = [point(1), 1.0_pReal - point(1) - point(2), point(2)] + temp(:,4) = [point(2), 1.0_pReal - point(1) - point(2), point(1)] + temp(:,5) = [1.0_pReal - point(1) - point(2), point(2), point(1)] + temp(:,6) = [1.0_pReal - point(1) - point(2), point(1), point(2)] + qPt = matmul(triangle, temp) + +end subroutine FEM_Zoo_permutationStar111 + +!-------------------------------------------------------------------------------------------------- +!> @brief star 4 permutation of input +!-------------------------------------------------------------------------------------------------- +subroutine FEM_Zoo_permutationStar4(point,qPt) + + implicit none + real(pReal) :: point(1), qPt(3,1), temp(4,1) + + temp(:,1) = [point(1), point(1), point(1), point(1)] + qPt = matmul(tetrahedron, temp) + +end subroutine FEM_Zoo_permutationStar4 + +!-------------------------------------------------------------------------------------------------- +!> @brief star 31 permutation of input +!-------------------------------------------------------------------------------------------------- +subroutine FEM_Zoo_permutationStar31(point,qPt) + + implicit none + real(pReal) :: point(1), qPt(3,4), temp(4,4) + + temp(:,1) = [point(1), point(1), point(1), 1.0_pReal - 3.0_pReal*point(1)] + temp(:,2) = [point(1), point(1), 1.0_pReal - 3.0_pReal*point(1), point(1)] + temp(:,3) = [point(1), 1.0_pReal - 3.0_pReal*point(1), point(1), point(1)] + temp(:,4) = [1.0_pReal - 3.0_pReal*point(1), point(1), point(1), point(1)] + qPt = matmul(tetrahedron, temp) + +end subroutine FEM_Zoo_permutationStar31 + +!-------------------------------------------------------------------------------------------------- +!> @brief star 22 permutation of input +!-------------------------------------------------------------------------------------------------- +subroutine FEM_Zoo_permutationStar22(point,qPt) + + implicit none + real(pReal) :: point(1), qPt(3,6), temp(4,6) + + temp(:,1) = [point(1), point(1), 0.5_pReal - point(1), 0.5_pReal - point(1)] + temp(:,2) = [point(1), 0.5_pReal - point(1), point(1), 0.5_pReal - point(1)] + temp(:,3) = [0.5_pReal - point(1), point(1), point(1), 0.5_pReal - point(1)] + temp(:,4) = [0.5_pReal - point(1), point(1), 0.5_pReal - point(1), point(1)] + temp(:,5) = [0.5_pReal - point(1), 0.5_pReal - point(1), point(1), point(1)] + temp(:,6) = [point(1), 0.5_pReal - point(1), 0.5_pReal - point(1), point(1)] + qPt = matmul(tetrahedron, temp) + +end subroutine FEM_Zoo_permutationStar22 + +!-------------------------------------------------------------------------------------------------- +!> @brief star 211 permutation of input +!-------------------------------------------------------------------------------------------------- +subroutine FEM_Zoo_permutationStar211(point,qPt) + + implicit none + real(pReal) :: point(2), qPt(3,12), temp(4,12) + + temp(:,1 ) = [point(1), point(1), point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2)] + temp(:,2 ) = [point(1), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2)] + temp(:,3 ) = [point(1), point(2), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2)] + temp(:,4 ) = [point(1), point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1)] + temp(:,5 ) = [point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(2)] + temp(:,6 ) = [point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1)] + temp(:,7 ) = [point(2), point(1), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2)] + temp(:,8 ) = [point(2), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1)] + temp(:,9 ) = [point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(1)] + temp(:,10) = [1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(1), point(2)] + temp(:,11) = [1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(2), point(1)] + temp(:,12) = [1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1), point(1)] + qPt = matmul(tetrahedron, temp) + +end subroutine FEM_Zoo_permutationStar211 + +!-------------------------------------------------------------------------------------------------- +!> @brief star 1111 permutation of input +!-------------------------------------------------------------------------------------------------- +subroutine FEM_Zoo_permutationStar1111(point,qPt) + + implicit none + real(pReal) :: point(3), qPt(3,24), temp(4,24) + + temp(:,1 ) = [point(1), point(2), point(3), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,2 ) = [point(1), point(2), 1.0_pReal - point(1) - point(2)- point(3), point(3)] + temp(:,3 ) = [point(1), point(3), point(2), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,4 ) = [point(1), point(3), 1.0_pReal - point(1) - point(2)- point(3), point(2)] + temp(:,5 ) = [point(1), 1.0_pReal - point(1) - point(2)- point(3), point(2), point(3)] + temp(:,6 ) = [point(1), 1.0_pReal - point(1) - point(2)- point(3), point(3), point(2)] + temp(:,7 ) = [point(2), point(1), point(3), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,8 ) = [point(2), point(1), 1.0_pReal - point(1) - point(2)- point(3), point(3)] + temp(:,9 ) = [point(2), point(3), point(1), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,10) = [point(2), point(3), 1.0_pReal - point(1) - point(2)- point(3), point(1)] + temp(:,11) = [point(2), 1.0_pReal - point(1) - point(2)- point(3), point(1), point(3)] + temp(:,12) = [point(2), 1.0_pReal - point(1) - point(2)- point(3), point(3), point(1)] + temp(:,13) = [point(3), point(1), point(2), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,14) = [point(3), point(1), 1.0_pReal - point(1) - point(2)- point(3), point(2)] + temp(:,15) = [point(3), point(2), point(1), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,16) = [point(3), point(2), 1.0_pReal - point(1) - point(2)- point(3), point(1)] + temp(:,17) = [point(3), 1.0_pReal - point(1) - point(2)- point(3), point(1), point(2)] + temp(:,18) = [point(3), 1.0_pReal - point(1) - point(2)- point(3), point(2), point(1)] + temp(:,19) = [1.0_pReal - point(1) - point(2)- point(3), point(1), point(2), point(3)] + temp(:,20) = [1.0_pReal - point(1) - point(2)- point(3), point(1), point(3), point(2)] + temp(:,21) = [1.0_pReal - point(1) - point(2)- point(3), point(2), point(1), point(3)] + temp(:,22) = [1.0_pReal - point(1) - point(2)- point(3), point(2), point(3), point(1)] + temp(:,23) = [1.0_pReal - point(1) - point(2)- point(3), point(3), point(1), point(2)] + temp(:,24) = [1.0_pReal - point(1) - point(2)- point(3), point(3), point(2), point(1)] + qPt = matmul(tetrahedron, temp) + +end subroutine FEM_Zoo_permutationStar1111 + + +end module FEM_Zoo