223031012
/
DAMASK_EICMD
mirror of https://github.com/achalhp/DAMASK_EICMD.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

corrected makefile, now working again without giving standard values explicitly. 

did some small modification in order to make it possible to compile with gfortran. Changed NaN=0.0/0.0 to bitwise representation (3 different ways)
This commit is contained in:
Martin Diehl 2011-08-01 10:11:32 +00:00
parent 06a4ac2565
commit 3adb7ab382
8 changed files with 259 additions and 211 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
code/DAMASK_spectral.f90
View File

@ -262,8 +262,8 @@ if ((N_l + N_Fdot /= N_n).or.(N_n /= N_t)) & ! sanity check
call IO_error(31,loadcase) call IO_error(31,loadcase)
if (velGradApplied(loadcase)) then if (velGradApplied(loadcase)) then
do j = 1, 3 do j = 1, 3
if (any(bc_mask(j,:,1,loadcase) == .true.) .and.& if (any(bc_mask(j,:,1,loadcase) .eqv. .true.) .and.&
any(bc_mask(j,:,1,loadcase) == .false.)) call IO_error(32,loadcase) ! each line should be either fully or not at all defined any(bc_mask(j,:,1,loadcase) .eqv. .false.)) call IO_error(32,loadcase) ! each line should be either fully or not at all defined
enddo enddo
print '(a,/,3(3(f12.6,x)/))','L:' ,math_transpose3x3(bc_deformation(:,:,loadcase)) print '(a,/,3(3(f12.6,x)/))','L:' ,math_transpose3x3(bc_deformation(:,:,loadcase))
print '(a,/,3(3(l,x)/))', 'bc_mask for L:',transpose(bc_mask(:,:,1,loadcase)) print '(a,/,3(3(l,x)/))', 'bc_mask for L:',transpose(bc_mask(:,:,1,loadcase))
@ -326,7 +326,9 @@ if ((N_l + N_Fdot /= N_n).or.(N_n /= N_t)) & ! sanity check
enddo enddo
100 close(unit) 100 close(unit)
if(mod(resolution(1),2)/=0 .or. mod(resolution(2),2)/=0 .or. mod(resolution(3),2)/=0) call IO_error(103) if(mod(resolution(1),2_pInt)/=0_pInt .or.&
mod(resolution(2),2_pInt)/=0_pInt .or.&
(mod(resolution(3),2_pInt)/=0_pInt .and. resolution(3)/= 1_pInt)) call IO_error(103)
print '(a,/,i4,i4,i4)','resolution a b c:', resolution print '(a,/,i4,i4,i4)','resolution a b c:', resolution
print '(a,/,f8.4,f8.5,f8.5)','dimension x y z:', geomdimension print '(a,/,f8.4,f8.5,f8.5)','dimension x y z:', geomdimension
@ -426,10 +428,12 @@ if ((N_l + N_Fdot /= N_n).or.(N_n /= N_t)) & ! sanity check
!!!!!!!!!!!!!!!!!!!!!!!! start divergence debugging !!!!!!!!!!!!!!!!!!!!!!!! start divergence debugging
call dfftw_plan_many_dft(plan_div(1),3,(/resolution(1),resolution(2),resolution(3)/),9,& call dfftw_plan_many_dft(plan_div(1),3,(/resolution(1),resolution(2),resolution(3)/),9,&
pstress_field,(/resolution(1),resolution(2),resolution(3)/),1,(resolution(1)*resolution(2)*resolution(3)),& pstress_field,(/resolution(1),resolution(2),resolution(3)/),1,(resolution(1)*resolution(2)*resolution(3)),&
pstress_field_hat, (/resolution(1),resolution(2),resolution(3)/),1,(resolution(1)*resolution(2)*resolution(3)),FFTW_FORWARD,FFTW_PATIENT) pstress_field_hat, (/resolution(1),resolution(2),resolution(3)/),1,(resolution(1)*resolution(2)*resolution(3)),&
FFTW_FORWARD,FFTW_PATIENT)
call dfftw_plan_many_dft_c2r(plan_div(2),3,(/resolution(1),resolution(2),resolution(3)/),3/3,& call dfftw_plan_many_dft_c2r(plan_div(2),3,(/resolution(1),resolution(2),resolution(3)/),3/3,&
divergence_hat, (/resolution(1)/2+1,resolution(2),resolution(3)/),1,(resolution(1)/2+1)*resolution(2)*resolution(3),& divergence_hat, (/resolution(1)/2+1,resolution(2),resolution(3)/),1,(resolution(1)/2+1)*resolution(2)*resolution(3),&
divergence ,(/resolution(1), resolution(2),resolution(3)/),1, resolution(1)* resolution(2)*resolution(3),FFTW_PATIENT) divergence ,(/resolution(1), resolution(2),resolution(3)/),1, resolution(1)* resolution(2)*resolution(3),&
FFTW_PATIENT)
!!!!!!!!!!!!!!!!!!!!!!!! end divergence debugging !!!!!!!!!!!!!!!!!!!!!!!! end divergence debugging
! write header of output file ! write header of output file
@ -695,8 +699,8 @@ if ((N_l + N_Fdot /= N_n).or.(N_n /= N_t)) & ! sanity check
do j = 1, resolution(2) do j = 1, resolution(2)
err_div_avg_inf = err_div_avg_inf + (maxval(abs(math_mul33x3_complex& err_div_avg_inf = err_div_avg_inf + (maxval(abs(math_mul33x3_complex&
(workfft(3+2*i,n,m,:,:)+workfft(4+i*2,n,m,:,:)*img,xi(:,resolution(1)-i,j,k)*minval(geomdimension)))))**2.0 (workfft(3+2*i,n,m,:,:)+workfft(4+i*2,n,m,:,:)*img,xi(:,resolution(1)-i,j,k)*minval(geomdimension)))))**2.0
err_div_avg_two = err_div_avg_two + abs(sum((math_mul33x3_complex(workfft(3+2*i,n,m,:,:)+workfft(4+i*2,n,m,:,:)*img,xi(:,resolution(1)-i,j,k)& err_div_avg_two = err_div_avg_two + abs(sum((math_mul33x3_complex(workfft(3+2*i,n,m,:,:)+workfft(4+i*2,n,m,:,:)*img,&
*minval(geomdimension)))**2.0)) xi(:,resolution(1)-i,j,k)*minval(geomdimension)))**2.0))
! workfft(resolution(1)-i,j,k,:,:) = conjg(workfft(2+i,n,m,:,:)) original code for complex array, above little bit confusing because compley data is stored in real array ! workfft(resolution(1)-i,j,k,:,:) = conjg(workfft(2+i,n,m,:,:)) original code for complex array, above little bit confusing because compley data is stored in real array
if(n == 1) n = resolution(2) +1 if(n == 1) n = resolution(2) +1
n = n-1 n = n-1
@ -706,8 +710,10 @@ if ((N_l + N_Fdot /= N_n).or.(N_n /= N_t)) & ! sanity check
enddo; enddo enddo; enddo
do k = 1, resolution(3); do j = 1, resolution(2); do i = 1, resolution(1) !calculating divergence criteria for full field (no complex symmetry) do k = 1, resolution(3); do j = 1, resolution(2); do i = 1, resolution(1) !calculating divergence criteria for full field (no complex symmetry)
err_div_max_two2 = max(err_div_max_two,abs(sqrt(sum(math_mul33x3_complex(pstress_field_hat(i,j,k,:,:),xi(:,i,j,k)*minval(geomdimension)))**2.0))) err_div_max_two2 = max(err_div_max_two,abs(sqrt(sum(math_mul33x3_complex(pstress_field_hat(i,j,k,:,:),xi(:,i,j,k)*&
err_div_max_inf2 = max(err_div_max_inf2 , (maxval(abs(math_mul33x3_complex(pstress_field_hat(i,j,k,:,:),xi(:,i,j,k)*minval(geomdimension)))))) minval(geomdimension)))**2.0)))
err_div_max_inf2 = max(err_div_max_inf2 , (maxval(abs(math_mul33x3_complex(pstress_field_hat(i,j,k,:,:),xi(:,i,j,k)*&
minval(geomdimension))))))
err_div_avg_inf2 = err_div_avg_inf2 + (maxval(abs(math_mul33x3_complex(pstress_field_hat(i,j,k,:,:),& err_div_avg_inf2 = err_div_avg_inf2 + (maxval(abs(math_mul33x3_complex(pstress_field_hat(i,j,k,:,:),&
xi(:,i,j,k)*minval(geomdimension)))))**2.0 xi(:,i,j,k)*minval(geomdimension)))))**2.0
err_div_avg_two2 = err_div_avg_two2 + abs(sum((math_mul33x3_complex(pstress_field_hat(i,j,k,:,:),& err_div_avg_two2 = err_div_avg_two2 + abs(sum((math_mul33x3_complex(pstress_field_hat(i,j,k,:,:),&

6
code/DAMASK_spectral_interface.f90
View File

@ -94,7 +94,7 @@ function getModelName()
implicit none implicit none
character(1024) getModelName, outName, cwd character(1024) getModelName, outName, cwd
character(len=*), parameter :: pathSep = achar(47)//achar(92) ! /, \ character(len=*), parameter :: pathSep = achar(47)//achar(92) ! forwardslash, backwardslash
integer(pInt) posExt,posSep integer(pInt) posExt,posSep
getModelName = '' getModelName = ''
@ -129,7 +129,7 @@ function getLoadCase()
implicit none implicit none
character(1024) getLoadCase, outName character(1024) getLoadCase, outName
character(len=*), parameter :: pathSep = achar(47)//achar(92) ! /, \ character(len=*), parameter :: pathSep = achar(47)//achar(92) ! forwardslash, backwardslash
integer(pInt) posExt,posSep integer(pInt) posExt,posSep
getLoadCase = '' getLoadCase = ''
@ -157,7 +157,7 @@ function getLoadcaseName()
implicit none implicit none
character(len=1024) getLoadcaseName, outName, cwd character(len=1024) getLoadcaseName, outName, cwd
character(len=*), parameter :: pathSep = achar(47)//achar(92) ! /, \ character(len=*), parameter :: pathSep = achar(47)//achar(92) ! forwardslash, backwardslash
integer(pInt) posExt,posSep integer(pInt) posExt,posSep
posExt = 0 posExt = 0

2
code/constitutive_nonlocal.f90
View File

@ -1650,7 +1650,7 @@ forall (s = 1:ns, t = 1:4, rhoSgl(s,t+4) * constitutive_nonlocal_v(s,t,g,ip,el)
if (any(1.2_pReal * constitutive_nonlocal_v(1:ns,1:4,g,ip,el) * timestep & ! security factor 1.2 if (any(1.2_pReal * constitutive_nonlocal_v(1:ns,1:4,g,ip,el) * timestep & ! security factor 1.2
> mesh_ipVolume(ip,el) / maxval(mesh_ipArea(:,ip,el)))) then > mesh_ipVolume(ip,el) / maxval(mesh_ipArea(:,ip,el)))) then
dotState%p = NaN dotState%p = NaN(3)
return return
endif endif

26
code/constitutive_titanmod.f90
View File

@ -52,27 +52,27 @@ implicit none
!* Lists of states and physical parameters !* Lists of states and physical parameters
character(len=*), parameter :: constitutive_titanmod_label = 'titanmod' character(len=*), parameter :: constitutive_titanmod_label = 'titanmod'
character(len=18), dimension(3), parameter:: constitutive_titanmod_listBasicSlipStates = (/'rho_edge', & character(len=18), dimension(3), parameter:: constitutive_titanmod_listBasicSlipStates = (/'rho_edge ', &
'rho_screw', & 'rho_screw ', &
'shear_system'/) 'shear_system'/)
character(len=18), dimension(1), parameter:: constitutive_titanmod_listBasicTwinStates = (/'gdot_twin'/) character(len=18), dimension(1), parameter:: constitutive_titanmod_listBasicTwinStates = (/'gdot_twin'/)
character(len=18), dimension(11), parameter:: constitutive_titanmod_listDependentSlipStates =(/'segment_edge', & character(len=18), dimension(11), parameter:: constitutive_titanmod_listDependentSlipStates =(/'segment_edge ', &
'segment_screw', & 'segment_screw ', &
'resistance_edge', & 'resistance_edge ', &
'resistance_screw', & 'resistance_screw ', &
'tau_slip', & 'tau_slip ', &
'velocity_edge', & 'velocity_edge ', &
'velocity_screw', & 'velocity_screw ', &
'gdot_slip_edge', & 'gdot_slip_edge ', &
'gdot_slip_screw', & 'gdot_slip_screw ', &
'stressratio_edge_p', & 'stressratio_edge_p ', &
'stressratio_screw_p' & 'stressratio_screw_p' &
/) /)
character(len=18), dimension(2), parameter:: constitutive_titanmod_listDependentTwinStates =(/'twin_fraction', & character(len=18), dimension(2), parameter:: constitutive_titanmod_listDependentTwinStates =(/'twin_fraction', &
'tau_twin' & 'tau_twin ' &
/) /)
real(pReal), parameter :: kB = 1.38e-23_pReal ! Boltzmann constant in J/Kelvin real(pReal), parameter :: kB = 1.38e-23_pReal ! Boltzmann constant in J/Kelvin

5
code/homogenization.f90
View File

@ -124,7 +124,7 @@ do p = 1,material_Nhomogenization
write(fileunit,*) write(fileunit,*)
if (knownHomogenization) then if (knownHomogenization) then
write(fileunit,'(a)') '(type)'//char(9)//trim(homogenization_type(p)) write(fileunit,'(a)') '(type)'//char(9)//trim(homogenization_type(p))
write(fileunit,'(a,i)') '(ngrains)'//char(9),homogenization_Ngrains(p) write(fileunit,'(a,i4)') '(ngrains)'//char(9),homogenization_Ngrains(p)
do e = 1,homogenization_Noutput(p) do e = 1,homogenization_Noutput(p)
write(fileunit,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) write(fileunit,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i)
enddo enddo
@ -410,7 +410,8 @@ subroutine materialpoint_stressAndItsTangent(&
#ifndef _OPENMP #ifndef _OPENMP
if (debug_verbosity > 2 .and. ((e == debug_e .and. i == debug_i) .or. .not. debug_selectiveDebugger)) then if (debug_verbosity > 2 .and. ((e == debug_e .and. i == debug_i) .or. .not. debug_selectiveDebugger)) then
write(6,'(a,x,f10.8,/)') '<< HOMOG >> cutback step in materialpoint_stressAndItsTangent with new materialpoint_subStep:',& write(6,'(a,x,f10.8,/)') '<< HOMOG >> cutback step in materialpoint_stressAndItsTangent with&
new materialpoint_subStep:',&
materialpoint_subStep(i,e) materialpoint_subStep(i,e)
endif endif
#endif #endif

51
code/makefile
View File

@ -10,36 +10,47 @@
# Install fftw3 (v3.2.2 is tested) with "./configure --enable-threads --enable-float" and "make", "make install" is not needed # Install fftw3 (v3.2.2 is tested) with "./configure --enable-threads --enable-float" and "make", "make install" is not needed
# as long as the two library files are copied to the source code directory. # as long as the two library files are copied to the source code directory.
#standart values # OPTIONS = standart (alternative): meaning
PRECISION :=double # precision #-------------------------------------------------------------
F90 :=ifort # compiler (Intel or gfortran, default intel) # PRECISION = double (single): floating point precision
VERSION :=10 # version of intel compiler. More aggressive optimization if VERSION =12 # F90 = ifort (gfortran): compiler, choose Intel or GNU
PORTABLE :=TRUE # decision, if executable is optimized for the machine on which it was built # VERSION = 10 (12): version of Intel compiler. More aggressive optimization if VERSION =12
# PORTABLE = TRUE (FALSE): decision, if executable is optimized for the machine on which it was built
ifeq ($(PORTABLE), FALSE)
PORTABLE_SWITCH = -xHost
endif
ifeq ($(F90), ifort)
OPENMP_FLAG = -openmp
COMPILE_OPTIONS = -fpp -diag-disable 8291 #for preprocessor, switch of messages on formatting of output
OPTIMIZATION_AGGRESSIVE = -O3 -static $(PORTABLE_SWITCH)
endif
ifeq ($(F90), gfortran) ifeq ($(F90), gfortran)
OPENMP_FLAG := -fopenmp OPENMP_FLAG =-fopenmp
OPTIMIZATION_AGGRESSIVE = -O3 OPTIMIZATION_AGGRESSIVE =-O3
OPTIMIZATION_DEFENSIVE =-O2
COMPILE_OPTIONS =-xf95-cpp-input
#COMPILE_OPTIONS =
HEAP_ARRAYS =
else
F90 =ifort
ifeq ($(PORTABLE), FALSE)
PORTABLE_SWITCH =-xHost
endif endif
OPENMP_FLAG =-openmp
HEAP_ARRAYS =-heap-arrays 500000000
COMPILE_OPTIONS =-fpp -diag-disable 8291 #for preprocessor, switch off messages on formatting of output
OPTIMIZATION_AGGRESSIVE =-O3 -static $(PORTABLE_SWITCH)
ifeq ($(VERSION), 12) ifeq ($(VERSION), 12)
OPTIMIZATION_DEFENSIVE = -O3 -static $(PORTABLE_SWITCH) OPTIMIZATION_DEFENSIVE =$(OPTIMIZATION_AGGRESIVE)
else else
OPTIMIZATION_DEFENSIVE = -O2 OPTIMIZATION_DEFENSIVE =-O2
endif endif
endif
COMPILE = $(OPENMP_FLAG) $(COMPILE_OPTIONS) $(OPTIMIZATION_AGGRESSIVE) -c COMPILE = $(OPENMP_FLAG) $(COMPILE_OPTIONS) $(OPTIMIZATION_AGGRESSIVE) -c
COMPILE_HEAP = $(COMPILE) -heap-arrays 500000000 COMPILE_HEAP = $(COMPILE) $(HEAP_ARRAYS)
COMPILE_HEAP_DEFENSIVE = $(OPENMP_FLAG) $(COMPILE_OPTIONS) $(OPTIMIZATION_DEFENSIVE) -c -heap-arrays 500000000 COMPILE_HEAP_DEFENSIVE = $(OPENMP_FLAG) $(COMPILE_OPTIONS) $(OPTIMIZATION_DEFENSIVE) -c $(HEAP_ARRAYS)
ifeq ($(PRECISION),single) ifeq ($(PRECISION),single)

234
code/math.f90
View File

@ -29,7 +29,10 @@
real(pReal), parameter :: pi = 3.14159265358979323846264338327950288419716939937510_pReal real(pReal), parameter :: pi = 3.14159265358979323846264338327950288419716939937510_pReal
real(pReal), parameter :: inDeg = 180.0_pReal/pi real(pReal), parameter :: inDeg = 180.0_pReal/pi
real(pReal), parameter :: inRad = pi/180.0_pReal real(pReal), parameter :: inRad = pi/180.0_pReal
real(pReal), parameter :: NaN = 0.0_pReal/0.0_pReal ! Not a number real(pReal), dimension(3), parameter :: NaN = & ! taken from http://ftp.aset.psu.edu/pub/ger/fortran/hdk/nan.f90
(/B'01111111100000100000000000000000',& ! NaN
B'11111111100100010001001010101010',& ! NaN
B'11111111110000000000000000000000'/) ! 0/0
! *** 3x3 Identity *** ! *** 3x3 Identity ***
real(pReal), dimension(3,3), parameter :: math_I3 = & real(pReal), dimension(3,3), parameter :: math_I3 = &
reshape( (/ & reshape( (/ &
@ -146,14 +149,17 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
real(pReal), dimension(3,3) :: R,R2 real(pReal), dimension(3,3) :: R,R2
real(pReal), dimension(3) :: Eulers real(pReal), dimension(3) :: Eulers
real(pReal), dimension(4) :: q,q2,axisangle real(pReal), dimension(4) :: q,q2,axisangle
integer(pInt), dimension(1) :: randInit integer(pInt), dimension(8) :: randInit ! gfortran requires "8" to compile
! if recalculations of former randomness (with given seed) is necessary
! set this value back to "1" and use ifort...
!$OMP CRITICAL (write2out) !$OMP CRITICAL (write2out)
write(6,*) write(6,*)
write(6,*) '<<<+- math init -+>>>' write(6,*) '<<<+- math init -+>>>'
write(6,*) '$Id$' write(6,*) '$Id$'
write(6,*) write(6,*)
write(6,*) 'NaN check: ',NaN/=NaN
write(6,*)
!$OMP END CRITICAL (write2out) !$OMP END CRITICAL (write2out)
if (fixedSeed > 0_pInt) then if (fixedSeed > 0_pInt) then
@ -204,7 +210,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
call IO_error(673) call IO_error(673)
ENDSUBROUTINE ENDSUBROUTINE math_init
@ -225,9 +231,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
call qsort(a, istart, ipivot-1) call qsort(a, istart, ipivot-1)
call qsort(a, ipivot+1, iend) call qsort(a, ipivot+1, iend)
endif endif
return
ENDSUBROUTINE ENDSUBROUTINE qsort
!************************************************************************** !**************************************************************************
! Partitioning required for quicksort ! Partitioning required for quicksort
@ -271,7 +276,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
endif endif
enddo enddo
endfunction endfunction math_partition
!************************************************************************** !**************************************************************************
@ -287,9 +292,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
integer(pInt), dimension(N) :: math_range integer(pInt), dimension(N) :: math_range
forall (i=1:N) math_range(i) = i forall (i=1:N) math_range(i) = i
return
endfunction endfunction math_range
!************************************************************************** !**************************************************************************
! second rank identity tensor of specified dimension ! second rank identity tensor of specified dimension
@ -305,9 +309,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
math_identity2nd = 0.0_pReal math_identity2nd = 0.0_pReal
forall (i=1:dimen) math_identity2nd(i,i) = 1.0_pReal forall (i=1:dimen) math_identity2nd(i,i) = 1.0_pReal
return
endfunction endfunction math_identity2nd
!************************************************************************** !**************************************************************************
! permutation tensor e_ijk used for computing cross product of two tensors ! permutation tensor e_ijk used for computing cross product of two tensors
@ -331,9 +334,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
if (((i == 1).and.(j == 3).and.(k == 2)) .or. & if (((i == 1).and.(j == 3).and.(k == 2)) .or. &
((i == 2).and.(j == 1).and.(k == 3)) .or. & ((i == 2).and.(j == 1).and.(k == 3)) .or. &
((i == 3).and.(j == 2).and.(k == 1))) math_civita = -1.0_pReal ((i == 3).and.(j == 2).and.(k == 1))) math_civita = -1.0_pReal
return
endfunction endfunction math_civita
!************************************************************************** !**************************************************************************
! kronecker delta function d_ij ! kronecker delta function d_ij
@ -351,9 +353,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
math_delta = 0.0_pReal math_delta = 0.0_pReal
if (i == j) math_delta = 1.0_pReal if (i == j) math_delta = 1.0_pReal
return endfunction math_delta
endfunction
!************************************************************************** !**************************************************************************
! fourth rank identity tensor of specified dimension ! fourth rank identity tensor of specified dimension
@ -369,9 +369,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
forall (i=1:dimen,j=1:dimen,k=1:dimen,l=1:dimen) math_identity4th(i,j,k,l) = & forall (i=1:dimen,j=1:dimen,k=1:dimen,l=1:dimen) math_identity4th(i,j,k,l) = &
0.5_pReal*(math_I3(i,k)*math_I3(j,k)+math_I3(i,l)*math_I3(j,k)) 0.5_pReal*(math_I3(i,k)*math_I3(j,k)+math_I3(i,l)*math_I3(j,k))
return
endfunction endfunction math_identity4th
!************************************************************************** !**************************************************************************
@ -389,9 +388,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
math_vectorproduct(2) = A(3)*B(1)-A(1)*B(3) math_vectorproduct(2) = A(3)*B(1)-A(1)*B(3)
math_vectorproduct(3) = A(1)*B(2)-A(2)*B(1) math_vectorproduct(3) = A(1)*B(2)-A(2)*B(1)
return
endfunction endfunction math_vectorproduct
!************************************************************************** !**************************************************************************
@ -408,9 +406,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
forall (i=1:3,j=1:3) math_tensorproduct(i,j) = A(i)*B(j) forall (i=1:3,j=1:3) math_tensorproduct(i,j) = A(i)*B(j)
return
endfunction endfunction math_tensorproduct
!************************************************************************** !**************************************************************************
@ -429,9 +426,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
forall (i=1:3) C(i) = A(i)*B(i) forall (i=1:3) C(i) = A(i)*B(i)
math_mul3x3 = sum(C) math_mul3x3 = sum(C)
return endfunction math_mul3x3
endfunction
!************************************************************************** !**************************************************************************
@ -450,9 +445,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
forall (i=1:6) C(i) = A(i)*B(i) forall (i=1:6) C(i) = A(i)*B(i)
math_mul6x6 = sum(C) math_mul6x6 = sum(C)
return endfunction math_mul6x6
endfunction
!************************************************************************** !**************************************************************************
@ -470,9 +463,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
forall (i=1:3,j=1:3) C(i,j) = A(i,j) * B(i,j) forall (i=1:3,j=1:3) C(i,j) = A(i,j) * B(i,j)
math_mul33xx33 = sum(C) math_mul33xx33 = sum(C)
return
endfunction endfunction math_mul33xx33
!************************************************************************** !**************************************************************************
! matrix multiplication 3333x33 = 33 (double contraction --> ijkl *kl = ij) ! matrix multiplication 3333x33 = 33 (double contraction --> ijkl *kl = ij)
@ -491,9 +483,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
do j = 1,3 do j = 1,3
math_mul3333xx33(i,j) = sum(A(i,j,:,:)*B(:,:)) math_mul3333xx33(i,j) = sum(A(i,j,:,:)*B(:,:))
enddo; enddo enddo; enddo
return
endfunction endfunction math_mul3333xx33
!************************************************************************** !**************************************************************************
@ -510,9 +501,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
forall (i=1:3,j=1:3) math_mul33x33(i,j) = & forall (i=1:3,j=1:3) math_mul33x33(i,j) = &
A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j)
return
endfunction endfunction math_mul33x33
!************************************************************************** !**************************************************************************
@ -530,9 +520,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
forall (i=1:6,j=1:6) math_mul66x66(i,j) = & forall (i=1:6,j=1:6) math_mul66x66(i,j) = &
A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + & A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + &
A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j)
return
endfunction endfunction math_mul66x66
!************************************************************************** !**************************************************************************
@ -553,9 +542,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + & A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + &
A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) + & A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) + &
A(i,7)*B(7,j) + A(i,8)*B(8,j) + A(i,9)*B(9,j) A(i,7)*B(7,j) + A(i,8)*B(8,j) + A(i,9)*B(9,j)
return
endfunction endfunction math_mul99x99
!************************************************************************** !**************************************************************************
@ -572,9 +560,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
real(pReal), dimension(3) :: math_mul33x3 real(pReal), dimension(3) :: math_mul33x3
forall (i=1:3) math_mul33x3(i) = A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3) forall (i=1:3) math_mul33x3(i) = A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3)
return
endfunction endfunction math_mul33x3
!************************************************************************** !**************************************************************************
! matrix multiplication complex(33) x real(3) = complex(3) ! matrix multiplication complex(33) x real(3) = complex(3)
@ -590,9 +577,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
complex(pReal), dimension(3) :: math_mul33x3_complex complex(pReal), dimension(3) :: math_mul33x3_complex
forall (i=1:3) math_mul33x3_complex(i) = A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3) forall (i=1:3) math_mul33x3_complex(i) = A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3)
return
endfunction endfunction math_mul33x3_complex
!************************************************************************** !**************************************************************************
@ -611,9 +597,8 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
forall (i=1:6) math_mul66x6(i) = & forall (i=1:6) math_mul66x6(i) = &
A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3) + & A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3) + &
A(i,4)*B(4) + A(i,5)*B(5) + A(i,6)*B(6) A(i,4)*B(4) + A(i,5)*B(5) + A(i,6)*B(6)
return
endfunction endfunction math_mul66x6
!************************************************************************** !**************************************************************************
@ -633,7 +618,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
math_qRnd(3) = cos(2.0_pReal*pi*rnd(2))*sqrt(1.0_pReal-rnd(3)) math_qRnd(3) = cos(2.0_pReal*pi*rnd(2))*sqrt(1.0_pReal-rnd(3))
math_qRnd(4) = sin(2.0_pReal*pi*rnd(1))*sqrt(rnd(3)) math_qRnd(4) = sin(2.0_pReal*pi*rnd(1))*sqrt(rnd(3))
endfunction endfunction math_qRnd
!************************************************************************** !**************************************************************************
@ -652,7 +637,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
math_qMul(3) = A(1)*B(3) - A(2)*B(4) + A(3)*B(1) + A(4)*B(2) math_qMul(3) = A(1)*B(3) - A(2)*B(4) + A(3)*B(1) + A(4)*B(2)
math_qMul(4) = A(1)*B(4) + A(2)*B(3) - A(3)*B(2) + A(4)*B(1) math_qMul(4) = A(1)*B(4) + A(2)*B(3) - A(3)*B(2) + A(4)*B(1)
endfunction endfunction math_qMul
!************************************************************************** !**************************************************************************
@ -668,7 +653,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
math_qDot = A(1)*B(1) + A(2)*B(2) + A(3)*B(3) + A(4)*B(4) math_qDot = A(1)*B(1) + A(2)*B(2) + A(3)*B(3) + A(4)*B(4)
endfunction endfunction math_qDot
!************************************************************************** !**************************************************************************
@ -685,7 +670,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
math_qConj(1) = Q(1) math_qConj(1) = Q(1)
math_qConj(2:4) = -Q(2:4) math_qConj(2:4) = -Q(2:4)
endfunction endfunction math_qConj
!************************************************************************** !**************************************************************************
@ -701,7 +686,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
math_qNorm = sqrt(max(0.0_pReal, Q(1)*Q(1) + Q(2)*Q(2) + Q(3)*Q(3) + Q(4)*Q(4))) math_qNorm = sqrt(max(0.0_pReal, Q(1)*Q(1) + Q(2)*Q(2) + Q(3)*Q(3) + Q(4)*Q(4)))
endfunction endfunction math_qNorm
!************************************************************************** !**************************************************************************
@ -722,7 +707,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
if (squareNorm > tiny(squareNorm)) & if (squareNorm > tiny(squareNorm)) &
math_qInv = math_qConj(Q) / squareNorm math_qInv = math_qConj(Q) / squareNorm
endfunction endfunction math_qInv
!************************************************************************** !**************************************************************************
@ -751,7 +736,7 @@ real(pReal), dimension(4,36), parameter :: math_symOperations = &
math_qRot = 2.0_pReal * math_qRot + v math_qRot = 2.0_pReal * math_qRot + v
endfunction endfunction math_qRot
!************************************************************************** !**************************************************************************
@ -767,9 +752,8 @@ pure function math_transpose3x3(A)
integer(pInt) i,j integer(pInt) i,j
forall(i=1:3, j=1:3) math_transpose3x3(i,j) = A(j,i) forall(i=1:3, j=1:3) math_transpose3x3(i,j) = A(j,i)
return
endfunction endfunction math_transpose3x3
!************************************************************************** !**************************************************************************
@ -807,9 +791,8 @@ pure function math_transpose3x3(A)
math_inv3x3(2,3) = ( -A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / DetA math_inv3x3(2,3) = ( -A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / DetA
math_inv3x3(3,3) = ( A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / DetA math_inv3x3(3,3) = ( A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / DetA
endif endif
return
endfunction endfunction math_inv3x3
@ -854,9 +837,8 @@ pure function math_transpose3x3(A)
error = .false. error = .false.
endif endif
return
ENDSUBROUTINE ENDSUBROUTINE math_invert3x3
@ -888,7 +870,6 @@ pure function math_transpose3x3(A)
InvA = math_identity2nd(dimen) InvA = math_identity2nd(dimen)
B = A B = A
CALL Gauss(dimen,B,InvA,LogAbsDetA,AnzNegEW,error) CALL Gauss(dimen,B,InvA,LogAbsDetA,AnzNegEW,error)
RETURN
ENDSUBROUTINE math_invert ENDSUBROUTINE math_invert
@ -1058,8 +1039,6 @@ pure function math_transpose3x3(A)
error = .false. error = .false.
RETURN
ENDSUBROUTINE Gauss ENDSUBROUTINE Gauss
@ -1077,7 +1056,7 @@ pure function math_transpose3x3(A)
forall (i=1:3,j=1:3) math_symmetric3x3(i,j) = 0.5_pReal * (m(i,j) + m(j,i)) forall (i=1:3,j=1:3) math_symmetric3x3(i,j) = 0.5_pReal * (m(i,j) + m(j,i))
endfunction endfunction math_symmetric3x3
!******************************************************************** !********************************************************************
@ -1094,7 +1073,7 @@ pure function math_transpose3x3(A)
forall (i=1:6,j=1:6) math_symmetric6x6(i,j) = 0.5_pReal * (m(i,j) + m(j,i)) forall (i=1:6,j=1:6) math_symmetric6x6(i,j) = 0.5_pReal * (m(i,j) + m(j,i))
endfunction endfunction math_symmetric6x6
!******************************************************************** !********************************************************************
@ -1117,9 +1096,8 @@ pure function math_transpose3x3(A)
math_equivStrain33 = 2.0_pReal*(1.50_pReal*(e11**2.0_pReal+e22**2.0_pReal+e33**2.0_pReal) + & math_equivStrain33 = 2.0_pReal*(1.50_pReal*(e11**2.0_pReal+e22**2.0_pReal+e33**2.0_pReal) + &
0.75_pReal*(s12**2.0_pReal+s23**2.0_pReal+s31**2.0_pReal))**(0.5_pReal)/3.0_pReal 0.75_pReal*(s12**2.0_pReal+s23**2.0_pReal+s31**2.0_pReal))**(0.5_pReal)/3.0_pReal
return
endfunction endfunction math_equivStrain33
!******************************************************************** !********************************************************************
@ -1136,9 +1114,8 @@ pure function math_transpose3x3(A)
math_det3x3 = m(1,1)*(m(2,2)*m(3,3)-m(2,3)*m(3,2)) & math_det3x3 = m(1,1)*(m(2,2)*m(3,3)-m(2,3)*m(3,2)) &
-m(1,2)*(m(2,1)*m(3,3)-m(2,3)*m(3,1)) & -m(1,2)*(m(2,1)*m(3,3)-m(2,3)*m(3,1)) &
+m(1,3)*(m(2,1)*m(3,2)-m(2,2)*m(3,1)) +m(1,3)*(m(2,1)*m(3,2)-m(2,2)*m(3,1))
return
endfunction endfunction math_det3x3
!******************************************************************** !********************************************************************
@ -1169,9 +1146,8 @@ pure function math_transpose3x3(A)
real(pReal) math_norm3 real(pReal) math_norm3
math_norm3 = sqrt(v(1)*v(1) + v(2)*v(2) + v(3)*v(3)) math_norm3 = sqrt(v(1)*v(1) + v(2)*v(2) + v(3)*v(3))
return
endfunction endfunction math_norm3
!******************************************************************** !********************************************************************
@ -1187,9 +1163,8 @@ pure function math_transpose3x3(A)
integer(pInt) i integer(pInt) i
forall (i=1:9) math_Plain33to9(i) = m33(mapPlain(1,i),mapPlain(2,i)) forall (i=1:9) math_Plain33to9(i) = m33(mapPlain(1,i),mapPlain(2,i))
return
endfunction endfunction math_Plain33to9
!******************************************************************** !********************************************************************
@ -1205,9 +1180,8 @@ pure function math_transpose3x3(A)
integer(pInt) i integer(pInt) i
forall (i=1:9) math_Plain9to33(mapPlain(1,i),mapPlain(2,i)) = v9(i) forall (i=1:9) math_Plain9to33(mapPlain(1,i),mapPlain(2,i)) = v9(i)
return
endfunction endfunction math_Plain9to33
!******************************************************************** !********************************************************************
@ -1223,9 +1197,8 @@ pure function math_transpose3x3(A)
integer(pInt) i integer(pInt) i
forall (i=1:6) math_Mandel33to6(i) = nrmMandel(i)*m33(mapMandel(1,i),mapMandel(2,i)) forall (i=1:6) math_Mandel33to6(i) = nrmMandel(i)*m33(mapMandel(1,i),mapMandel(2,i))
return
endfunction endfunction math_Mandel33to6
!******************************************************************** !********************************************************************
@ -1244,9 +1217,8 @@ pure function math_transpose3x3(A)
math_Mandel6to33(mapMandel(1,i),mapMandel(2,i)) = invnrmMandel(i)*v6(i) math_Mandel6to33(mapMandel(1,i),mapMandel(2,i)) = invnrmMandel(i)*v6(i)
math_Mandel6to33(mapMandel(2,i),mapMandel(1,i)) = invnrmMandel(i)*v6(i) math_Mandel6to33(mapMandel(2,i),mapMandel(1,i)) = invnrmMandel(i)*v6(i)
end forall end forall
return
endfunction endfunction math_Mandel6to33
!******************************************************************** !********************************************************************
@ -1263,9 +1235,8 @@ pure function math_transpose3x3(A)
forall (i=1:9,j=1:9) math_Plain3333to99(i,j) = & forall (i=1:9,j=1:9) math_Plain3333to99(i,j) = &
m3333(mapPlain(1,i),mapPlain(2,i),mapPlain(1,j),mapPlain(2,j)) m3333(mapPlain(1,i),mapPlain(2,i),mapPlain(1,j),mapPlain(2,j))
return
endfunction endfunction math_Plain3333to99
!******************************************************************** !********************************************************************
! plain matrix 9x9 into 3x3x3x3 tensor ! plain matrix 9x9 into 3x3x3x3 tensor
@ -1281,9 +1252,8 @@ pure function math_transpose3x3(A)
forall (i=1:9,j=1:9) math_Plain99to3333(mapPlain(1,i),mapPlain(2,i),& forall (i=1:9,j=1:9) math_Plain99to3333(mapPlain(1,i),mapPlain(2,i),&
mapPlain(1,j),mapPlain(2,j)) = m99(i,j) mapPlain(1,j),mapPlain(2,j)) = m99(i,j)
return
endfunction endfunction math_Plain99to3333
!******************************************************************** !********************************************************************
@ -1340,9 +1310,8 @@ pure function math_transpose3x3(A)
forall (i=1:6,j=1:6) math_Mandel3333to66(i,j) = & forall (i=1:6,j=1:6) math_Mandel3333to66(i,j) = &
nrmMandel(i)*nrmMandel(j)*m3333(mapMandel(1,i),mapMandel(2,i),mapMandel(1,j),mapMandel(2,j)) nrmMandel(i)*nrmMandel(j)*m3333(mapMandel(1,i),mapMandel(2,i),mapMandel(1,j),mapMandel(2,j))
return
endfunction endfunction math_Mandel3333to66
@ -1364,9 +1333,8 @@ pure function math_transpose3x3(A)
math_Mandel66to3333(mapMandel(1,i),mapMandel(2,i),mapMandel(2,j),mapMandel(1,j)) = invnrmMandel(i)*invnrmMandel(j)*m66(i,j) math_Mandel66to3333(mapMandel(1,i),mapMandel(2,i),mapMandel(2,j),mapMandel(1,j)) = invnrmMandel(i)*invnrmMandel(j)*m66(i,j)
math_Mandel66to3333(mapMandel(2,i),mapMandel(1,i),mapMandel(2,j),mapMandel(1,j)) = invnrmMandel(i)*invnrmMandel(j)*m66(i,j) math_Mandel66to3333(mapMandel(2,i),mapMandel(1,i),mapMandel(2,j),mapMandel(1,j)) = invnrmMandel(i)*invnrmMandel(j)*m66(i,j)
end forall end forall
return
endfunction endfunction math_Mandel66to3333
@ -1388,9 +1356,8 @@ pure function math_transpose3x3(A)
math_Voigt66to3333(mapVoigt(1,i),mapVoigt(2,i),mapVoigt(2,j),mapVoigt(1,j)) = invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) math_Voigt66to3333(mapVoigt(1,i),mapVoigt(2,i),mapVoigt(2,j),mapVoigt(1,j)) = invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j)
math_Voigt66to3333(mapVoigt(2,i),mapVoigt(1,i),mapVoigt(2,j),mapVoigt(1,j)) = invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) math_Voigt66to3333(mapVoigt(2,i),mapVoigt(1,i),mapVoigt(2,j),mapVoigt(1,j)) = invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j)
end forall end forall
return
endfunction endfunction math_Voigt66to3333
@ -1443,9 +1410,8 @@ pure function math_transpose3x3(A)
math_RtoEuler(1) = acos(val) math_RtoEuler(1) = acos(val)
if(R(3,1) < 0.0) math_RtoEuler(1) = 2.0_pReal*pi-math_RtoEuler(1) if(R(3,1) < 0.0) math_RtoEuler(1) = 2.0_pReal*pi-math_RtoEuler(1)
end if end if
return
endfunction endfunction math_RtoEuler
!******************************************************************** !********************************************************************
@ -1503,15 +1469,13 @@ pure function math_transpose3x3(A)
math_RtoQuaternion = math_RtoQuaternion*0.25_pReal/max_absQ math_RtoQuaternion = math_RtoQuaternion*0.25_pReal/max_absQ
math_RtoQuaternion(largest(1)) = max_absQ math_RtoQuaternion(largest(1)) = max_absQ
return endfunction math_RtoQuaternion
endfunction
!**************************************************************** !****************************************************************
! rotation matrix from Euler angles (in radians) ! rotation matrix from Euler angles (in radians)
!**************************************************************** !****************************************************************
pure function math_EulerToR (Euler) pure function math_EulerToR(Euler)
use prec, only: pReal, pInt use prec, only: pReal, pInt
implicit none implicit none
@ -1535,9 +1499,8 @@ pure function math_transpose3x3(A)
math_EulerToR(3,1)=S1*S math_EulerToR(3,1)=S1*S
math_EulerToR(3,2)=-C1*S math_EulerToR(3,2)=-C1*S
math_EulerToR(3,3)=C math_EulerToR(3,3)=C
return
endfunction endfunction math_EulerToR
!******************************************************************** !********************************************************************
@ -1563,7 +1526,7 @@ pure function math_transpose3x3(A)
math_EulerToQuaternion(3) = sin(halfangles(1)-halfangles(3)) * s math_EulerToQuaternion(3) = sin(halfangles(1)-halfangles(3)) * s
math_EulerToQuaternion(4) = sin(halfangles(1)+halfangles(3)) * c math_EulerToQuaternion(4) = sin(halfangles(1)+halfangles(3)) * c
endfunction endfunction math_EulerToQuaternion
!**************************************************************** !****************************************************************
@ -1607,9 +1570,8 @@ pure function math_transpose3x3(A)
math_AxisAngleToR = math_I3 math_AxisAngleToR = math_I3
endif endif
return
endfunction endfunction math_AxisAngleToR
!**************************************************************** !****************************************************************
@ -1639,9 +1601,8 @@ pure function math_transpose3x3(A)
math_AxisAngleToQuaternion = (/1.0_pReal,0.0_pReal,0.0_pReal,0.0_pReal/) ! no rotation math_AxisAngleToQuaternion = (/1.0_pReal,0.0_pReal,0.0_pReal,0.0_pReal/) ! no rotation
endif endif
return
endfunction endfunction math_AxisAngleToQuaternion
!******************************************************************** !********************************************************************
@ -1666,9 +1627,8 @@ pure function math_transpose3x3(A)
2.0_pReal * T - & 2.0_pReal * T - &
2.0_pReal * Q(1) * S 2.0_pReal * Q(1) * S
return
endfunction endfunction math_QuaternionToR
!******************************************************************** !********************************************************************
@ -1704,9 +1664,7 @@ pure function math_transpose3x3(A)
if (math_QuaternionToEuler(2) < 0.0_pReal) & if (math_QuaternionToEuler(2) < 0.0_pReal) &
math_QuaternionToEuler(2) = math_QuaternionToEuler(2) + pi math_QuaternionToEuler(2) = math_QuaternionToEuler(2) + pi
return endfunction math_QuaternionToEuler
endfunction
!******************************************************************** !********************************************************************
@ -1731,9 +1689,8 @@ pure function math_transpose3x3(A)
math_QuaternionToAxisAngle(4) = halfAngle*2.0_pReal math_QuaternionToAxisAngle(4) = halfAngle*2.0_pReal
endif endif
return
endfunction endfunction math_QuaternionToAxisAngle
!******************************************************************** !********************************************************************
@ -1750,12 +1707,11 @@ pure function math_transpose3x3(A)
if (Q(1) /= 0.0_pReal) then ! unless rotation by 180 deg if (Q(1) /= 0.0_pReal) then ! unless rotation by 180 deg
math_QuaternionToRodrig = Q(2:4)/Q(1) math_QuaternionToRodrig = Q(2:4)/Q(1)
else else
math_QuaternionToRodrig = NaN ! Rodrig is unbound for 180 deg... math_QuaternionToRodrig = NaN(3) ! 0/0, since Rodrig is unbound for 180 deg...
endif endif
return
endfunction endfunction math_QuaternionToRodrig
!************************************************************************** !**************************************************************************
@ -1774,9 +1730,8 @@ pure function math_transpose3x3(A)
tr = (r(1,1)+r(2,2)+r(3,3)-1.0_pReal)*0.4999999_pReal tr = (r(1,1)+r(2,2)+r(3,3)-1.0_pReal)*0.4999999_pReal
math_EulerMisorientation = abs(0.5_pReal*pi-asin(tr)) math_EulerMisorientation = abs(0.5_pReal*pi-asin(tr))
return
endfunction endfunction math_EulerMisorientation
!************************************************************************** !**************************************************************************
@ -1811,7 +1766,7 @@ pure function math_QuaternionInSST(Q, symmetryType)
math_QuaternionInSST = .true. math_QuaternionInSST = .true.
end select end select
endfunction endfunction math_QuaternionInSST
!************************************************************************** !**************************************************************************
@ -1862,8 +1817,7 @@ function math_QuaternionDisorientation(Q1, Q2, symmetryType)
call IO_error(550,symmetryType) ! complain about unknown symmetry call IO_error(550,symmetryType) ! complain about unknown symmetry
end select end select
endfunction math_QuaternionDisorientation
endfunction
!******************************************************************** !********************************************************************
@ -1880,9 +1834,8 @@ endfunction
math_sampleRandomOri(1) = rnd(1)*2.0_pReal*pi math_sampleRandomOri(1) = rnd(1)*2.0_pReal*pi
math_sampleRandomOri(2) = acos(2.0_pReal*rnd(2)-1.0_pReal) math_sampleRandomOri(2) = acos(2.0_pReal*rnd(2)-1.0_pReal)
math_sampleRandomOri(3) = rnd(3)*2.0_pReal*pi math_sampleRandomOri(3) = rnd(3)*2.0_pReal*pi
return
endfunction endfunction math_sampleRandomOri
!******************************************************************** !********************************************************************
@ -1921,9 +1874,7 @@ endif
math_sampleGaussOri = math_RtoEuler(math_mul33x33(math_EulerToR(disturb),math_EulerToR(center))) math_sampleGaussOri = math_RtoEuler(math_mul33x33(math_EulerToR(disturb),math_EulerToR(center)))
return endfunction math_sampleGaussOri
endfunction
!******************************************************************** !********************************************************************
@ -1996,9 +1947,7 @@ endif
! ---# apply the three rotations #--- ! ---# apply the three rotations #---
math_sampleFiberOri = math_RtoEuler(math_mul33x33(pRot,math_mul33x33(fRot,oRot))) math_sampleFiberOri = math_RtoEuler(math_mul33x33(pRot,math_mul33x33(fRot,oRot)))
return endfunction math_sampleFiberOri
endfunction
@ -2040,9 +1989,8 @@ endif
math_symmetricEulers = 0.0_pReal math_symmetricEulers = 0.0_pReal
end select end select
return
endfunction endfunction math_symmetricEulers
@ -2087,7 +2035,7 @@ enddo
math_sampleGaussVar = scatter * stddev math_sampleGaussVar = scatter * stddev
endfunction endfunction math_sampleGaussVar
@ -2111,9 +2059,8 @@ endfunction
call math_invert3x3(U,UI,det,error) call math_invert3x3(U,UI,det,error)
if (.not. error) R = math_mul33x33(FE,UI) if (.not. error) R = math_mul33x33(FE,UI)
return
ENDSUBROUTINE ENDSUBROUTINE math_pDecomposition
!********************************************************************** !**********************************************************************
@ -2208,8 +2155,8 @@ endfunction
END IF END IF
END IF END IF
RETURN
ENDSUBROUTINE ENDSUBROUTINE math_spectral1
!********************************************************************** !**********************************************************************
@ -2226,9 +2173,8 @@ endfunction
HI2M=HI1M**2/2.0_pReal-(M(1,1)**2+M(2,2)**2+M(3,3)**2)/2.0_pReal-M(1,2)*M(2,1)-M(1,3)*M(3,1)-M(2,3)*M(3,2) HI2M=HI1M**2/2.0_pReal-(M(1,1)**2+M(2,2)**2+M(3,3)**2)/2.0_pReal-M(1,2)*M(2,1)-M(1,3)*M(3,1)-M(2,3)*M(3,2)
HI3M=math_det3x3(M) HI3M=math_det3x3(M)
! QUESTION: is 3rd equiv det(M) ?? if yes, use function math_det !agreed on YES ! QUESTION: is 3rd equiv det(M) ?? if yes, use function math_det !agreed on YES
return
ENDSUBROUTINE ENDSUBROUTINE math_hi
SUBROUTINE get_seed(seed) SUBROUTINE get_seed(seed)
@ -2305,9 +2251,8 @@ endfunction
seed = seed - 1 seed = seed - 1
end if end if
return
ENDSUBROUTINE ENDSUBROUTINE get_seed
subroutine halton ( ndim, r ) subroutine halton ( ndim, r )
@ -2360,9 +2305,8 @@ endfunction
value(1) = 1 value(1) = 1
call halton_memory ( 'INC', 'SEED', 1, value ) call halton_memory ( 'INC', 'SEED', 1, value )
return
ENDSUBROUTINE ENDSUBROUTINE halton
subroutine halton_memory ( action, name, ndim, value ) subroutine halton_memory ( action, name, ndim, value )
@ -2490,9 +2434,8 @@ endfunction
end if end if
end if end if
return
ENDSUBROUTINE ENDSUBROUTINE halton_memory
subroutine halton_ndim_set ( ndim ) subroutine halton_ndim_set ( ndim )
@ -2531,9 +2474,8 @@ endfunction
value(1) = ndim value(1) = ndim
call halton_memory ( 'SET', 'NDIM', 1, value ) call halton_memory ( 'SET', 'NDIM', 1, value )
return
ENDSUBROUTINE ENDSUBROUTINE halton_ndim_set
subroutine halton_seed_set ( seed ) subroutine halton_seed_set ( seed )
@ -2588,9 +2530,8 @@ endfunction
value(1) = seed value(1) = seed
call halton_memory ( 'SET', 'SEED', ndim, value ) call halton_memory ( 'SET', 'SEED', ndim, value )
return
ENDSUBROUTINE ENDSUBROUTINE halton_seed_set
subroutine i_to_halton ( seed, base, ndim, r ) subroutine i_to_halton ( seed, base, ndim, r )
@ -2678,9 +2619,8 @@ endfunction
seed2(1:ndim) = seed2(1:ndim) / base(1:ndim) seed2(1:ndim) = seed2(1:ndim) / base(1:ndim)
enddo enddo
return
ENDSUBROUTINE ENDSUBROUTINE i_to_halton
function prime ( n ) function prime ( n )
@ -2946,9 +2886,7 @@ endfunction
stop stop
end if end if
return endfunction prime
endfunction
!************************************************************************** !**************************************************************************
! volume of tetrahedron given by four vertices ! volume of tetrahedron given by four vertices
@ -2967,10 +2905,8 @@ endfunction
m(:,3) = v3-v4 m(:,3) = v3-v4
math_volTetrahedron = math_det3x3(m)/6.0_pReal math_volTetrahedron = math_det3x3(m)/6.0_pReal
return
endfunction
endfunction math_volTetrahedron
END MODULE math END MODULE math

94
documentation/Code/Fortran/nan.f90 Normal file
View File

@ -0,0 +1,94 @@
program nantest
! This file: http://ftp.aset.psu.edu/pub/ger/fortran/hdk/nan.f90
!
!====NAN.F90 illustrates what works and what doesn't when
! detecting a NaN. All but the Fortran 2003 IEEE_IS_NAN are not
! Standard Fortran.
!
! Platforms: Windows 9x/Me/NT/2000, AIX 4.3, Linux
! Compiler Notes:
! Compaq Visual Fortran 6.6C with default
! fpe settings (/fpe:3 /nocheck) and /OPTIMIZE:0
! (ISNAN is an Elemental Intrinsic Function)
! Options /fpe:0 /traceback will cause this
! program to stop with error message,
! James Giles points out that in order to actually print
! minus zero from CVF, you have to compile with the
! /assume:minus0 option.
!
! AIX XLF90 without optimization.
! (ISNAN is part of a BOS Runtime C library;
! thus ISNAN must be declared LOGICAL.)
!
! Linux Intel IFORT, use: -O0 (no optimization) and
! -assume minus0
!
! g95 supports ieee_is_nan elemental function.
!
!
! Author: hdkLESS at SPAM psu dot edu
! Date: March, 2002, January 2005, August 2006.
!
! References:
! http://www.psc.edu/general/software/packages/ieee/ieee.html
! http://homepages.borland.com/efg2lab/Mathematics/NaN.htm
! http://en.wikipedia.org/wiki/NaN
!
logical :: ISNAN
integer :: i
integer, Dimension (6) :: Iy
real, Dimension (6) :: y
integer :: IPInf, IMinf, IMZero
real :: PInf, MInf, MZero, DivNan
Character (Len=10), Dimension(6) :: NType
data NType/'+Infinity','-Infinity','-0', 'NaN','NaN','0/0'/
data IPInf/B'01111111100000000000000000000000'/ ! +Infinity
data IMInf/B'11111111100000000000000000000000'/ ! -Infinity
data IMZero/B'10000000000000000000000000000000'/ ! -0
data Iy(1)/B'01111111100000000000000000000000'/ ! +Infinity
data Iy(2)/B'11111111100000000000000000000000'/ ! -Infinity
data Iy(3)/B'10000000000000000000000000000000'/ ! -0
data Iy(4)/B'01111111100000100000000000000000'/ ! NaN
data Iy(5)/B'11111111100100010001001010101010'/ ! NaN
data Iy(6)/B'11111111110000000000000000000000'/ ! 0/0
PInf = transfer(IPinf,Pinf)
Minf = transfer(IMinf,Minf)
MZero = transfer(IMZero,MZero)
Y = transfer(IY,Y)
! Some debug options for some compilers may flag the following
! zero/zero as an exception. If so, comment out the next two lines.
DivNan=0
y(6)=DivNan/DivNan
Do i=1,6
print *, 'Test#',i,' ->',NType(i)
if (y(i).eq.PInf) print *, 'Y = Plus Infinity'
if (y(i).eq.MInf) print *, 'Y = Minus Infinity'
if (y(i).eq.Mzero) print *, 'Y = Minus Zero'
print *, 'y(Test#)=',y(i)
print *, 'Testing each of three NaN detection methods:'
! EQV -> true iff both A and B are True or iff both A and B are False.
if( (y(i) > 0.0) .EQV. (y(i) <= 0.0)) then
print *, '1) (y(Test#) > 0.0) .EQV. (y(Test#) <= 0.0)'
end if
if (y(i)/=y(i)) then
print *, '2) (y(Test#)/=(y(Test#))'
end if
! If ISNAN is available for a specific compiler, uncomment the
! following 3 lines.
! if (ISNAN(y(i))) then
! print *, '3) ISNAN(y(Test#))'
! end if
! if Fortran 2003 IEEE floating-point exception handling is available
! uncomment the following 4 lines
! use ieee_arithmetic
! if (ieee_is_nan(y(i))) then
! print *, '4) ieee_is_nan(y(Test#))'
! end if
print *, ' '
End Do
end program nantest