diff --git a/code/constitutive_dislotwin.f90 b/code/constitutive_dislotwin.f90 index 8f07ea0d1..0d85941e7 100644 --- a/code/constitutive_dislotwin.f90 +++ b/code/constitutive_dislotwin.f90 @@ -186,8 +186,8 @@ constitutive_dislotwin_Nslip = 0_pInt constitutive_dislotwin_Ntwin = 0_pInt constitutive_dislotwin_slipFamily = 0_pInt constitutive_dislotwin_twinFamily = 0_pInt -constitutive_dislotwin_slipSystemLattice = 0.0_pReal -constitutive_dislotwin_twinSystemLattice = 0.0_pReal +constitutive_dislotwin_slipSystemLattice = 0_pInt +constitutive_dislotwin_twinSystemLattice = 0_pInt constitutive_dislotwin_totalNslip = 0_pInt constitutive_dislotwin_totalNtwin = 0_pInt allocate(constitutive_dislotwin_CoverA(maxNinstance)) @@ -959,23 +959,23 @@ real(pReal), dimension(3,3) :: eigVectors, sb_Smatrix real(pReal), dimension(3) :: eigValues, sb_s, sb_m real(pReal), dimension(3,6), parameter :: & sb_sComposition = & - reshape((/& + reshape(real([& 1, 0, 1, & 1, 0,-1, & 1, 1, 0, & 1,-1, 0, & 0, 1, 1, & 0, 1,-1 & - /),(/3,6/)), & + ],pReal),[ 3,6]), & sb_mComposition = & - reshape((/& + reshape(real([& 1, 0,-1, & 1, 0,+1, & 1,-1, 0, & 1, 1, 0, & 0, 1,-1, & 0, 1, 1 & - /),(/3,6/)) + ],pReal),[ 3,6]) logical error !* Shortened notation diff --git a/code/constitutive_titanmod.f90 b/code/constitutive_titanmod.f90 index ef1226940..fff006ae3 100644 --- a/code/constitutive_titanmod.f90 +++ b/code/constitutive_titanmod.f90 @@ -58,7 +58,7 @@ character(len=18), dimension(3), parameter:: constitutive_titanmod_listBasicSlip character(len=18), dimension(1), parameter:: constitutive_titanmod_listBasicTwinStates = (/'gdot_twin'/) -character(len=18), dimension(11), parameter:: constitutive_titanmod_listDependentSlipStates =(/'segment_edge ', & +character(len=19), dimension(11), parameter:: constitutive_titanmod_listDependentSlipStates =(/'segment_edge ', & 'segment_screw ', & 'resistance_edge ', & 'resistance_screw ', & @@ -254,8 +254,8 @@ constitutive_titanmod_Nslip = 0_pInt constitutive_titanmod_Ntwin = 0_pInt constitutive_titanmod_slipFamily = 0_pInt constitutive_titanmod_twinFamily = 0_pInt -constitutive_titanmod_slipSystemLattice = 0.0_pReal -constitutive_titanmod_twinSystemLattice = 0.0_pReal +constitutive_titanmod_slipSystemLattice = 0_pInt +constitutive_titanmod_twinSystemLattice = 0_pInt constitutive_titanmod_totalNslip = 0_pInt constitutive_titanmod_totalNtwin = 0_pInt allocate(constitutive_titanmod_CoverA(maxNinstance)) diff --git a/code/homogenization_RGC.f90 b/code/homogenization_RGC.f90 index 58c5b0ac0..aa3957d7f 100644 --- a/code/homogenization_RGC.f90 +++ b/code/homogenization_RGC.f90 @@ -941,8 +941,8 @@ subroutine homogenization_RGC_stressPenalty(& integer(pInt) homID,iGrain,iGNghb,iFace,i,j,k,l real(pReal) muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb ! - integer(pInt), parameter :: nFace = 6 - real(pReal), parameter :: nDefToler = 1.0e-10 + integer(pInt), parameter :: nFace = 6_pInt + real(pReal), parameter :: nDefToler = 1.0e-10_pReal nGDim = homogenization_RGC_Ngrains(:,homID) diff --git a/code/homogenization_isostrain.f90 b/code/homogenization_isostrain.f90 index edf389dd7..5512fce13 100644 --- a/code/homogenization_isostrain.f90 +++ b/code/homogenization_isostrain.f90 @@ -61,7 +61,7 @@ CONTAINS subroutine homogenization_isostrain_init(& file & ! file pointer to material configuration ) - + use, intrinsic :: iso_fortran_env use prec, only: pInt, pReal use math, only: math_Mandel3333to66, math_Voigt66to3333 use IO @@ -328,7 +328,7 @@ pure function homogenization_isostrain_postResults(& do o = 1,homogenization_Noutput(mesh_element(3,el)) select case(homogenization_isostrain_output(o,homID)) case ('ngrains') - homogenization_isostrain_postResults(c+1) = homogenization_isostrain_Ngrains(homID) + homogenization_isostrain_postResults(c+1) = real(homogenization_isostrain_Ngrains(homID),pReal) c = c + 1 end select enddo diff --git a/code/lattice.f90 b/code/lattice.f90 index dd2421c55..9945c9398 100644 --- a/code/lattice.f90 +++ b/code/lattice.f90 @@ -88,7 +88,7 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & integer(pInt) :: lattice_fcc_Nstructure = 0_pInt real(pReal), dimension(3+3,lattice_fcc_Nslip), parameter :: lattice_fcc_systemSlip = & - reshape((/& + reshape(real([& ! Slip system <110>{111} Sorted according to Eisenlohr & Hantcherli 0, 1,-1, 1, 1, 1, & -1, 0, 1, 1, 1, 1, & @@ -102,10 +102,10 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 0, 1, 1, -1, 1,-1, & 1, 0,-1, -1, 1,-1, & -1,-1, 0, -1, 1,-1 & - /),(/3+3,lattice_fcc_Nslip/)) + ],pReal),[ 3_pInt + 3_pInt,lattice_fcc_Nslip]) real(pReal), dimension(3+3,lattice_fcc_Ntwin), parameter :: lattice_fcc_systemTwin = & - reshape((/& + reshape(real( [& ! Twin system <112>{111} Sorted according to Eisenlohr & Hantcherli -2, 1, 1, 1, 1, 1, & 1,-2, 1, 1, 1, 1, & @@ -119,27 +119,27 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 2, 1,-1, -1, 1,-1, & -1,-2,-1, -1, 1,-1, & -1, 1, 2, -1, 1,-1 & - /),(/3+3,lattice_fcc_Ntwin/)) + ],pReal),[ 3_pInt + 3_pInt ,lattice_fcc_Ntwin]) real(pReal), dimension(lattice_fcc_Ntwin), parameter :: lattice_fcc_shearTwin = & - reshape((/& + reshape([& ! Twin system <112>{111} Sorted according to Eisenlohr & Hantcherli - 0.7071067812, & - 0.7071067812, & - 0.7071067812, & - 0.7071067812, & - 0.7071067812, & - 0.7071067812, & - 0.7071067812, & - 0.7071067812, & - 0.7071067812, & - 0.7071067812, & - 0.7071067812, & - 0.7071067812 & - /),(/lattice_fcc_Ntwin/)) + 0.7071067812_pReal, & + 0.7071067812_pReal, & + 0.7071067812_pReal, & + 0.7071067812_pReal, & + 0.7071067812_pReal, & + 0.7071067812_pReal, & + 0.7071067812_pReal, & + 0.7071067812_pReal, & + 0.7071067812_pReal, & + 0.7071067812_pReal, & + 0.7071067812_pReal, & + 0.7071067812_pReal & + ],[lattice_fcc_Ntwin]) integer(pInt), target, dimension(lattice_fcc_Nslip,lattice_fcc_Nslip) :: lattice_fcc_interactionSlipSlip = & - reshape((/& + reshape(int( [& ! Interaction types ! 1 --- self interaction ! 2 --- coplanar interaction @@ -159,10 +159,10 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 4,5,6,3,5,5,4,6,5,1,2,2, & 5,3,5,5,4,6,6,4,5,2,1,2, & 6,5,4,5,6,4,5,5,3,2,2,1 & - /),(/lattice_fcc_Nslip,lattice_fcc_Nslip/)) + ],pInt),[lattice_fcc_Nslip,lattice_fcc_Nslip]) integer(pInt), target, dimension(lattice_fcc_Ntwin,lattice_fcc_Nslip) :: lattice_fcc_interactionSlipTwin = & - reshape((/& + reshape(int( [& 1,1,1,2,2,1,1,2,2,2,1,2, & 1,1,1,2,2,1,1,2,2,2,1,2, & 1,1,1,2,2,1,1,2,2,2,1,2, & @@ -175,12 +175,12 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 2,1,2,1,2,2,2,2,1,1,1,1, & 2,1,2,1,2,2,2,2,1,1,1,1, & 2,1,2,1,2,2,2,2,1,1,1,1 & - /),(/lattice_fcc_Ntwin,lattice_fcc_Nslip/)) + ],pInt),[lattice_fcc_Ntwin,lattice_fcc_Nslip]) - integer(pInt), target, dimension(lattice_fcc_Nslip,lattice_fcc_Ntwin) :: lattice_fcc_interactionTwinSlip = 0 + integer(pInt), target, dimension(lattice_fcc_Nslip,lattice_fcc_Ntwin) :: lattice_fcc_interactionTwinSlip = 0_pInt integer(pInt), target, dimension(lattice_fcc_Ntwin,lattice_fcc_Ntwin) :: lattice_fcc_interactionTwinTwin = & - reshape((/& + reshape(int( [& 1,1,1,2,2,2,2,2,2,2,2,2, & 1,1,1,2,2,2,2,2,2,2,2,2, & 1,1,1,2,2,2,2,2,2,2,2,2, & @@ -193,19 +193,19 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 2,2,2,2,2,2,2,2,2,1,1,1, & 2,2,2,2,2,2,2,2,2,1,1,1, & 2,2,2,2,2,2,2,2,2,1,1,1 & - /),(/lattice_fcc_Ntwin,lattice_fcc_Ntwin/)) + ],pInt),[lattice_fcc_Ntwin,lattice_fcc_Ntwin]) !============================== bcc (2) ================================= - integer(pInt), parameter, dimension(lattice_maxNslipFamily) :: lattice_bcc_NslipSystem = (/12,12,24, 0, 0/) - integer(pInt), parameter, dimension(lattice_maxNtwinFamily) :: lattice_bcc_NtwinSystem = (/12, 0, 0, 0/) - integer(pInt), parameter :: lattice_bcc_Nslip = 48 ! sum(lattice_bcc_NslipSystem) - integer(pInt), parameter :: lattice_bcc_Ntwin = 12 ! sum(lattice_bcc_NtwinSystem) + integer(pInt), parameter, dimension(lattice_maxNslipFamily) :: lattice_bcc_NslipSystem = int([ 12,12,24, 0, 0], pInt) + integer(pInt), parameter, dimension(lattice_maxNtwinFamily) :: lattice_bcc_NtwinSystem = int([ 12, 0, 0, 0], pInt) + integer(pInt), parameter :: lattice_bcc_Nslip = 48_pInt ! sum(lattice_bcc_NslipSystem) + integer(pInt), parameter :: lattice_bcc_Ntwin = 12_pInt ! sum(lattice_bcc_NtwinSystem) integer(pInt) :: lattice_bcc_Nstructure = 0_pInt real(pReal), dimension(3+3,lattice_bcc_Nslip), parameter :: lattice_bcc_systemSlip = & - reshape((/& + reshape(real([& ! Slip system <111>{110} meaningful sorting? 1,-1, 1, 0, 1, 1, & -1,-1, 1, 0, 1, 1, & @@ -257,12 +257,12 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 1, 1, 1, -3, 2, 1, & 1, 1,-1, 3,-2, 1, & 1,-1, 1, 3, 2,-1 & - /),(/3+3,lattice_bcc_Nslip/)) + ],pReal),[ 3_pInt + 3_pInt ,lattice_bcc_Nslip]) ! twin system <111>{112} ! MISSING: not implemented yet -- now dummy copy from fcc !! real(pReal), dimension(3+3,lattice_bcc_Ntwin), parameter :: lattice_bcc_systemTwin = & - reshape((/& + reshape(real([& ! Twin system <112>{111} Sorted according to Eisenlohr & Hantcherli -2, 1, 1, 1, 1, 1, & 1,-2, 1, 1, 1, 1, & @@ -276,28 +276,28 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 2, 1,-1, -1, 1,-1, & -1,-2,-1, -1, 1,-1, & -1, 1, 2, -1, 1,-1 & - /),(/3+3,lattice_bcc_Ntwin/)) + ],pReal),[ 3_pInt + 3_pInt,lattice_bcc_Ntwin]) real(pReal), dimension(lattice_bcc_Ntwin), parameter :: lattice_bcc_shearTwin = & - reshape((/& + reshape([& ! Twin system {111}<112> just a dummy - 0.123, & - 0.123, & - 0.123, & - 0.123, & - 0.123, & - 0.123, & - 0.123, & - 0.123, & - 0.123, & - 0.123, & - 0.123, & - 0.123 & - /),(/lattice_bcc_Ntwin/)) + 0.123_pReal, & + 0.123_pReal, & + 0.123_pReal, & + 0.123_pReal, & + 0.123_pReal, & + 0.123_pReal, & + 0.123_pReal, & + 0.123_pReal, & + 0.123_pReal, & + 0.123_pReal, & + 0.123_pReal, & + 0.123_pReal & + ],[lattice_bcc_Ntwin]) !*** slip--slip interactions for BCC structures (2) *** integer(pInt), target, dimension(lattice_bcc_Nslip,lattice_bcc_Nslip) :: lattice_bcc_interactionSlipSlip = & - reshape((/& + reshape(int( [& 1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, & 2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, & 2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, & @@ -346,12 +346,12 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2, & 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2, & 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1 & - /),(/lattice_bcc_Nslip,lattice_bcc_Nslip/)) + ],pInt),[lattice_bcc_Nslip,lattice_bcc_Nslip]) !*** slip--twin interactions for BCC structures (2) *** ! MISSING: not implemented yet integer(pInt), target, dimension(lattice_bcc_Ntwin,lattice_bcc_Nslip) :: lattice_bcc_interactionSlipTwin = & - reshape((/& + reshape(int( [& 0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0, & @@ -400,13 +400,13 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0 & - /),(/lattice_bcc_Ntwin,lattice_bcc_Nslip/)) + ],pInt),[lattice_bcc_Ntwin,lattice_bcc_Nslip]) !*** twin--slip interactions for BCC structures (2) *** ! MISSING: not implemented yet integer(pInt), target, dimension(lattice_bcc_Nslip,lattice_bcc_Ntwin) :: lattice_bcc_interactionTwinSlip = & - reshape((/& + reshape(int( [& 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & @@ -419,12 +419,12 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 & - /),(/lattice_bcc_Nslip,lattice_bcc_Ntwin/)) + ],pInt),[lattice_bcc_Nslip,lattice_bcc_Ntwin]) !*** twin-twin interactions for BCC structures (2) *** ! MISSING: not implemented yet integer(pInt), target, dimension(lattice_bcc_Ntwin,lattice_bcc_Ntwin) :: lattice_bcc_interactionTwinTwin = & - reshape((/& + reshape(int( [& 0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0, & @@ -437,7 +437,7 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0, & 0,0,0,0,0,0,0,0,0,0,0,0 & - /),(/lattice_bcc_Ntwin,lattice_bcc_Ntwin/)) + ],pInt),[lattice_bcc_Ntwin,lattice_bcc_Ntwin]) !============================== hex (3+) ================================= @@ -450,7 +450,7 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & !* sorted by A. Alankar & P. Eisenlohr real(pReal), dimension(4+4,lattice_hex_Nslip), parameter :: lattice_hex_systemSlip = & - reshape((/& + reshape(real([& ! Basal systems <1120>{0001} (independent of c/a-ratio, Bravais notation (4 coordinate base)) 2, -1, -1, 0, 0, 0, 0, 1, & -1, 2, -1, 0, 0, 0, 0, 1, & @@ -486,10 +486,10 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & -2, 1, 1, -3, -2, 1, 1, 2, & -1, -1, 2, -3, -1, -1, 2, 2, & 1, -2, 1, -3, 1, -2, 1, 2 & - /),(/4+4,lattice_hex_Nslip/)) + ],pReal),[ 4_pInt + 4_pInt,lattice_hex_Nslip]) real(pReal), dimension(4+4,lattice_hex_Ntwin), parameter :: lattice_hex_systemTwin = & - reshape((/& + reshape(real([& 0, 1, -1, 1, 0, -1, 1, 2, & ! <-10.1>{10.2} shear = (3-(c/a)^2)/(sqrt(3) c/a) -1, 1, 0, 1, 1, -1, 0, 2, & -1, 0, 1, 1, 1, 0, -1, 2, & !! @@ -514,10 +514,10 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 0, -1, 1, -2, 0, -1, 1, 1, & 1, -1, 0, -2, 1, -1, 0, 1, & -1, 1, 0, -2, -1, 1, 0, 1 & - /),(/4+4,lattice_hex_Ntwin/)) !* Sort? Numbering of twin system follows Prof. Tom Bieler's scheme (to be consistent with his work); but numbering in data was restarted from 1 & + ],pReal),[ 4_pInt + 4_pInt ,lattice_hex_Ntwin]) !* Sort? Numbering of twin system follows Prof. Tom Bieler's scheme (to be consistent with his work); but numbering in data was restarted from 1 & integer(pInt), dimension(lattice_hex_Ntwin), parameter :: lattice_hex_shearTwin = & ! indicator to formula further below - reshape((/& + reshape(int( [& 1, & ! {10.2}<-10.1> 1, & 1, & @@ -542,7 +542,7 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 4, & 4, & 4 & - /),(/lattice_hex_Ntwin/)) + ],pInt),[lattice_hex_Ntwin]) !* four different interaction type matrix !* 1. slip-slip interaction - 30 types @@ -551,7 +551,7 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & !* 4. twin-slip interaction - 16 types integer(pInt), target, dimension(lattice_hex_Nslip,lattice_hex_Nslip) :: lattice_hex_interactionSlipSlip = & - reshape((/& + reshape(int( [& 1, 6, 6, 11,11,11, 15,15,15,15,15,15, 18,18,18,18,18,18,18,18,18,18,18,18, 20,20,20,20,20,20, & 6, 1, 6, 11,11,11, 15,15,15,15,15,15, 18,18,18,18,18,18,18,18,18,18,18,18, 20,20,20,20,20,20, & 6, 6, 1, 11,11,11, 15,15,15,15,15,15, 18,18,18,18,18,18,18,18,18,18,18,18, 20,20,20,20,20,20, & @@ -586,11 +586,11 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 30,30,30, 29,29,29, 27,27,27,27,27,27, 24,24,24,24,24,24,24,24,24,24,24,24, 10,10,10, 5,10,10, & 30,30,30, 29,29,29, 27,27,27,27,27,27, 24,24,24,24,24,24,24,24,24,24,24,24, 10,10,10,10, 5,10, & 30,30,30, 29,29,29, 27,27,27,27,27,27, 24,24,24,24,24,24,24,24,24,24,24,24, 10,10,10,10,10, 5 & - /),(/lattice_hex_Nslip,lattice_hex_Nslip/)) + ],pInt),[lattice_hex_Nslip,lattice_hex_Nslip]) !* isotropic interaction at the moment integer(pInt), target, dimension(lattice_hex_Ntwin,lattice_hex_Nslip) :: lattice_hex_interactionSlipTwin = & - reshape((/& + reshape(int( [& 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! --> twin 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | @@ -625,11 +625,11 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20 & - /),(/lattice_hex_Ntwin,lattice_hex_Nslip/)) + ],pInt),[lattice_hex_Ntwin,lattice_hex_Nslip]) !* isotropic interaction at the moment integer(pInt), target, dimension(lattice_hex_Nslip,lattice_hex_Ntwin) :: lattice_hex_interactionTwinSlip = & - reshape((/& + reshape(int( [& 1, 1, 1, 5, 5, 5, 9, 9, 9, 9, 9, 9, 13,13,13,13,13,13,13,13,13,13,13,13, 17,17,17,17,17,17, & ! --> slip 1, 1, 1, 5, 5, 5, 9, 9, 9, 9, 9, 9, 13,13,13,13,13,13,13,13,13,13,13,13, 17,17,17,17,17,17, & ! | 1, 1, 1, 5, 5, 5, 9, 9, 9, 9, 9, 9, 13,13,13,13,13,13,13,13,13,13,13,13, 17,17,17,17,17,17, & ! | @@ -657,11 +657,11 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 4, 4, 4, 8, 8, 8, 12,12,12,12,12,12, 16,16,16,16,16,16,16,16,16,16,16,16, 20,20,20,20,20,20, & 4, 4, 4, 8, 8, 8, 12,12,12,12,12,12, 16,16,16,16,16,16,16,16,16,16,16,16, 20,20,20,20,20,20, & 4, 4, 4, 8, 8, 8, 12,12,12,12,12,12, 16,16,16,16,16,16,16,16,16,16,16,16, 20,20,20,20,20,20 & - /),(/lattice_hex_Nslip,lattice_hex_Ntwin/)) + ],pInt),[lattice_hex_Nslip,lattice_hex_Ntwin]) integer(pInt), target, dimension(lattice_hex_Ntwin,lattice_hex_Ntwin) :: lattice_hex_interactionTwinTwin = & - reshape((/& + reshape(int( [& 1, 5, 5, 5, 5, 5, 9, 9, 9, 9, 9, 9, 12,12,12,12,12,12, 14,14,14,14,14,14, & 5, 1, 5, 5, 5, 5, 9, 9, 9, 9, 9, 9, 12,12,12,12,12,12, 14,14,14,14,14,14, & 5, 5, 1, 5, 5, 5, 9, 9, 9, 9, 9, 9, 12,12,12,12,12,12, 14,14,14,14,14,14, & @@ -689,7 +689,7 @@ integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip, & 20,20,20,20,20,20, 19,19,19,19,19,19, 17,17,17,17,17,17, 8, 8, 8, 4, 8, 8, & 20,20,20,20,20,20, 19,19,19,19,19,19, 17,17,17,17,17,17, 8, 8, 8, 8, 4, 8, & 20,20,20,20,20,20, 19,19,19,19,19,19, 17,17,17,17,17,17, 8, 8, 8, 8, 8, 4 & - /),(/lattice_hex_Ntwin,lattice_hex_Ntwin/)) + ],pInt),[lattice_hex_Ntwin,lattice_hex_Ntwin]) CONTAINS @@ -710,9 +710,9 @@ pure function lattice_symmetryType(structID) integer(pInt) lattice_symmetryType select case(structID) - case (1,2) + case (1_pInt,2_pInt) lattice_symmetryType = 1_pInt - case (3:) + case (3_pInt:) lattice_symmetryType = 2_pInt case default lattice_symmetryType = 0_pInt @@ -727,6 +727,7 @@ subroutine lattice_init() !************************************** !* Module initialization * !************************************** + use, intrinsic :: iso_fortran_env use IO, only: IO_open_file,IO_open_jobFile,IO_countSections,IO_countTagInPart,IO_error use material, only: material_configfile,material_localFileExt,material_partPhase use debug, only: debug_verbosity @@ -742,15 +743,15 @@ subroutine lattice_init() #include "compilation_info.f90" !$OMP END CRITICAL (write2out) - if (.not. IO_open_jobFile(fileunit,material_localFileExt)) then ! no local material configuration present... - if (.not. IO_open_file(fileunit,material_configFile)) call IO_error(100) ! ...and cannot open material.config file + if (.not. IO_open_jobFile(fileunit,material_localFileExt)) then ! no local material configuration present... + if (.not. IO_open_file(fileunit,material_configFile)) call IO_error(100_pInt) ! ...and cannot open material.config file endif Nsections = IO_countSections(fileunit,material_partPhase) lattice_Nstructure = 2_pInt + sum(IO_countTagInPart(fileunit,material_partPhase,'covera_ratio',Nsections)) ! fcc + bcc + all hex ! lattice_Nstructure = Nsections + 2_pInt ! most conservative assumption close(fileunit) - if (debug_verbosity > 0) then + if (debug_verbosity > 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(a16,1x,i5)') '# phases:',Nsections write(6,'(a16,1x,i5)') '# structures:',lattice_Nstructure @@ -773,8 +774,8 @@ subroutine lattice_init() allocate(lattice_shearTwin(lattice_maxNtwin,lattice_Nstructure)); lattice_shearTwin = 0.0_pReal - allocate(lattice_NslipSystem(lattice_maxNslipFamily,lattice_Nstructure)); lattice_NslipSystem = 0.0_pReal - allocate(lattice_NtwinSystem(lattice_maxNtwinFamily,lattice_Nstructure)); lattice_NtwinSystem = 0.0_pReal + allocate(lattice_NslipSystem(lattice_maxNslipFamily,lattice_Nstructure)); lattice_NslipSystem = 0_pInt + allocate(lattice_NtwinSystem(lattice_maxNtwinFamily,lattice_Nstructure)); lattice_NtwinSystem = 0_pInt allocate(lattice_interactionSlipSlip(lattice_maxNslip,lattice_maxNslip,lattice_Nstructure)); lattice_interactionSlipSlip = 0_pInt ! other:me allocate(lattice_interactionSlipTwin(lattice_maxNtwin,lattice_maxNslip,lattice_Nstructure)); lattice_interactionSlipTwin = 0_pInt ! other:me @@ -901,13 +902,13 @@ function lattice_initializeStructure(struct,CoverA) tt(1:3,i) = math_vectorproduct(td(1:3,i),tn(1:3,i)) select case(lattice_hex_shearTwin(i)) ! from Christian & Mahajan 1995 p.29 - case (1) ! {10.2}<-10.1> + case (1_pInt) ! {10.2}<-10.1> ts(i) = (3.0_pReal-CoverA*CoverA)/sqrt(3.0_pReal)/CoverA - case (2) ! {11.2}<11.-3> + case (2_pInt) ! {11.2}<11.-3> ts(i) = 2.0_pReal*(CoverA*CoverA-2.0_pReal)/3.0_pReal/CoverA - case (3) ! {11.1}<-1-1.6> + case (3_pInt) ! {11.1}<-1-1.6> ts(i) = 1.0_pReal/CoverA - case (4) ! {10.1}<10.-2> + case (4_pInt) ! {10.1}<10.-2> ts(i) = (4.0_pReal*CoverA*CoverA-9.0_pReal)/4.0_pReal/sqrt(3.0_pReal)/CoverA end select @@ -921,7 +922,7 @@ function lattice_initializeStructure(struct,CoverA) if (processMe) then if (myStructure > lattice_Nstructure) & - call IO_error(666,0,0,0,'structure index too large') ! check for memory leakage + call IO_error(666_pint,0_pInt,0_pInt,0_pInt,'structure index too large') ! check for memory leakage do i = 1,myNslip ! store slip system vectors and Schmid matrix for my structure lattice_sd(1:3,i,myStructure) = sd(1:3,i) lattice_st(1:3,i,myStructure) = st(1:3,i) diff --git a/code/material.f90 b/code/material.f90 index 444a9d51b..a665a3354 100644 --- a/code/material.f90 +++ b/code/material.f90 @@ -31,13 +31,13 @@ MODULE material use prec, only: pReal,pInt implicit none -character(len=64), parameter :: material_configFile = 'material.config' -character(len=64), parameter :: material_localFileExt = 'materialConfig' -character(len=32), parameter :: material_partHomogenization = 'homogenization' -character(len=32), parameter :: material_partMicrostructure = 'microstructure' -character(len=32), parameter :: material_partCrystallite = 'crystallite' -character(len=32), parameter :: material_partPhase = 'phase' -character(len=32), parameter :: material_partTexture = 'texture' +character(len=64), parameter, public :: material_configFile = 'material.config' +character(len=64), parameter, public :: material_localFileExt = 'materialConfig' +character(len=32), parameter, public :: material_partHomogenization = 'homogenization' +character(len=32), parameter, private :: material_partMicrostructure = 'microstructure' +character(len=32), parameter, public :: material_partCrystallite = 'crystallite' +character(len=32), parameter, public :: material_partPhase = 'phase' +character(len=32), parameter, private :: material_partTexture = 'texture' !************************************* @@ -106,6 +106,8 @@ subroutine material_init() !********************************************************************* !* Module initialization * !************************************** + + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) use prec, only: pReal,pInt use IO, only: IO_error, IO_open_file, IO_open_jobFile use debug, only: debug_verbosity @@ -123,7 +125,7 @@ subroutine material_init() !$OMP END CRITICAL (write2out) if (.not. IO_open_jobFile(fileunit,material_localFileExt)) then ! no local material configuration present... - if (.not. IO_open_file(fileunit,material_configFile)) call IO_error(100) ! ...and cannot open material.config file + if (.not. IO_open_file(fileunit,material_configFile)) call IO_error(100_pInt) ! ...and cannot open material.config file endif call material_parseHomogenization(fileunit,material_partHomogenization) if (debug_verbosity > 0) then @@ -159,18 +161,18 @@ subroutine material_init() do i = 1,material_Nmicrostructure if (microstructure_crystallite(i) < 1 .or. & - microstructure_crystallite(i) > material_Ncrystallite) call IO_error(150,i) + microstructure_crystallite(i) > material_Ncrystallite) call IO_error(150_pInt,i) if (minval(microstructure_phase(1:microstructure_Nconstituents(i),i)) < 1 .or. & - maxval(microstructure_phase(1:microstructure_Nconstituents(i),i)) > material_Nphase) call IO_error(155,i) + maxval(microstructure_phase(1:microstructure_Nconstituents(i),i)) > material_Nphase) call IO_error(155_pInt,i) if (minval(microstructure_texture(1:microstructure_Nconstituents(i),i)) < 1 .or. & - maxval(microstructure_texture(1:microstructure_Nconstituents(i),i)) > material_Ntexture) call IO_error(160,i) + maxval(microstructure_texture(1:microstructure_Nconstituents(i),i)) > material_Ntexture) call IO_error(160_pInt,i) if (abs(sum(microstructure_fraction(:,i)) - 1.0_pReal) >= 1.0e-10_pReal) then if (debug_verbosity > 0) then !$OMP CRITICAL (write2out) write(6,*)'sum of microstructure fraction = ',sum(microstructure_fraction(:,i)) !$OMP END CRITICAL (write2out) endif - call IO_error(170,i) + call IO_error(170_pInt,i) endif enddo if (debug_verbosity > 0) then @@ -217,7 +219,7 @@ subroutine material_parseHomogenization(file,myPart) character(len=*), intent(in) :: myPart integer(pInt), intent(in) :: file - integer(pInt), parameter :: maxNchunks = 2 + integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension(1+2*maxNchunks) :: positions integer(pInt) Nsections, section, s character(len=64) tag @@ -225,7 +227,7 @@ subroutine material_parseHomogenization(file,myPart) Nsections = IO_countSections(file,myPart) material_Nhomogenization = Nsections - if (Nsections < 1_pInt) call IO_error(125,ext_msg=myPart) + if (Nsections < 1_pInt) call IO_error(125_pInt,ext_msg=myPart) allocate(homogenization_name(Nsections)); homogenization_name = '' allocate(homogenization_type(Nsections)); homogenization_type = '' @@ -253,18 +255,18 @@ subroutine material_parseHomogenization(file,myPart) section = section + 1 homogenization_name(section) = IO_getTag(line,'[',']') endif - if (section > 0) then + if (section > 0_pInt) then positions = IO_stringPos(line,maxNchunks) - tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key + tag = IO_lc(IO_stringValue(line,positions,1_pInt)) ! extract key select case(tag) case ('type') - homogenization_type(section) = IO_lc(IO_stringValue(line,positions,2)) ! adding: IO_lc function <<>> - do s = 1,section + homogenization_type(section) = IO_lc(IO_stringValue(line,positions,2_pInt)) ! adding: IO_lc function <<>> + do s = 1_pInt,section if (homogenization_type(s) == homogenization_type(section)) & - homogenization_typeInstance(section) = homogenization_typeInstance(section) + 1 ! count instances + homogenization_typeInstance(section) = homogenization_typeInstance(section) + 1_pInt ! count instances enddo case ('ngrains') - homogenization_Ngrains(section) = IO_intValue(line,positions,2) + homogenization_Ngrains(section) = IO_intValue(line,positions,2_pInt) end select endif enddo @@ -285,15 +287,15 @@ subroutine material_parseMicrostructure(file,myPart) character(len=*), intent(in) :: myPart integer(pInt), intent(in) :: file - integer(pInt), parameter :: maxNchunks = 7 - integer(pInt), dimension(1+2*maxNchunks) :: positions + integer(pInt), parameter :: maxNchunks = 7_pInt + integer(pInt), dimension(1_pInt+2_pInt*maxNchunks) :: positions integer(pInt) Nsections, section, constituent, e, i character(len=64) tag character(len=1024) line Nsections = IO_countSections(file,myPart) material_Nmicrostructure = Nsections - if (Nsections < 1_pInt) call IO_error(125,ext_msg=myPart) + if (Nsections < 1_pInt) call IO_error(125_pInt,ext_msg=myPart) allocate(microstructure_name(Nsections)); microstructure_name = '' allocate(microstructure_crystallite(Nsections)); microstructure_crystallite = 0_pInt @@ -330,21 +332,21 @@ subroutine material_parseMicrostructure(file,myPart) endif if (section > 0) then positions = IO_stringPos(line,maxNchunks) - tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key + tag = IO_lc(IO_stringValue(line,positions,1_pInt)) ! extract key select case(tag) case ('crystallite') - microstructure_crystallite(section) = IO_intValue(line,positions,2) + microstructure_crystallite(section) = IO_intValue(line,positions,2_pInt) case ('(constituent)') constituent = constituent + 1 do i=2,6,2 tag = IO_lc(IO_stringValue(line,positions,i)) select case (tag) case('phase') - microstructure_phase(constituent,section) = IO_intValue(line,positions,i+1) + microstructure_phase(constituent,section) = IO_intValue(line,positions,i+1_pInt) case('texture') - microstructure_texture(constituent,section) = IO_intValue(line,positions,i+1) + microstructure_texture(constituent,section) = IO_intValue(line,positions,i+1_pInt) case('fraction') - microstructure_fraction(constituent,section) = IO_floatValue(line,positions,i+1) + microstructure_fraction(constituent,section) = IO_floatValue(line,positions,i+1_pInt) end select enddo end select @@ -370,7 +372,7 @@ subroutine material_parseCrystallite(file,myPart) Nsections = IO_countSections(file,myPart) material_Ncrystallite = Nsections - if (Nsections < 1_pInt) call IO_error(125,ext_msg=myPart) + if (Nsections < 1_pInt) call IO_error(125_pInt,ext_msg=myPart) allocate(crystallite_name(Nsections)); crystallite_name = '' allocate(crystallite_Noutput(Nsections)); crystallite_Noutput = 0_pInt @@ -416,7 +418,7 @@ subroutine material_parsePhase(file,myPart) Nsections = IO_countSections(file,myPart) material_Nphase = Nsections - if (Nsections < 1_pInt) call IO_error(125,ext_msg=myPart) + if (Nsections < 1_pInt) call IO_error(125_pInt,ext_msg=myPart) allocate(phase_name(Nsections)); phase_name = '' allocate(phase_constitution(Nsections)); phase_constitution = '' @@ -443,12 +445,12 @@ subroutine material_parsePhase(file,myPart) section = section + 1 phase_name(section) = IO_getTag(line,'[',']') endif - if (section > 0) then + if (section > 0_pInt) then positions = IO_stringPos(line,maxNchunks) - tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key + tag = IO_lc(IO_stringValue(line,positions,1_pInt)) ! extract key select case(tag) case ('constitution') - phase_constitution(section) = IO_lc(IO_stringValue(line,positions,2)) + phase_constitution(section) = IO_lc(IO_stringValue(line,positions,2_pInt)) do s = 1,section if (phase_constitution(s) == phase_constitution(section)) & phase_constitutionInstance(section) = phase_constitutionInstance(section) + 1 ! count instances @@ -480,7 +482,7 @@ subroutine material_parseTexture(file,myPart) Nsections = IO_countSections(file,myPart) material_Ntexture = Nsections - if (Nsections < 1_pInt) call IO_error(125,ext_msg=myPart) + if (Nsections < 1_pInt) call IO_error(125_pInt,ext_msg=myPart) allocate(texture_name(Nsections)); texture_name = '' allocate(texture_ODFfile(Nsections)); texture_ODFfile = '' @@ -516,14 +518,14 @@ subroutine material_parseTexture(file,myPart) endif if (section > 0) then positions = IO_stringPos(line,maxNchunks) - tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key + tag = IO_lc(IO_stringValue(line,positions,1_pInt)) ! extract key select case(tag) case ('hybridia') - texture_ODFfile(section) = IO_stringValue(line,positions,2) + texture_ODFfile(section) = IO_stringValue(line,positions,2_pInt) case ('symmetry') - tag = IO_lc(IO_stringValue(line,positions,2)) + tag = IO_lc(IO_stringValue(line,positions,2_pInt)) select case (tag) case('orthotropic') texture_symmetry(section) = 4 @@ -540,9 +542,9 @@ subroutine material_parseTexture(file,myPart) tag = IO_lc(IO_stringValue(line,positions,i)) select case (tag) case('scatter') - texture_Gauss(4,gauss,section) = IO_floatValue(line,positions,i+1)*inRad + texture_Gauss(4,gauss,section) = IO_floatValue(line,positions,i+1_pInt)*inRad case('fraction') - texture_Gauss(5,gauss,section) = IO_floatValue(line,positions,i+1) + texture_Gauss(5,gauss,section) = IO_floatValue(line,positions,i+1_pInt) end select enddo @@ -552,15 +554,15 @@ subroutine material_parseTexture(file,myPart) tag = IO_lc(IO_stringValue(line,positions,i)) select case (tag) case('phi1') - texture_Gauss(1,gauss,section) = IO_floatValue(line,positions,i+1)*inRad + texture_Gauss(1,gauss,section) = IO_floatValue(line,positions,i+1_pInt)*inRad case('phi') - texture_Gauss(2,gauss,section) = IO_floatValue(line,positions,i+1)*inRad + texture_Gauss(2,gauss,section) = IO_floatValue(line,positions,i+1_pInt)*inRad case('phi2') - texture_Gauss(3,gauss,section) = IO_floatValue(line,positions,i+1)*inRad + texture_Gauss(3,gauss,section) = IO_floatValue(line,positions,i+1_pInt)*inRad case('scatter') - texture_Gauss(4,gauss,section) = IO_floatValue(line,positions,i+1)*inRad + texture_Gauss(4,gauss,section) = IO_floatValue(line,positions,i+1_pInt)*inRad case('fraction') - texture_Gauss(5,gauss,section) = IO_floatValue(line,positions,i+1) + texture_Gauss(5,gauss,section) = IO_floatValue(line,positions,i+1_pInt) end select enddo @@ -570,17 +572,17 @@ subroutine material_parseTexture(file,myPart) tag = IO_lc(IO_stringValue(line,positions,i)) select case (tag) case('alpha1') - texture_Fiber(1,fiber,section) = IO_floatValue(line,positions,i+1)*inRad + texture_Fiber(1,fiber,section) = IO_floatValue(line,positions,i+1_pInt)*inRad case('alpha2') - texture_Fiber(2,fiber,section) = IO_floatValue(line,positions,i+1)*inRad + texture_Fiber(2,fiber,section) = IO_floatValue(line,positions,i+1_pInt)*inRad case('beta1') - texture_Fiber(3,fiber,section) = IO_floatValue(line,positions,i+1)*inRad + texture_Fiber(3,fiber,section) = IO_floatValue(line,positions,i+1_pInt)*inRad case('beta2') - texture_Fiber(4,fiber,section) = IO_floatValue(line,positions,i+1)*inRad + texture_Fiber(4,fiber,section) = IO_floatValue(line,positions,i+1_pInt)*inRad case('scatter') - texture_Fiber(5,fiber,section) = IO_floatValue(line,positions,i+1)*inRad + texture_Fiber(5,fiber,section) = IO_floatValue(line,positions,i+1_pInt)*inRad case('fraction') - texture_Fiber(6,fiber,section) = IO_floatValue(line,positions,i+1) + texture_Fiber(6,fiber,section) = IO_floatValue(line,positions,i+1_pInt) end select enddo @@ -643,9 +645,9 @@ subroutine material_populateGrains() homog = mesh_element(3,e) micro = mesh_element(4,e) if (homog < 1 .or. homog > material_Nhomogenization) & ! out of bounds - call IO_error(130,e,0,0) + call IO_error(130_pInt,e,0_pInt,0_pInt) if (micro < 1 .or. micro > material_Nmicrostructure) & ! out of bounds - call IO_error(140,e,0,0) + call IO_error(140_pInt,e,0_pInt,0_pInt) if (microstructure_elemhomo(micro)) then dGrains = homogenization_Ngrains(homog) else @@ -688,7 +690,8 @@ subroutine material_populateGrains() do hme = 1_pInt, Nelems(homog,micro) e = elemsOfHomogMicro(hme,homog,micro) ! my combination of homog and micro, only perform calculations for elements with homog, micro combinations which is indexed in cpElemsindex if (microstructure_elemhomo(micro)) then ! homogeneous distribution of grains over each element's IPs - volumeOfGrain(grain+1:grain+dGrains) = sum(mesh_ipVolume(1:FE_Nips(mesh_element(2,e)),e))/dGrains + volumeOfGrain(grain+1:grain+dGrains) = sum(mesh_ipVolume(1:FE_Nips(mesh_element(2,e)),e))/& + real(dGrains,pReal) grain = grain + dGrains ! wind forward by NgrainsPerIP else forall (i = 1:FE_Nips(mesh_element(2,e))) & ! loop over IPs @@ -707,8 +710,8 @@ subroutine material_populateGrains() extreme = 0.0_pReal t = 0_pInt do i = 1,microstructure_Nconstituents(micro) ! find largest deviator - if (sgn*log(NgrainsOfConstituent(i)/myNgrains/microstructure_fraction(i,micro)) > extreme) then - extreme = sgn*log(NgrainsOfConstituent(i)/myNgrains/microstructure_fraction(i,micro)) + if (real(sgn,pReal)*log(NgrainsOfConstituent(i)/myNgrains/microstructure_fraction(i,micro)) > extreme) then + extreme = real(sgn,pReal)*log(NgrainsOfConstituent(i)/myNgrains/microstructure_fraction(i,micro)) t = i endif enddo @@ -726,7 +729,8 @@ subroutine material_populateGrains() phaseOfGrain(grain+1:grain+NgrainsOfConstituent(i)) = phaseID ! assign resp. phase textureOfGrain(grain+1:grain+NgrainsOfConstituent(i)) = textureID ! assign resp. texture - myNorientations = ceiling(float(NgrainsOfConstituent(i))/texture_symmetry(textureID)) ! max number of unique orientations (excl. symmetry) + myNorientations = ceiling(real(NgrainsOfConstituent(i),pReal)/& + real(texture_symmetry(textureID),pReal)) ! max number of unique orientations (excl. symmetry) constituentGrain = 0_pInt ! constituent grain index ! --------- @@ -758,7 +762,7 @@ subroutine material_populateGrains() else ! hybrid IA ! --------- orientationOfGrain(:,grain+1:grain+myNorientations) = IO_hybridIA(myNorientations,texture_ODFfile(textureID)) - if (all(orientationOfGrain(:,grain+1) == -1.0_pReal)) call IO_error(105) + if (all(orientationOfGrain(:,grain+1) == -1.0_pReal)) call IO_error(105_pInt) constituentGrain = constituentGrain + myNorientations endif diff --git a/code/mesh.f90 b/code/mesh.f90 index 6952864ca..427e29438 100644 --- a/code/mesh.f90 +++ b/code/mesh.f90 @@ -332,12 +332,12 @@ parallelExecution = (parallelExecution .and. (mesh_Nelems == mesh_NcpElems)) ! plus potential killer from non-local constitutive else - call IO_error(error_ID=101) ! cannot open input file + call IO_error(error_ID=101_pInt) ! cannot open input file endif - FEsolving_execElem = (/1,mesh_NcpElems/) + FEsolving_execElem = [ 1_pInt,mesh_NcpElems] allocate(FEsolving_execIP(2,mesh_NcpElems)); FEsolving_execIP = 1_pInt - forall (e = 1:mesh_NcpElems) FEsolving_execIP(2,e) = FE_Nips(mesh_element(2,e)) + forall (e = 1_pInt:mesh_NcpElems) FEsolving_execIP(2,e) = FE_Nips(mesh_element(2,e)) allocate(calcMode(mesh_maxNips,mesh_NcpElems)) calcMode = .false. ! pretend to have collected what first call is asking (F = I) @@ -362,37 +362,37 @@ select case (IO_lc(what)) case ( '7', & 'c3d8') - FE_mapElemtype = 1 ! Three-dimensional Arbitrarily Distorted Brick + FE_mapElemtype = 1_pInt ! Three-dimensional Arbitrarily Distorted Brick case ('134', & 'c3d4') - FE_mapElemtype = 2 ! Three-dimensional Four-node Tetrahedron + FE_mapElemtype = 2_pInt ! Three-dimensional Four-node Tetrahedron case ( '11', & 'cpe4') - FE_mapElemtype = 3 ! Arbitrary Quadrilateral Plane-strain + FE_mapElemtype = 3_pInt ! Arbitrary Quadrilateral Plane-strain case ( '27', & 'cpe8') - FE_mapElemtype = 4 ! Plane Strain, Eight-node Distorted Quadrilateral + FE_mapElemtype = 4_pInt ! Plane Strain, Eight-node Distorted Quadrilateral case ('157') - FE_mapElemtype = 5 ! Three-dimensional, Low-order, Tetrahedron, Herrmann Formulations + FE_mapElemtype = 5_pInt ! Three-dimensional, Low-order, Tetrahedron, Herrmann Formulations case ('136', & 'c3d6') - FE_mapElemtype = 6 ! Three-dimensional Arbitrarily Distorted Pentahedral + FE_mapElemtype = 6_pInt ! Three-dimensional Arbitrarily Distorted Pentahedral case ( '21', & 'c3d20') - FE_mapElemtype = 7 ! Three-dimensional Arbitrarily Distorted quadratic hexahedral + FE_mapElemtype = 7_pInt ! Three-dimensional Arbitrarily Distorted quadratic hexahedral case ( '117', & '123', & 'c3d8r') - FE_mapElemtype = 8 ! Three-dimensional Arbitrarily Distorted linear hexahedral with reduced integration + FE_mapElemtype = 8_pInt ! Three-dimensional Arbitrarily Distorted linear hexahedral with reduced integration case ( '57', & 'c3d20r') - FE_mapElemtype = 9 ! Three-dimensional Arbitrarily Distorted quad hexahedral with reduced integration + FE_mapElemtype = 9_pInt ! Three-dimensional Arbitrarily Distorted quad hexahedral with reduced integration case ( '155', & '125', & '128') - FE_mapElemtype = 10 ! Two-dimensional Plane Strain triangle (155: cubic shape function, 125/128: second order isoparametric) + FE_mapElemtype = 10_pInt ! Two-dimensional Plane Strain triangle (155: cubic shape function, 125/128: second order isoparametric) case default - FE_mapElemtype = 0 ! unknown element --> should raise an error upstream..! + FE_mapElemtype = 0_pInt ! unknown element --> should raise an error upstream..! endselect endfunction @@ -426,7 +426,7 @@ endselect lower = 1_pInt - upper = size(lookupMap,2) + upper = int(size(lookupMap,2_pInt),pInt) ! check at bounds QUESTION is it valid to extend bounds by 1 and just do binary search w/o init check at bounds? if (lookupMap(1,lower) == id) then @@ -1382,9 +1382,9 @@ FE_ipNeighbor(:FE_NipNeighbors(8),:FE_Nips(8),8) = & ! element 117 read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_stringValue(line,myPos,1)) == 'table' .and. myPos(1) .GT. 5) then - initialcondTableStyle = IO_intValue(line,myPos,4) - hypoelasticTableStyle = IO_intValue(line,myPos,5) + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'table' .and. myPos(1_pInt) .GT. 5) then + initialcondTableStyle = IO_intValue(line,myPos,4_pInt) + hypoelasticTableStyle = IO_intValue(line,myPos,5_pInt) exit endif enddo @@ -1409,8 +1409,7 @@ integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 5 integer(pInt), dimension (1+2*maxNchunks) :: myPos integer(pInt) chunk, Nchunks -character(len=300) line -character damaskOption, keyword +character(len=300) line, keyword, damaskOption, v mesh_periodicSurface = (/.false., .false., .false./) @@ -1431,35 +1430,27 @@ do Nchunks = myPos(1) select case (FEsolver) case ('Marc','Abaqus') - if (IO_lc(IO_stringValue(line,myPos,1)) == keyword .and. Nchunks > 1) then ! found keyword for damask option and there is at least one more chunk to read - damaskOption = IO_lc(IO_stringValue(line,myPos,2)) + if (IO_lc(IO_stringValue(line,myPos,1_pInt)) == keyword .and. Nchunks > 1_pInt) then ! found keyword for damask option and there is at least one more chunk to read + damaskOption = IO_lc(IO_stringValue(line,myPos,2_pInt)) select case(damaskOption) case('periodic') ! damask Option that allows to specify periodic fluxes - do chunk = 3,Nchunks ! loop through chunks (skipping the keyword) - select case(IO_stringValue(line,myPos,chunk)) ! chunk matches keyvalues x,y, or z? - case('x') - mesh_periodicSurface(1) = .true. - case('y') - mesh_periodicSurface(2) = .true. - case('z') - mesh_periodicSurface(3) = .true. - end select + do chunk = 3_pInt,Nchunks ! loop through chunks (skipping the keyword) + v = IO_lc(IO_stringValue(line,myPos,chunk)) ! chunk matches keyvalues x,y, or z? + mesh_periodicSurface(1) = mesh_periodicSurface(1) .or. v == 'x' + mesh_periodicSurface(2) = mesh_periodicSurface(2) .or. v == 'y' + mesh_periodicSurface(3) = mesh_periodicSurface(3) .or. v == 'z' enddo endselect endif case('Spectral') - damaskOption = IO_lc(IO_stringValue(line,myPos,1)) + damaskOption = IO_lc(IO_stringValue(line,myPos,1_pInt)) select case(damaskOption) case('periodic') ! damask Option that allows to specify periodic fluxes - do chunk = 2,Nchunks ! loop through chunks (skipping the keyword) - select case(IO_stringValue(line,myPos,chunk)) ! chunk matches keyvalues x,y, or z? - case('x') - mesh_periodicSurface(1) = .true. - case('y') - mesh_periodicSurface(2) = .true. - case('z') - mesh_periodicSurface(3) = .true. - end select + do chunk = 2_pInt,Nchunks ! loop through chunks (skipping the keyword) + v = IO_lc(IO_stringValue(line,myPos,chunk)) ! chunk matches keyvalues x,y, or z? + mesh_periodicSurface(1) = mesh_periodicSurface(1) .or. v == 'x' + mesh_periodicSurface(2) = mesh_periodicSurface(2) .or. v == 'y' + mesh_periodicSurface(3) = mesh_periodicSurface(3) .or. v == 'z' enddo endselect endselect @@ -1491,27 +1482,27 @@ enddo rewind(myUnit) read(myUnit,'(a1024)') line - myPos = IO_stringPos(line,2) - keyword = IO_lc(IO_StringValue(line,myPos,2)) + myPos = IO_stringPos(line,2_pInt) + keyword = IO_lc(IO_StringValue(line,myPos,2_pInt)) if (keyword(1:4) == 'head') then - headerLength = IO_intValue(line,myPos,1) + 1_pInt + headerLength = IO_intValue(line,myPos,1_pInt) + 1_pInt else - call IO_error(error_ID=42) + call IO_error(error_ID=42_pInt) endif rewind(myUnit) do i = 1, headerLength read(myUnit,'(a1024)') line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_StringValue(line,myPos,1)) == 'resolution') then + if ( IO_lc(IO_StringValue(line,myPos,1_pInt)) == 'resolution') then do j = 2,6,2 select case (IO_lc(IO_stringValue(line,myPos,j))) case('a') - a = IO_intValue(line,myPos,j+1) + a = IO_intValue(line,myPos,j+1_pInt) case('b') - b = IO_intValue(line,myPos,j+1) + b = IO_intValue(line,myPos,j+1_pInt) case('c') - c = IO_intValue(line,myPos,j+1) + c = IO_intValue(line,myPos,j+1_pInt) end select enddo mesh_Nelems = a * b * c @@ -1548,9 +1539,9 @@ enddo read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_StringValue(line,myPos,1)) == 'sizing') then - mesh_Nelems = IO_IntValue (line,myPos,3) - mesh_Nnodes = IO_IntValue (line,myPos,4) + if ( IO_lc(IO_StringValue(line,myPos,1_pInt)) == 'sizing') then + mesh_Nelems = IO_IntValue (line,myPos,3_pInt) + mesh_Nnodes = IO_IntValue (line,myPos,4_pInt) exit endif enddo @@ -1585,25 +1576,25 @@ enddo do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*end' .and. & - IO_lc(IO_stringValue(line,myPos,2)) == 'part' ) inPart = .false. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if (inPart .or. noPart) then - select case ( IO_lc(IO_stringValue(line,myPos,1))) + select case ( IO_lc(IO_stringValue(line,myPos,1_pInt))) case('*node') if( & - IO_lc(IO_stringValue(line,myPos,2)) /= 'output' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'print' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'file' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'response' & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'print' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'file' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' & ) & mesh_Nnodes = mesh_Nnodes + IO_countDataLines(myUnit) case('*element') if( & - IO_lc(IO_stringValue(line,myPos,2)) /= 'output' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'matrix' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'response' & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'matrix' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' & ) then mesh_Nelems = mesh_Nelems + IO_countDataLines(myUnit) endif @@ -1611,8 +1602,8 @@ enddo endif enddo -620 if (mesh_Nnodes < 2) call IO_error(error_ID=900) - if (mesh_Nelems == 0) call IO_error(error_ID=901) +620 if (mesh_Nnodes < 2) call IO_error(error_ID=900_pInt) + if (mesh_Nelems == 0) call IO_error(error_ID=901_pInt) endsubroutine @@ -1644,8 +1635,8 @@ enddo read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_StringValue(line,myPos,1)) == 'define' .and. & - IO_lc(IO_StringValue(line,myPos,2)) == 'element' ) then + if ( IO_lc(IO_StringValue(line,myPos,1_pInt)) == 'define' .and. & + IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'element' ) then mesh_NelemSets = mesh_NelemSets + 1_pInt mesh_maxNelemInSet = max(mesh_maxNelemInSet, & IO_countContinousIntValues(myUnit)) @@ -1683,16 +1674,16 @@ enddo do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*end' .and. & - IO_lc(IO_stringValue(line,myPos,2)) == 'part' ) inPart = .false. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. - if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,myPos,1)) == '*elset' ) & + if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*elset' ) & mesh_NelemSets = mesh_NelemSets + 1_pInt enddo 620 continue - if (mesh_NelemSets == 0) call IO_error(error_ID=902) + if (mesh_NelemSets == 0) call IO_error(error_ID=902_pInt) endsubroutine @@ -1724,17 +1715,17 @@ enddo do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*end' .and. & - IO_lc(IO_stringValue(line,myPos,2)) == 'part' ) inPart = .false. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if ( (inPart .or. noPart) .and. & - IO_lc(IO_StringValue(line,myPos,1)) == '*solid' .and. & - IO_lc(IO_StringValue(line,myPos,2)) == 'section' ) & + IO_lc(IO_StringValue(line,myPos,1_pInt)) == '*solid' .and. & + IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'section' ) & mesh_Nmaterials = mesh_Nmaterials + 1_pInt enddo -620 if (mesh_Nmaterials == 0) call IO_error(error_ID=903) +620 if (mesh_Nmaterials == 0) call IO_error(error_ID=903_pInt) endsubroutine @@ -1780,7 +1771,7 @@ enddo read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_stringValue(line,myPos,1)) == 'hypoelastic') then + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'hypoelastic') then do i=1,3+hypoelasticTableStyle ! Skip 3 or 4 lines read (myUnit,610,END=620) line enddo @@ -1819,12 +1810,12 @@ enddo do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) - select case ( IO_lc(IO_stringValue(line,myPos,1)) ) + select case ( IO_lc(IO_stringValue(line,myPos,1_pInt)) ) case('*material') - materialName = IO_extractValue(IO_lc(IO_stringValue(line,myPos,2)),'name') ! extract name=value + materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2_pInt)),'name')) ! extract name=value materialFound = materialName /= '' ! valid name? case('*user') - if (IO_lc(IO_StringValue(line,myPos,2)) == 'material' .and. materialFound) then + if (IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'material' .and. materialFound) then do i = 1,mesh_Nmaterials ! look thru material names if (materialName == mesh_nameMaterial(i)) then ! found one elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet @@ -1839,7 +1830,7 @@ enddo endselect enddo -620 if (mesh_NcpElems == 0) call IO_error(error_ID=906) +620 if (mesh_NcpElems == 0) call IO_error(error_ID=906_pInt) endsubroutine @@ -1863,7 +1854,7 @@ enddo integer(pInt) myUnit,elemSet allocate (mesh_nameElemSet(mesh_NelemSets)) ; mesh_nameElemSet = '' - allocate (mesh_mapElemSet(1+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt + allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt 610 FORMAT(A300) @@ -1872,10 +1863,10 @@ enddo do read (myUnit,610,END=640) line myPos = IO_stringPos(line,maxNchunks) - if( (IO_lc(IO_stringValue(line,myPos,1)) == 'define' ) .and. & - (IO_lc(IO_stringValue(line,myPos,2)) == 'element' ) ) then + if( (IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'define' ) .and. & + (IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'element' ) ) then elemSet = elemSet+1 - mesh_nameElemSet(elemSet) = IO_stringValue(line,myPos,4) + mesh_nameElemSet(elemSet) = trim(IO_stringValue(line,myPos,4_pInt)) mesh_mapElemSet(:,elemSet) = IO_continousIntValues(myUnit,mesh_maxNelemInSet,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) endif enddo @@ -1895,15 +1886,15 @@ enddo implicit none - integer(pInt), parameter :: maxNchunks = 4 - integer(pInt), dimension (1+2*maxNchunks) :: myPos + integer(pInt), parameter :: maxNchunks = 4_pInt + integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line integer(pInt) myUnit,elemSet,i logical inPart allocate (mesh_nameElemSet(mesh_NelemSets)) ; mesh_nameElemSet = '' - allocate (mesh_mapElemSet(1+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt + allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt 610 FORMAT(A300) @@ -1913,21 +1904,22 @@ enddo do read (myUnit,610,END=640) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*end' .and. & - IO_lc(IO_stringValue(line,myPos,2)) == 'part' ) inPart = .false. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. - if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,myPos,1)) == '*elset' ) then + if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*elset' ) then elemSet = elemSet + 1_pInt - mesh_nameElemSet(elemSet) = IO_extractValue(IO_lc(IO_stringValue(line,myPos,2)),'elset') - mesh_mapElemSet(:,elemSet) = IO_continousIntValues(myUnit,mesh_Nelems,mesh_nameElemSet,mesh_mapElemSet,elemSet-1) + mesh_nameElemSet(elemSet) = trim(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2_pInt)),'elset')) + mesh_mapElemSet(:,elemSet) = IO_continousIntValues(myUnit,mesh_Nelems,mesh_nameElemSet,& + mesh_mapElemSet,elemSet-1_pInt) endif enddo -640 do i = 1,elemSet +640 do i = 1_pInt,elemSet ! write(6,*)'elemSetName: ',mesh_nameElemSet(i) ! write(6,*)'elems in Elset',mesh_mapElemSet(:,i) - if (mesh_mapElemSet(1,i) == 0) call IO_error(error_ID=904,ext_msg=mesh_nameElemSet(i)) + if (mesh_mapElemSet(1,i) == 0_pInt) call IO_error(error_ID=904_pInt,ext_msg=mesh_nameElemSet(i)) enddo endsubroutine @@ -1963,22 +1955,22 @@ enddo do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*end' .and. & - IO_lc(IO_stringValue(line,myPos,2)) == 'part' ) inPart = .false. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if ( (inPart .or. noPart) .and. & - IO_lc(IO_StringValue(line,myPos,1)) == '*solid' .and. & - IO_lc(IO_StringValue(line,myPos,2)) == 'section' ) then + IO_lc(IO_StringValue(line,myPos,1_pInt)) == '*solid' .and. & + IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'section' ) then elemSetName = '' materialName = '' - do i = 3,myPos(1) + do i = 3,myPos(1_pInt) if (IO_extractValue(IO_lc(IO_stringValue(line,myPos,i)),'elset') /= '') & - elemSetName = IO_extractValue(IO_lc(IO_stringValue(line,myPos,i)),'elset') + elemSetName = trim(IO_extractValue(IO_lc(IO_stringValue(line,myPos,i)),'elset')) if (IO_extractValue(IO_lc(IO_stringValue(line,myPos,i)),'material') /= '') & - materialName = IO_extractValue(IO_lc(IO_stringValue(line,myPos,i)),'material') + materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,myPos,i)),'material')) enddo if (elemSetName /= '' .and. materialName /= '') then @@ -1989,11 +1981,11 @@ enddo endif enddo -620 if (count==0) call IO_error(error_ID=905) +620 if (count==0) call IO_error(error_ID=905_pInt) do i=1,count ! write(6,*)'name of materials: ',i,mesh_nameMaterial(i) ! write(6,*)'name of elemSets: ',i,mesh_mapMaterial(i) - if (mesh_nameMaterial(i)=='' .or. mesh_mapMaterial(i)=='') call IO_error(error_ID=905) + if (mesh_nameMaterial(i)=='' .or. mesh_mapMaterial(i)=='') call IO_error(error_ID=905_pInt) enddo endsubroutine @@ -2012,7 +2004,7 @@ enddo implicit none integer(pInt) i - allocate (mesh_mapFEtoCPnode(2,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt + allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt forall (i = 1:mesh_Nnodes) & mesh_mapFEtoCPnode(1:2,i) = i @@ -2034,14 +2026,14 @@ enddo implicit none - integer(pInt), parameter :: maxNchunks = 1 - integer(pInt), dimension (1+2*maxNchunks) :: myPos + integer(pInt), parameter :: maxNchunks = 1_pInt + integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line integer(pInt), dimension (mesh_Nnodes) :: node_count integer(pInt) myUnit,i - allocate (mesh_mapFEtoCPnode(2,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt + allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt 610 FORMAT(A300) @@ -2051,18 +2043,18 @@ enddo do read (myUnit,610,END=650) line myPos = IO_stringPos(line,maxNchunks) - if( IO_lc(IO_stringValue(line,myPos,1)) == 'coordinates' ) then + if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'coordinates' ) then read (myUnit,610,END=650) line ! skip crap line do i = 1,mesh_Nnodes read (myUnit,610,END=650) line - mesh_mapFEtoCPnode(1,i) = IO_fixedIntValue (line,(/0,10/),1) - mesh_mapFEtoCPnode(2,i) = i + mesh_mapFEtoCPnode(1_pInt,i) = IO_fixedIntValue (line,[ 0_pInt,10_pInt],1_pInt) + mesh_mapFEtoCPnode(2_pInt,i) = i enddo exit endif enddo -650 call qsort(mesh_mapFEtoCPnode,1,size(mesh_mapFEtoCPnode,2)) +650 call qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) endsubroutine @@ -2088,7 +2080,7 @@ enddo integer(pInt) myUnit,i,count,cpNode logical inPart - allocate (mesh_mapFEtoCPnode(2,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt + allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt 610 FORMAT(A300) @@ -2098,16 +2090,16 @@ enddo do read (myUnit,610,END=650) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*end' .and. & - IO_lc(IO_stringValue(line,myPos,2)) == 'part' ) inPart = .false. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if( (inPart .or. noPart) .and. & - IO_lc(IO_stringValue(line,myPos,1)) == '*node' .and. & - ( IO_lc(IO_stringValue(line,myPos,2)) /= 'output' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'print' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'file' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'response' ) & + IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*node' .and. & + ( IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'print' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'file' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' ) & ) then count = IO_countDataLines(myUnit) do i = 1,count @@ -2117,15 +2109,15 @@ enddo read (myUnit,610,END=650) line myPos = IO_stringPos(line,maxNchunks) cpNode = cpNode + 1_pInt - mesh_mapFEtoCPnode(1,cpNode) = IO_intValue(line,myPos,1) - mesh_mapFEtoCPnode(2,cpNode) = cpNode + mesh_mapFEtoCPnode(1_pInt,cpNode) = IO_intValue(line,myPos,1_pInt) + mesh_mapFEtoCPnode(2_pInt,cpNode) = cpNode enddo endif enddo -650 call qsort(mesh_mapFEtoCPnode,1,size(mesh_mapFEtoCPnode,2)) +650 call qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) - if (size(mesh_mapFEtoCPnode) == 0) call IO_error(error_ID=908) + if (int(size(mesh_mapFEtoCPnode),pInt) == 0_pInt) call IO_error(error_ID=908_pInt) endsubroutine @@ -2142,7 +2134,7 @@ enddo implicit none integer(pInt) i - allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt + allocate (mesh_mapFEtoCPelem(2_pInt,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt forall (i = 1:mesh_NcpElems) & mesh_mapFEtoCPelem(1:2,i) = i @@ -2180,7 +2172,7 @@ enddo do read (myUnit,610,END=660) line myPos = IO_stringPos(line,maxNchunks) - if( IO_lc(IO_stringValue(line,myPos,1)) == 'hypoelastic' ) then + if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'hypoelastic' ) then do i=1,3+hypoelasticTableStyle ! skip three (or four if new table style!) lines read (myUnit,610,END=660) line enddo @@ -2193,7 +2185,7 @@ enddo endif enddo -660 call qsort(mesh_mapFEtoCPelem,1,size(mesh_mapFEtoCPelem,2)) ! should be mesh_NcpElems +660 call qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems endsubroutine @@ -2217,7 +2209,7 @@ enddo integer(pInt) myUnit,i,j,k,cpElem logical materialFound - character (len=64) materialName,elemSetName + character (len=64) materialName,elemSetName ! why limited to 64? ABAQUS? allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt @@ -2228,12 +2220,12 @@ enddo do read (myUnit,610,END=660) line myPos = IO_stringPos(line,maxNchunks) - select case ( IO_lc(IO_stringValue(line,myPos,1)) ) + select case ( IO_lc(IO_stringValue(line,myPos,1_pInt)) ) case('*material') - materialName = IO_extractValue(IO_lc(IO_stringValue(line,myPos,2)),'name') ! extract name=value + materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2_pInt)),'name')) ! extract name=value materialFound = materialName /= '' ! valid name? case('*user') - if (IO_lc(IO_stringValue(line,myPos,2)) == 'material' .and. materialFound) then + if (IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'material' .and. materialFound) then do i = 1,mesh_Nmaterials ! look thru material names if (materialName == mesh_nameMaterial(i)) then ! found one elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet @@ -2253,9 +2245,9 @@ enddo endselect enddo -660 call qsort(mesh_mapFEtoCPelem,1,size(mesh_mapFEtoCPelem,2)) ! should be mesh_NcpElems +660 call qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems - if (size(mesh_mapFEtoCPelem) < 2) call IO_error(error_ID=907) + if (int(size(mesh_mapFEtoCPelem),pInt) < 2_pInt) call IO_error(error_ID=907_pInt) endsubroutine @@ -2311,19 +2303,19 @@ subroutine mesh_marc_count_cpSizes (myUnit) do read (myUnit,610,END=630) line myPos = IO_stringPos(line,maxNchunks) - if( IO_lc(IO_stringValue(line,myPos,1)) == 'connectivity' ) then + if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'connectivity' ) then read (myUnit,610,END=630) line ! Garbage line do i=1,mesh_Nelems ! read all elements read (myUnit,610,END=630) line myPos = IO_stringPos(line,maxNchunks) ! limit to id and type - e = mesh_FEasCP('elem',IO_intValue(line,myPos,1)) + e = mesh_FEasCP('elem',IO_intValue(line,myPos,1_pInt)) if (e /= 0) then - t = FE_mapElemtype(IO_stringValue(line,myPos,2)) + t = FE_mapElemtype(IO_stringValue(line,myPos,2_pInt)) mesh_maxNnodes = max(mesh_maxNnodes,FE_Nnodes(t)) mesh_maxNips = max(mesh_maxNips,FE_Nips(t)) mesh_maxNipNeighbors = max(mesh_maxNipNeighbors,FE_NipNeighbors(t)) mesh_maxNsubNodes = max(mesh_maxNsubNodes,FE_NsubNodes(t)) - call IO_skipChunks(myUnit,FE_NoriginalNodes(t)-(myPos(1)-2)) ! read on if FE_Nnodes exceeds node count present on current line + call IO_skipChunks(myUnit,FE_NoriginalNodes(t)-(myPos(1_pInt)-2_pInt)) ! read on if FE_Nnodes exceeds node count present on current line endif enddo exit @@ -2364,18 +2356,18 @@ subroutine mesh_marc_count_cpSizes (myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*end' .and. & - IO_lc(IO_stringValue(line,myPos,2)) == 'part' ) inPart = .false. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if( (inPart .or. noPart) .and. & - IO_lc(IO_stringValue(line,myPos,1)) == '*element' .and. & - ( IO_lc(IO_stringValue(line,myPos,2)) /= 'output' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'matrix' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'response' ) & + IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*element' .and. & + ( IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'matrix' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' ) & ) then - t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2)),'type')) ! remember elem type - if (t==0) call IO_error(error_ID=910,ext_msg='mesh_abaqus_count_cpSizes') + t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2_pInt)),'type')) ! remember elem type + if (t==0) call IO_error(error_ID=910_pInt,ext_msg='mesh_abaqus_count_cpSizes') count = IO_countDataLines(myUnit) do i = 1,count backspace(myUnit) @@ -2383,7 +2375,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) do i = 1,count read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) ! limit to 64 nodes max - if (mesh_FEasCP('elem',IO_intValue(line,myPos,1)) /= 0) then ! disregard non CP elems + if (mesh_FEasCP('elem',IO_intValue(line,myPos,1_pInt)) /= 0) then ! disregard non CP elems mesh_maxNnodes = max(mesh_maxNnodes,FE_Nnodes(t)) mesh_maxNips = max(mesh_maxNips,FE_Nips(t)) mesh_maxNipNeighbors = max(mesh_maxNipNeighbors,FE_NipNeighbors(t)) @@ -2415,7 +2407,6 @@ subroutine mesh_marc_count_cpSizes (myUnit) logical gotResolution,gotDimension integer(pInt) myUnit - character(len=64) tag character(len=1024) line, keyword allocate ( mesh_node0 (3,mesh_Nnodes) ); mesh_node0 = 0.0_pReal @@ -2432,29 +2423,29 @@ subroutine mesh_marc_count_cpSizes (myUnit) gotDimension = .false. rewind(myUnit) read(myUnit,'(a1024)') line - myPos = IO_stringPos(line,2) - keyword = IO_lc(IO_StringValue(line,myPos,2)) + myPos = IO_stringPos(line,2_pInt) + keyword = IO_lc(IO_StringValue(line,myPos,2_pInt)) if (keyword(1:4) == 'head') then - headerLength = IO_intValue(line,myPos,1) + 1_pInt + headerLength = IO_intValue(line,myPos,1_pInt) + 1_pInt else - call IO_error(error_ID=42) + call IO_error(error_ID=42_pInt) endif rewind(myUnit) do i = 1, headerLength read(myUnit,'(a1024)') line myPos = IO_stringPos(line,maxNchunks) - select case ( IO_lc(IO_StringValue(line,myPos,1)) ) + select case ( IO_lc(IO_StringValue(line,myPos,1_pInt)) ) case ('dimension') gotDimension = .true. do j = 2,6,2 select case (IO_lc(IO_stringValue(line,myPos,j))) case('x') - x = IO_floatValue(line,myPos,j+1) + x = IO_floatValue(line,myPos,j+1_pInt) case('y') - y = IO_floatValue(line,myPos,j+1) + y = IO_floatValue(line,myPos,j+1_pInt) case('z') - z = IO_floatValue(line,myPos,j+1) + z = IO_floatValue(line,myPos,j+1_pInt) end select enddo case ('resolution') @@ -2462,11 +2453,11 @@ subroutine mesh_marc_count_cpSizes (myUnit) do j = 2,6,2 select case (IO_lc(IO_stringValue(line,myPos,j))) case('a') - a = 1_pInt + IO_intValue(line,myPos,j+1) + a = 1_pInt + IO_intValue(line,myPos,j+1_pInt) case('b') - b = 1_pInt + IO_intValue(line,myPos,j+1) + b = 1_pInt + IO_intValue(line,myPos,j+1_pInt) case('c') - c = 1_pInt + IO_intValue(line,myPos,j+1) + c = 1_pInt + IO_intValue(line,myPos,j+1_pInt) end select enddo end select @@ -2474,9 +2465,9 @@ subroutine mesh_marc_count_cpSizes (myUnit) ! --- sanity checks --- - if ((.not. gotDimension) .or. (.not. gotResolution)) call IO_error(error_ID=42) - if ((a < 1) .or. (b < 1) .or. (c < 0)) call IO_error(error_ID=43) ! 1_pInt is already added - if ((x <= 0.0_pReal) .or. (y <= 0.0_pReal) .or. (z <= 0.0_pReal)) call IO_error(error_ID=44) + if ((.not. gotDimension) .or. (.not. gotResolution)) call IO_error(error_ID=42_pInt) + if ((a < 1) .or. (b < 1) .or. (c < 0)) call IO_error(error_ID=43_pInt) ! 1_pInt is already added + if ((x <= 0.0_pReal) .or. (y <= 0.0_pReal) .or. (z <= 0.0_pReal)) call IO_error(error_ID=44_pInt) forall (n = 0:mesh_Nnodes-1) mesh_node0(1,n+1) = x * dble(mod(n,a)) / dble(a-1_pInt) @@ -2517,12 +2508,12 @@ subroutine mesh_marc_count_cpSizes (myUnit) do read (myUnit,610,END=670) line myPos = IO_stringPos(line,maxNchunks) - if( IO_lc(IO_stringValue(line,myPos,1)) == 'coordinates' ) then + if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'coordinates' ) then read (myUnit,610,END=670) line ! skip crap line do i=1,mesh_Nnodes read (myUnit,610,END=670) line - m = mesh_FEasCP('node',IO_fixedIntValue(line,node_ends,1)) - forall (j = 1:3) mesh_node0(j,m) = IO_fixedNoEFloatValue(line,node_ends,j+1) + m = mesh_FEasCP('node',IO_fixedIntValue(line,node_ends,1_pInt)) + forall (j = 1_pInt:3_pInt) mesh_node0(j,m) = IO_fixedNoEFloatValue(line,node_ends,j+1_pInt) enddo exit endif @@ -2562,16 +2553,16 @@ subroutine mesh_marc_count_cpSizes (myUnit) do read (myUnit,610,END=670) line myPos = IO_stringPos(line,maxNchunks) - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*end' .and. & - IO_lc(IO_stringValue(line,myPos,2)) == 'part' ) inPart = .false. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if( (inPart .or. noPart) .and. & - IO_lc(IO_stringValue(line,myPos,1)) == '*node' .and. & - ( IO_lc(IO_stringValue(line,myPos,2)) /= 'output' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'print' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'file' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'response' ) & + IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*node' .and. & + ( IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'print' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'file' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' ) & ) then count = IO_countDataLines(myUnit) ! how many nodes are defined here? do i = 1,count @@ -2580,13 +2571,13 @@ subroutine mesh_marc_count_cpSizes (myUnit) do i = 1,count read (myUnit,610,END=670) line myPos = IO_stringPos(line,maxNchunks) - m = mesh_FEasCP('node',IO_intValue(line,myPos,1)) - forall (j=1:3) mesh_node0(j,m) = IO_floatValue(line,myPos,j+1) + m = mesh_FEasCP('node',IO_intValue(line,myPos,1_pInt)) + forall (j=1:3) mesh_node0(j,m) = IO_floatValue(line,myPos,j+1_pInt) enddo endif enddo -670 if (size(mesh_node0,2) /= mesh_Nnodes) call IO_error(error_ID=909) +670 if (int(size(mesh_node0,2_pInt),pInt) /= mesh_Nnodes) call IO_error(error_ID=909_pInt) mesh_node = mesh_node0 endsubroutine @@ -2620,32 +2611,32 @@ subroutine mesh_marc_count_cpSizes (myUnit) rewind(myUnit) read(myUnit,'(a65536)') line - myPos = IO_stringPos(line,2) - keyword = IO_lc(IO_StringValue(line,myPos,2)) + myPos = IO_stringPos(line,2_pInt) + keyword = IO_lc(IO_StringValue(line,myPos,2_pInt)) if (keyword(1:4) == 'head') then - headerLength = IO_intValue(line,myPos,1) + 1_pInt + headerLength = IO_intValue(line,myPos,1_pInt) + 1_pInt else - call IO_error(error_ID=42) + call IO_error(error_ID=42_pInt) endif rewind(myUnit) do i = 1, headerLength read(myUnit,'(a65536)') line myPos = IO_stringPos(line,maxNchunks) - select case ( IO_lc(IO_StringValue(line,myPos,1)) ) + select case ( IO_lc(IO_StringValue(line,myPos,1_pInt)) ) case ('resolution') do j = 2,6,2 select case (IO_lc(IO_stringValue(line,myPos,j))) case('a') - a = 1_pInt + IO_intValue(line,myPos,j+1) + a = 1_pInt + IO_intValue(line,myPos,j+1_pInt) case('b') - b = 1_pInt + IO_intValue(line,myPos,j+1) + b = 1_pInt + IO_intValue(line,myPos,j+1_pInt) case('c') - c = 1_pInt + IO_intValue(line,myPos,j+1) + c = 1_pInt + IO_intValue(line,myPos,j+1_pInt) end select enddo case ('homogenization') - homog = IO_intValue(line,myPos,2) + homog = IO_intValue(line,myPos,2_pInt) end select enddo @@ -2667,20 +2658,20 @@ subroutine mesh_marc_count_cpSizes (myUnit) e = 0_pInt do while (e < mesh_NcpElems .and. microstructures(1) > 0_pInt) ! fill expected number of elements, stop at end of data (or blank line!) - microstructures = IO_continousIntValues(myUnit,maxIntCount,dummyName,dummySet,0) ! get affected elements - do i = 1,microstructures(1) + microstructures = IO_continousIntValues(myUnit,maxIntCount,dummyName,dummySet,0_pInt) ! get affected elements + do i = 1,microstructures(1_pInt) e = e+1 ! valid element entry mesh_element( 1,e) = e ! FE id mesh_element( 2,e) = FE_mapElemtype('C3D8R') ! elem type mesh_element( 3,e) = homog ! homogenization mesh_element( 4,e) = microstructures(1_pInt+i) ! microstructure - mesh_element( 5,e) = e + (e-1)/(a-1) + ((e-1)/((a-1)*(b-1)))*a ! base node - mesh_element( 6,e) = mesh_element(5,e) + 1 - mesh_element( 7,e) = mesh_element(5,e) + a + 1 + mesh_element( 5,e) = e + (e-1_pInt)/(a-1_pInt) + ((e-1_pInt)/((a-1_pInt)*(b-1_pInt)))*a ! base node + mesh_element( 6,e) = mesh_element(5,e) + 1_pInt + mesh_element( 7,e) = mesh_element(5,e) + a + 1_pInt mesh_element( 8,e) = mesh_element(5,e) + a mesh_element( 9,e) = mesh_element(5,e) + a * b ! second floor base node - mesh_element(10,e) = mesh_element(9,e) + 1 - mesh_element(11,e) = mesh_element(9,e) + a + 1 + mesh_element(10,e) = mesh_element(9,e) + 1_pInt + mesh_element(11,e) = mesh_element(9,e) + a + 1_pInt mesh_element(12,e) = mesh_element(9,e) + a mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),mesh_element(3,e)) !needed for statistics mesh_maxValStateVar(2) = max(mesh_maxValStateVar(2),mesh_element(4,e)) @@ -2688,7 +2679,7 @@ subroutine mesh_marc_count_cpSizes (myUnit) enddo 110 deallocate(microstructures) - if (e /= mesh_NcpElems) call IO_error(180,e) + if (e /= mesh_NcpElems) call IO_error(180_pInt,e) endsubroutine @@ -2720,19 +2711,19 @@ subroutine mesh_marc_count_cpSizes (myUnit) rewind(myUnit) do read (myUnit,610,END=620) line - myPos(1:1+2*1) = IO_stringPos(line,1) - if( IO_lc(IO_stringValue(line,myPos,1)) == 'connectivity' ) then + myPos(1:1+2*1) = IO_stringPos(line,1_pInt) + if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'connectivity' ) then read (myUnit,610,END=620) line ! Garbage line do i = 1,mesh_Nelems read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) ! limit to 64 nodes max (plus ID, type) - e = mesh_FEasCP('elem',IO_intValue(line,myPos,1)) + e = mesh_FEasCP('elem',IO_intValue(line,myPos,1_pInt)) if (e /= 0) then ! disregard non CP elems - mesh_element(1,e) = IO_IntValue (line,myPos,1) ! FE id - mesh_element(2,e) = FE_mapElemtype(IO_StringValue(line,myPos,2)) ! elem type + mesh_element(1,e) = IO_IntValue (line,myPos,1_pInt) ! FE id + mesh_element(2,e) = FE_mapElemtype(IO_StringValue(line,myPos,2_pInt)) ! elem type forall (j = 1:FE_Nnodes(mesh_element(2,e))) & - mesh_element(j+4,e) = IO_IntValue(line,myPos,j+2) ! copy FE ids of nodes - call IO_skipChunks(myUnit,FE_NoriginalNodes(mesh_element(2,e))-(myPos(1)-2)) ! read on if FE_Nnodes exceeds node count present on current line + mesh_element(j+4,e) = IO_IntValue(line,myPos,j+2_pInt) ! copy FE ids of nodes + call IO_skipChunks(myUnit,FE_NoriginalNodes(mesh_element(2_pInt,e))-(myPos(1_pInt)-2_pInt)) ! read on if FE_Nnodes exceeds node count present on current line endif enddo exit @@ -2742,31 +2733,31 @@ subroutine mesh_marc_count_cpSizes (myUnit) 620 rewind(myUnit) ! just in case "initial state" apears before "connectivity" read (myUnit,610,END=620) line do - myPos(1:1+2*2) = IO_stringPos(line,2) - if( (IO_lc(IO_stringValue(line,myPos,1)) == 'initial') .and. & - (IO_lc(IO_stringValue(line,myPos,2)) == 'state') ) then - if (initialcondTableStyle == 2) read (myUnit,610,END=620) line ! read extra line for new style + myPos(1:1+2*2) = IO_stringPos(line,2_pInt) + if( (IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'initial') .and. & + (IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'state') ) then + if (initialcondTableStyle == 2_pInt) read (myUnit,610,END=620) line ! read extra line for new style read (myUnit,610,END=630) line ! read line with index of state var - myPos(1:1+2*1) = IO_stringPos(line,1) - sv = IO_IntValue(line,myPos,1) ! figure state variable index - if( (sv == 2).or.(sv == 3) ) then ! only state vars 2 and 3 of interest + myPos(1:1+2*1) = IO_stringPos(line,1_pInt) + sv = IO_IntValue(line,myPos,1_pInt) ! figure state variable index + if( (sv == 2_pInt).or.(sv == 3_pInt) ) then ! only state vars 2 and 3 of interest read (myUnit,610,END=620) line ! read line with value of state var - myPos(1:1+2*1) = IO_stringPos(line,1) - do while (scan(IO_stringValue(line,myPos,1),'+-',back=.true.)>1) ! is noEfloat value? - val = NINT(IO_fixedNoEFloatValue(line,(/0,20/),1)) ! state var's value - mesh_maxValStateVar(sv-1) = max(val,mesh_maxValStateVar(sv-1)) ! remember max val of homogenization and microstructure index + myPos(1:1+2*1) = IO_stringPos(line,1_pInt) + do while (scan(IO_stringValue(line,myPos,1_pInt),'+-',back=.true.)>1_pInt) ! is noEfloat value? + val = NINT(IO_fixedNoEFloatValue(line,(/0_pInt,20_pInt/),1_pInt)) ! state var's value + mesh_maxValStateVar(sv-1) = max(val,mesh_maxValStateVar(sv-1_pInt)) ! remember max val of homogenization and microstructure index if (initialcondTableStyle == 2) then read (myUnit,610,END=630) line ! read extra line read (myUnit,610,END=630) line ! read extra line endif contInts = IO_continousIntValues(myUnit,mesh_Nelems,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) ! get affected elements do i = 1,contInts(1) - e = mesh_FEasCP('elem',contInts(1+i)) - mesh_element(1+sv,e) = val + e = mesh_FEasCP('elem',contInts(1_pInt+i)) + mesh_element(1_pInt+sv,e) = val enddo if (initialcondTableStyle == 0) read (myUnit,610,END=620) line ! ignore IP range for old table style read (myUnit,610,END=630) line - myPos(1:1+2*1) = IO_stringPos(line,1) + myPos(1:1+2*1) = IO_stringPos(line,1_pInt) enddo endif else @@ -2776,8 +2767,6 @@ subroutine mesh_marc_count_cpSizes (myUnit) 630 endsubroutine - - !******************************************************************** ! store FEid, type, mat, tex, and node list per element ! @@ -2806,19 +2795,19 @@ subroutine mesh_marc_count_cpSizes (myUnit) rewind(myUnit) do read (myUnit,610,END=620) line - myPos(1:1+2*2) = IO_stringPos(line,2) - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,myPos,1)) == '*end' .and. & - IO_lc(IO_stringValue(line,myPos,2)) == 'part' ) inPart = .false. + myPos(1:1+2*2) = IO_stringPos(line,2_pInt) + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if( (inPart .or. noPart) .and. & - IO_lc(IO_stringValue(line,myPos,1)) == '*element' .and. & - ( IO_lc(IO_stringValue(line,myPos,2)) /= 'output' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'matrix' .and. & - IO_lc(IO_stringValue(line,myPos,2)) /= 'response' ) & + IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*element' .and. & + ( IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'matrix' .and. & + IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' ) & ) then - t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2)),'type')) ! remember elem type - if (t==0) call IO_error(error_ID=910,ext_msg='mesh_abaqus_build_elements') + t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2_pInt)),'type')) ! remember elem type + if (t==0) call IO_error(error_ID=910_pInt,ext_msg='mesh_abaqus_build_elements') count = IO_countDataLines(myUnit) do i = 1,count backspace(myUnit) @@ -2826,13 +2815,13 @@ subroutine mesh_marc_count_cpSizes (myUnit) do i = 1,count read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) ! limit to 64 nodes max - e = mesh_FEasCP('elem',IO_intValue(line,myPos,1)) + e = mesh_FEasCP('elem',IO_intValue(line,myPos,1_pInt)) if (e /= 0) then ! disregard non CP elems - mesh_element(1,e) = IO_intValue(line,myPos,1) ! FE id + mesh_element(1,e) = IO_intValue(line,myPos,1_pInt) ! FE id mesh_element(2,e) = t ! elem type forall (j=1:FE_Nnodes(t)) & - mesh_element(4+j,e) = IO_intValue(line,myPos,1+j) ! copy FE ids of nodes to position 5: - call IO_skipChunks(myUnit,FE_NoriginalNodes(t)-(myPos(1)-1)) ! read on (even multiple lines) if FE_NoriginalNodes exceeds required node count + mesh_element(4_pInt+j,e) = IO_intValue(line,myPos,1_pInt+j) ! copy FE ids of nodes to position 5: + call IO_skipChunks(myUnit,FE_NoriginalNodes(t)-(myPos(1_pInt)-1_pInt)) ! read on (even multiple lines) if FE_NoriginalNodes exceeds required node count endif enddo endif @@ -2845,17 +2834,17 @@ subroutine mesh_marc_count_cpSizes (myUnit) do read (myUnit,610,END=630) line myPos = IO_stringPos(line,maxNchunks) - select case ( IO_lc(IO_StringValue(line,myPos,1))) + select case ( IO_lc(IO_StringValue(line,myPos,1_pInt))) case('*material') - materialName = IO_extractValue(IO_lc(IO_StringValue(line,myPos,2)),'name') ! extract name=value + materialName = trim(IO_extractValue(IO_lc(IO_StringValue(line,myPos,2_pInt)),'name')) ! extract name=value materialFound = materialName /= '' ! valid name? case('*user') - if ( IO_lc(IO_StringValue(line,myPos,2)) == 'material' .and. & + if ( IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'material' .and. & materialFound ) then read (myUnit,610,END=630) line ! read homogenization and microstructure - myPos(1:1+2*2) = IO_stringPos(line,2) - homog = NINT(IO_floatValue(line,myPos,1)) - micro = NINT(IO_floatValue(line,myPos,2)) + myPos(1:1+2*2) = IO_stringPos(line,2_pInt) + homog = NINT(IO_floatValue(line,myPos,1_pInt)) + micro = NINT(IO_floatValue(line,myPos,2_pInt)) do i = 1,mesh_Nmaterials ! look thru material names if (materialName == mesh_nameMaterial(i)) then ! found one elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet @@ -3135,7 +3124,7 @@ endsubroutine + mesh_node(1:3,mesh_FEasCP('node',mesh_element(4+FE_subNodeParent(p,n,t),e))) ! add up parents enddo mesh_subNodeCoord(1:3,n+FE_Nnodes(t),e) = mesh_subNodeCoord(1:3,n+FE_Nnodes(t),e) & - / count(FE_subNodeParent(:,n,t) > 0) + /real(count(FE_subNodeParent(:,n,t) > 0),pReal) enddo enddo @@ -3185,7 +3174,7 @@ endsubroutine enddo endif enddo - centerOfGravity = sum(gravityNodePos,2)/count(gravityNode) + centerOfGravity = sum(gravityNodePos,2)/real(count(gravityNode),pReal) mesh_ipCenterOfGravity(:,i,e) = centerOfGravity enddo enddo @@ -3216,15 +3205,15 @@ endsubroutine mesh_ipVolume = 0.0_pReal do e = 1,mesh_NcpElems ! loop over cpElems - t = mesh_element(2,e) ! get elemType + t = mesh_element(2_pInt,e) ! get elemType do i = 1,FE_Nips(t) ! loop over IPs of elem do f = 1,FE_NipNeighbors(t) ! loop over interfaces of IP and add tetrahedra which connect to CoG forall (n = 1:FE_NipFaceNodes) & nPos(:,n) = mesh_subNodeCoord(:,FE_subNodeOnIPFace(n,f,i,t),e) forall (n = 1:FE_NipFaceNodes, j = 1:Ntriangles) & ! start at each interface node and build valid triangles to cover interface volume(j,n) = math_volTetrahedron(nPos(:,n), & ! calc volume of respective tetrahedron to CoG - nPos(:,1+mod(n-1 +j ,FE_NipFaceNodes)), & ! start at offset j - nPos(:,1+mod(n-1 +j+1,FE_NipFaceNodes)), & ! and take j's neighbor + nPos(:,1_pInt+mod(n-1_pInt +j ,FE_NipFaceNodes)), & ! start at offset j + nPos(:,1+mod(n-1_pInt +j+1_pInt,FE_NipFaceNodes)), & ! and take j's neighbor mesh_ipCenterOfGravity(:,i,e)) mesh_ipVolume(i,e) = mesh_ipVolume(i,e) + sum(volume) ! add contribution from this interface enddo @@ -3254,22 +3243,23 @@ endsubroutine real(pReal), dimension(Ntriangles,FE_NipFaceNodes) :: area allocate(mesh_ipArea(mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems)) ; mesh_ipArea = 0.0_pReal - allocate(mesh_ipAreaNormal(3,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems)) ; mesh_ipAreaNormal = 0.0_pReal + allocate(mesh_ipAreaNormal(3_pInt,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems)) ; mesh_ipAreaNormal = 0.0_pReal do e = 1,mesh_NcpElems ! loop over cpElems t = mesh_element(2,e) ! get elemType do i = 1,FE_Nips(t) ! loop over IPs of elem do f = 1,FE_NipNeighbors(t) ! loop over interfaces of IP forall (n = 1:FE_NipFaceNodes) nPos(:,n) = mesh_subNodeCoord(:,FE_subNodeOnIPFace(n,f,i,t),e) forall (n = 1:FE_NipFaceNodes, j = 1:Ntriangles) ! start at each interface node and build valid triangles to cover interface - normal(:,j,n) = math_vectorproduct(nPos(:,1+mod(n+j-1,FE_NipFaceNodes)) - nPos(:,n), & ! calc their normal vectors - nPos(:,1+mod(n+j-0,FE_NipFaceNodes)) - nPos(:,n)) + normal(:,j,n) = math_vectorproduct(nPos(:,1_pInt+mod(n+j-1_pInt,FE_NipFaceNodes)) - nPos(:,n), & ! calc their normal vectors + nPos(:,1_pInt+mod(n+j-0_pInt,FE_NipFaceNodes)) - nPos(:,n)) area(j,n) = sqrt(sum(normal(:,j,n)*normal(:,j,n))) ! and area end forall forall (n = 1:FE_NipFaceNodes, j = 1:Ntriangles, area(j,n) > 0.0_pReal) & normal(1:3,j,n) = normal(1:3,j,n) / area(j,n) ! make myUnit normal mesh_ipArea(f,i,e) = sum(area) / (FE_NipFaceNodes*2.0_pReal) ! area of parallelograms instead of triangles - mesh_ipAreaNormal(:,f,i,e) = sum(sum(normal,3),2) / count(area > 0.0_pReal) ! average of all valid normals + mesh_ipAreaNormal(:,f,i,e) = sum(sum(normal,3),2)/& ! average of all valid normals + real(count(area > 0.0_pReal),pReal) enddo enddo enddo @@ -3375,13 +3365,13 @@ character(len=64) fmt integer(pInt) i,e,n,f,t -if (mesh_maxValStateVar(1) < 1_pInt) call IO_error(error_ID=110) ! no homogenization specified -if (mesh_maxValStateVar(2) < 1_pInt) call IO_error(error_ID=120) ! no microstructure specified +if (mesh_maxValStateVar(1) < 1_pInt) call IO_error(error_ID=110_pInt) ! no homogenization specified +if (mesh_maxValStateVar(2) < 1_pInt) call IO_error(error_ID=120_pInt) ! no microstructure specified allocate (mesh_HomogMicro(mesh_maxValStateVar(1),mesh_maxValStateVar(2))); mesh_HomogMicro = 0_pInt do e = 1,mesh_NcpElems - if (mesh_element(3,e) < 1_pInt) call IO_error(error_ID=110,e=e) ! no homogenization specified - if (mesh_element(4,e) < 1_pInt) call IO_error(error_ID=120,e=e) ! no microstructure specified + if (mesh_element(3,e) < 1_pInt) call IO_error(error_ID=110_pInt,e=e) ! no homogenization specified + if (mesh_element(4,e) < 1_pInt) call IO_error(error_ID=120_pInt,e=e) ! no microstructure specified mesh_HomogMicro(mesh_element(3,e),mesh_element(4,e)) = & mesh_HomogMicro(mesh_element(3,e),mesh_element(4,e)) + 1 ! count combinations of homogenization and microstructure enddo @@ -3500,5 +3490,4 @@ deallocate(mesh_HomogMicro) endsubroutine -END MODULE mesh - +END MODULE mesh \ No newline at end of file