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

use 'error stop' 

- does not require IO
- prints stack trace
This commit is contained in:
Martin Diehl 2020-09-13 12:09:32 +02:00
parent 16f8df3420
commit 5b83c8ad3c
10 changed files with 225 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/HDF5_utilities.f90
View File

@ -98,12 +98,12 @@ subroutine HDF5_utilities_init
call h5tget_size_f(H5T_NATIVE_INTEGER,typeSize, hdferr) call h5tget_size_f(H5T_NATIVE_INTEGER,typeSize, hdferr)
if (hdferr < 0) call IO_error(1,ext_msg='HDF5_Utilities_init: h5tget_size_f (int)') if (hdferr < 0) call IO_error(1,ext_msg='HDF5_Utilities_init: h5tget_size_f (int)')
if (int(bit_size(0),SIZE_T)/=typeSize*8) & if (int(bit_size(0),SIZE_T)/=typeSize*8) &
call IO_error(0,ext_msg='Default integer size does not match H5T_NATIVE_INTEGER') error stop 'Default integer size does not match H5T_NATIVE_INTEGER'
call h5tget_size_f(H5T_NATIVE_DOUBLE,typeSize, hdferr) call h5tget_size_f(H5T_NATIVE_DOUBLE,typeSize, hdferr)
if (hdferr < 0) call IO_error(1,ext_msg='HDF5_Utilities_init: h5tget_size_f (double)') if (hdferr < 0) call IO_error(1,ext_msg='HDF5_Utilities_init: h5tget_size_f (double)')
if (int(storage_size(0.0_pReal),SIZE_T)/=typeSize*8) & if (int(storage_size(0.0_pReal),SIZE_T)/=typeSize*8) &
call IO_error(0,ext_msg='pReal does not match H5T_NATIVE_DOUBLE') error stop 'pReal does not match H5T_NATIVE_DOUBLE'
end subroutine HDF5_utilities_init end subroutine HDF5_utilities_init

50
src/IO.f90
View File

@ -657,49 +657,49 @@ subroutine selfTest
integer, dimension(:), allocatable :: chunkPos integer, dimension(:), allocatable :: chunkPos
character(len=:), allocatable :: str character(len=:), allocatable :: str
if(dNeq(1.0_pReal, IO_stringAsFloat('1.0'))) call IO_error(0,ext_msg='IO_stringAsFloat') if(dNeq(1.0_pReal, IO_stringAsFloat('1.0'))) error stop 'IO_stringAsFloat'
if(dNeq(1.0_pReal, IO_stringAsFloat('1e0'))) call IO_error(0,ext_msg='IO_stringAsFloat') if(dNeq(1.0_pReal, IO_stringAsFloat('1e0'))) error stop 'IO_stringAsFloat'
if(dNeq(0.1_pReal, IO_stringAsFloat('1e-1'))) call IO_error(0,ext_msg='IO_stringAsFloat') if(dNeq(0.1_pReal, IO_stringAsFloat('1e-1'))) error stop 'IO_stringAsFloat'
if(3112019 /= IO_stringAsInt( '3112019')) call IO_error(0,ext_msg='IO_stringAsInt') if(3112019 /= IO_stringAsInt( '3112019')) error stop 'IO_stringAsInt'
if(3112019 /= IO_stringAsInt(' 3112019')) call IO_error(0,ext_msg='IO_stringAsInt') if(3112019 /= IO_stringAsInt(' 3112019')) error stop 'IO_stringAsInt'
if(-3112019 /= IO_stringAsInt('-3112019')) call IO_error(0,ext_msg='IO_stringAsInt') if(-3112019 /= IO_stringAsInt('-3112019')) error stop 'IO_stringAsInt'
if(3112019 /= IO_stringAsInt('+3112019 ')) call IO_error(0,ext_msg='IO_stringAsInt') if(3112019 /= IO_stringAsInt('+3112019 ')) error stop 'IO_stringAsInt'
if(.not. IO_stringAsBool(' true')) call IO_error(0,ext_msg='IO_stringAsBool') if(.not. IO_stringAsBool(' true')) error stop 'IO_stringAsBool'
if(.not. IO_stringAsBool(' True ')) call IO_error(0,ext_msg='IO_stringAsBool') if(.not. IO_stringAsBool(' True ')) error stop 'IO_stringAsBool'
if( IO_stringAsBool(' false')) call IO_error(0,ext_msg='IO_stringAsBool') if( IO_stringAsBool(' false')) error stop 'IO_stringAsBool'
if( IO_stringAsBool('False')) call IO_error(0,ext_msg='IO_stringAsBool') if( IO_stringAsBool('False')) error stop 'IO_stringAsBool'
if(any([1,1,1] /= IO_stringPos('a'))) call IO_error(0,ext_msg='IO_stringPos') if(any([1,1,1] /= IO_stringPos('a'))) error stop 'IO_stringPos'
if(any([2,2,3,5,5] /= IO_stringPos(' aa b'))) call IO_error(0,ext_msg='IO_stringPos') if(any([2,2,3,5,5] /= IO_stringPos(' aa b'))) error stop 'IO_stringPos'
str=' 1.0 xxx' str=' 1.0 xxx'
chunkPos = IO_stringPos(str) chunkPos = IO_stringPos(str)
if(dNeq(1.0_pReal,IO_floatValue(str,chunkPos,1))) call IO_error(0,ext_msg='IO_floatValue') if(dNeq(1.0_pReal,IO_floatValue(str,chunkPos,1))) error stop 'IO_floatValue'
str='M 3112019 F' str='M 3112019 F'
chunkPos = IO_stringPos(str) chunkPos = IO_stringPos(str)
if(3112019 /= IO_intValue(str,chunkPos,2)) call IO_error(0,ext_msg='IO_intValue') if(3112019 /= IO_intValue(str,chunkPos,2)) error stop 'IO_intValue'
if(.not. IO_isBlank(' ')) call IO_error(0,ext_msg='IO_isBlank/1') if(.not. IO_isBlank(' ')) error stop 'IO_isBlank/1'
if(.not. IO_isBlank(' #isBlank')) call IO_error(0,ext_msg='IO_isBlank/2') if(.not. IO_isBlank(' #isBlank')) error stop 'IO_isBlank/2'
if( IO_isBlank(' i#s')) call IO_error(0,ext_msg='IO_isBlank/3') if( IO_isBlank(' i#s')) error stop 'IO_isBlank/3'
str = IO_rmComment('#') str = IO_rmComment('#')
if (str /= '' .or. len(str) /= 0) call IO_error(0,ext_msg='IO_rmComment/1') if (str /= '' .or. len(str) /= 0) error stop 'IO_rmComment/1'
str = IO_rmComment(' #') str = IO_rmComment(' #')
if (str /= '' .or. len(str) /= 0) call IO_error(0,ext_msg='IO_rmComment/2') if (str /= '' .or. len(str) /= 0) error stop 'IO_rmComment/2'
str = IO_rmComment(' # ') str = IO_rmComment(' # ')
if (str /= '' .or. len(str) /= 0) call IO_error(0,ext_msg='IO_rmComment/3') if (str /= '' .or. len(str) /= 0) error stop 'IO_rmComment/3'
str = IO_rmComment(' # a') str = IO_rmComment(' # a')
if (str /= '' .or. len(str) /= 0) call IO_error(0,ext_msg='IO_rmComment/4') if (str /= '' .or. len(str) /= 0) error stop 'IO_rmComment/4'
str = IO_rmComment(' # a') str = IO_rmComment(' # a')
if (str /= '' .or. len(str) /= 0) call IO_error(0,ext_msg='IO_rmComment/5') if (str /= '' .or. len(str) /= 0) error stop 'IO_rmComment/5'
str = IO_rmComment(' a#') str = IO_rmComment(' a#')
if (str /= ' a' .or. len(str) /= 2) call IO_error(0,ext_msg='IO_rmComment/6') if (str /= ' a' .or. len(str) /= 2) error stop 'IO_rmComment/6'
str = IO_rmComment(' ab #') str = IO_rmComment(' ab #')
if (str /= ' ab'.or. len(str) /= 3) call IO_error(0,ext_msg='IO_rmComment/7') if (str /= ' ab'.or. len(str) /= 3) error stop 'IO_rmComment/7'
end subroutine selfTest end subroutine selfTest

68
src/YAML_parse.f90
View File

@ -398,7 +398,7 @@ recursive subroutine lst(blck,flow,s_blck,s_flow,offset)
if(isScalar(line) .or. isFlow(line)) then if(isScalar(line) .or. isFlow(line)) then
flow(s_flow:s_flow+1) = ', ' flow(s_flow:s_flow+1) = ', '
s_flow = s_flow +2 s_flow = s_flow + 2
endif endif
end do end do
@ -558,37 +558,39 @@ end function to_flow
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine selfTest() !> @brief Check correctness of some YAML functions.
!--------------------------------------------------------------------------------------------------
subroutine selfTest
if (indentDepth(' a') /= 1) call IO_error(0,ext_msg='indentDepth') if (indentDepth(' a') /= 1) error stop 'indentDepth'
if (indentDepth('a') /= 0) call IO_error(0,ext_msg='indentDepth') if (indentDepth('a') /= 0) error stop 'indentDepth'
if (indentDepth('x ') /= 0) call IO_error(0,ext_msg='indentDepth') if (indentDepth('x ') /= 0) error stop 'indentDepth'
if ( isFlow(' a')) call IO_error(0,ext_msg='isFLow') if ( isFlow(' a')) error stop 'isFLow'
if (.not. isFlow('{')) call IO_error(0,ext_msg='isFlow') if (.not. isFlow('{')) error stop 'isFlow'
if (.not. isFlow(' [')) call IO_error(0,ext_msg='isFlow') if (.not. isFlow(' [')) error stop 'isFlow'
if ( isListItem(' a')) call IO_error(0,ext_msg='isListItem') if ( isListItem(' a')) error stop 'isListItem'
if ( isListItem(' -b')) call IO_error(0,ext_msg='isListItem') if ( isListItem(' -b')) error stop 'isListItem'
if (.not. isListItem('- a ')) call IO_error(0,ext_msg='isListItem') if (.not. isListItem('- a ')) error stop 'isListItem'
if (.not. isListItem('- -a ')) call IO_error(0,ext_msg='isListItem') if (.not. isListItem('- -a ')) error stop 'isListItem'
if ( isKeyValue(' a')) call IO_error(0,ext_msg='isKeyValue') if ( isKeyValue(' a')) error stop 'isKeyValue'
if ( isKeyValue(' a: ')) call IO_error(0,ext_msg='isKeyValue') if ( isKeyValue(' a: ')) error stop 'isKeyValue'
if (.not. isKeyValue(' a: b')) call IO_error(0,ext_msg='isKeyValue') if (.not. isKeyValue(' a: b')) error stop 'isKeyValue'
if ( isKey(' a')) call IO_error(0,ext_msg='isKey') if ( isKey(' a')) error stop 'isKey'
if ( isKey('{a:b}')) call IO_error(0,ext_msg='isKey') if ( isKey('{a:b}')) error stop 'isKey'
if ( isKey(' a:b')) call IO_error(0,ext_msg='isKey') if ( isKey(' a:b')) error stop 'isKey'
if (.not. isKey(' a: ')) call IO_error(0,ext_msg='isKey') if (.not. isKey(' a: ')) error stop 'isKey'
if (.not. isKey(' a:')) call IO_error(0,ext_msg='isKey') if (.not. isKey(' a:')) error stop 'isKey'
if (.not. isKey(' a: #')) call IO_error(0,ext_msg='isKey') if (.not. isKey(' a: #')) error stop 'isKey'
if( isScalar('a: ')) call IO_error(0,ext_msg='isScalar') if( isScalar('a: ')) error stop 'isScalar'
if( isScalar('a: b')) call IO_error(0,ext_msg='isScalar') if( isScalar('a: b')) error stop 'isScalar'
if( isScalar('{a:b}')) call IO_error(0,ext_msg='isScalar') if( isScalar('{a:b}')) error stop 'isScalar'
if( isScalar('- a:')) call IO_error(0,ext_msg='isScalar') if( isScalar('- a:')) error stop 'isScalar'
if(.not. isScalar(' a')) call IO_error(0,ext_msg='isScalar') if(.not. isScalar(' a')) error stop 'isScalar'
basic_list: block basic_list: block
character(len=*), parameter :: block_list = & character(len=*), parameter :: block_list = &
@ -602,8 +604,8 @@ subroutine selfTest()
character(len=*), parameter :: flow_list = & character(len=*), parameter :: flow_list = &
"[Casablanca, North by Northwest]" "[Casablanca, North by Northwest]"
if (.not. to_flow(block_list) == flow_list) call IO_error(0,ext_msg='to_flow') if (.not. to_flow(block_list) == flow_list) error stop 'to_flow'
if (.not. to_flow(block_list_newline) == flow_list) call IO_error(0,ext_msg='to_flow') if (.not. to_flow(block_list_newline) == flow_list) error stop 'to_flow'
end block basic_list end block basic_list
basic_dict: block basic_dict: block
@ -618,8 +620,8 @@ subroutine selfTest()
character(len=*), parameter :: flow_dict = & character(len=*), parameter :: flow_dict = &
"{aa: Casablanca, bb: North by Northwest}" "{aa: Casablanca, bb: North by Northwest}"
if (.not. to_flow(block_dict) == flow_dict) call IO_error(0,ext_msg='to_flow') if (.not. to_flow(block_dict) == flow_dict) error stop 'to_flow'
if (.not. to_flow(block_dict_newline) == flow_dict) call IO_error(0,ext_msg='to_flow') if (.not. to_flow(block_dict_newline) == flow_dict) error stop 'to_flow'
end block basic_dict end block basic_dict
basic_flow: block basic_flow: block
@ -630,8 +632,8 @@ subroutine selfTest()
character(len=*), parameter :: flow = & character(len=*), parameter :: flow = &
"{source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]}" "{source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]}"
if (.not. to_flow(flow_braces) == flow) call IO_error(0,ext_msg='to_flow') if (.not. to_flow(flow_braces) == flow) error stop 'to_flow'
if (.not. to_flow(flow_mixed_braces) == flow) call IO_error(0,ext_msg='to_flow') if (.not. to_flow(flow_mixed_braces) == flow) error stop 'to_flow'
end block basic_flow end block basic_flow
basic_mixed: block basic_mixed: block
@ -645,7 +647,7 @@ subroutine selfTest()
character(len=*), parameter :: mixed_flow = & character(len=*), parameter :: mixed_flow = &
"{aa: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}, {c: d}], bb: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}]}" "{aa: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}, {c: d}], bb: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}]}"
if(.not. to_flow(block_flow) == mixed_flow) call IO_error(0,ext_msg='to_flow') if(.not. to_flow(block_flow) == mixed_flow) error stop 'to_flow'
end block basic_mixed end block basic_mixed
end subroutine selfTest end subroutine selfTest

28
src/YAML_types.f90
View File

@ -207,11 +207,11 @@ subroutine selfTest
select type(s1) select type(s1)
class is(tScalar) class is(tScalar)
s1 = '1' s1 = '1'
if(s1%asInt() /= 1) call IO_error(0,ext_msg='tScalar_asInt') if(s1%asInt() /= 1) error stop 'tScalar_asInt'
if(dNeq(s1%asFloat(),1.0_pReal)) call IO_error(0,ext_msg='tScalar_asFloat') if(dNeq(s1%asFloat(),1.0_pReal)) error stop 'tScalar_asFloat'
s1 = 'true' s1 = 'true'
if(.not. s1%asBool()) call IO_error(0,ext_msg='tScalar_asBool') if(.not. s1%asBool()) error stop 'tScalar_asBool'
if(s1%asString() /= 'true') call IO_error(0,ext_msg='tScalar_asString') if(s1%asString() /= 'true') error stop 'tScalar_asString'
end select end select
block block
@ -232,18 +232,18 @@ subroutine selfTest
call l1%append(s1) call l1%append(s1)
call l1%append(s2) call l1%append(s2)
n => l1 n => l1
if(any(l1%asInts() /= [2,3])) call IO_error(0,ext_msg='tList_asInts') if(any(l1%asInts() /= [2,3])) error stop 'tList_asInts'
if(any(dNeq(l1%asFloats(),[2.0_pReal,3.0_pReal]))) call IO_error(0,ext_msg='tList_asFloats') if(any(dNeq(l1%asFloats(),[2.0_pReal,3.0_pReal]))) error stop 'tList_asFloats'
if(n%get_asInt(1) /= 2) call IO_error(0,ext_msg='byIndex_asInt') if(n%get_asInt(1) /= 2) error stop 'byIndex_asInt'
if(dNeq(n%get_asFloat(2),3.0_pReal)) call IO_error(0,ext_msg='byIndex_asFloat') if(dNeq(n%get_asFloat(2),3.0_pReal)) error stop 'byIndex_asFloat'
endselect endselect
allocate(tList::l2) allocate(tList::l2)
select type(l2) select type(l2)
class is(tList) class is(tList)
call l2%append(l1) call l2%append(l1)
if(any(l2%get_asInts(1) /= [2,3])) call IO_error(0,ext_msg='byIndex_asInts') if(any(l2%get_asInts(1) /= [2,3])) error stop 'byIndex_asInts'
if(any(dNeq(l2%get_asFloats(1),[2.0_pReal,3.0_pReal]))) call IO_error(0,ext_msg='byIndex_asFloats') if(any(dNeq(l2%get_asFloats(1),[2.0_pReal,3.0_pReal]))) error stop 'byIndex_asFloats'
n => l2 n => l2
end select end select
deallocate(n) deallocate(n)
@ -265,10 +265,10 @@ subroutine selfTest
call l1%append(s2) call l1%append(s2)
n => l1 n => l1
if(any(l1%asBools() .neqv. [.true., .false.])) call IO_error(0,ext_msg='tList_asBools') if(any(l1%asBools() .neqv. [.true., .false.])) error stop 'tList_asBools'
if(any(l1%asStrings() /= ['true ','False'])) call IO_error(0,ext_msg='tList_asStrings') if(any(l1%asStrings() /= ['true ','False'])) error stop 'tList_asStrings'
if(n%get_asBool(2)) call IO_error(0,ext_msg='byIndex_asBool') if(n%get_asBool(2)) error stop 'byIndex_asBool'
if(n%get_asString(1) /= 'true') call IO_error(0,ext_msg='byIndex_asString') if(n%get_asString(1) /= 'true') error stop 'byIndex_asString'
end block end block
end subroutine selfTest end subroutine selfTest

52
src/base64.f90
View File

@ -167,59 +167,59 @@ subroutine selfTest
character(len=*), parameter :: zero_to_three = 'AAECAw==' character(len=*), parameter :: zero_to_three = 'AAECAw=='
! https://en.wikipedia.org/wiki/Base64#Output_padding ! https://en.wikipedia.org/wiki/Base64#Output_padding
if(base64_nChar(20_pI64) /= 28_pI64) call IO_error(0,ext_msg='base64_nChar/20/28') if(base64_nChar(20_pI64) /= 28_pI64) error stop 'base64_nChar/20/28'
if(base64_nChar(19_pI64) /= 28_pI64) call IO_error(0,ext_msg='base64_nChar/19/28') if(base64_nChar(19_pI64) /= 28_pI64) error stop 'base64_nChar/19/28'
if(base64_nChar(18_pI64) /= 24_pI64) call IO_error(0,ext_msg='base64_nChar/18/24') if(base64_nChar(18_pI64) /= 24_pI64) error stop 'base64_nChar/18/24'
if(base64_nChar(17_pI64) /= 24_pI64) call IO_error(0,ext_msg='base64_nChar/17/24') if(base64_nChar(17_pI64) /= 24_pI64) error stop 'base64_nChar/17/24'
if(base64_nChar(16_pI64) /= 24_pI64) call IO_error(0,ext_msg='base64_nChar/16/24') if(base64_nChar(16_pI64) /= 24_pI64) error stop 'base64_nChar/16/24'
if(base64_nByte(4_pI64) /= 3_pI64) call IO_error(0,ext_msg='base64_nByte/4/3') if(base64_nByte(4_pI64) /= 3_pI64) error stop 'base64_nByte/4/3'
if(base64_nByte(8_pI64) /= 6_pI64) call IO_error(0,ext_msg='base64_nByte/8/6') if(base64_nByte(8_pI64) /= 6_pI64) error stop 'base64_nByte/8/6'
bytes = base64_to_bytes(zero_to_three) bytes = base64_to_bytes(zero_to_three)
if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) call IO_error(0,ext_msg='base64_to_bytes//') if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes//'
bytes = base64_to_bytes(zero_to_three,e=1_pI64) bytes = base64_to_bytes(zero_to_three,e=1_pI64)
if(any(bytes /= int([0],C_SIGNED_CHAR)) .or. size(bytes) /= 1) call IO_error(0,ext_msg='base64_to_bytes//1') if(any(bytes /= int([0],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes//1'
bytes = base64_to_bytes(zero_to_three,e=2_pI64) bytes = base64_to_bytes(zero_to_three,e=2_pI64)
if(any(bytes /= int([0,1],C_SIGNED_CHAR)) .or. size(bytes) /= 2) call IO_error(0,ext_msg='base64_to_bytes//2') if(any(bytes /= int([0,1],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes//2'
bytes = base64_to_bytes(zero_to_three,e=3_pI64) bytes = base64_to_bytes(zero_to_three,e=3_pI64)
if(any(bytes /= int([0,1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 3) call IO_error(0,ext_msg='base64_to_bytes//3') if(any(bytes /= int([0,1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes//3'
bytes = base64_to_bytes(zero_to_three,e=4_pI64) bytes = base64_to_bytes(zero_to_three,e=4_pI64)
if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) call IO_error(0,ext_msg='base64_to_bytes//4') if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes//4'
bytes = base64_to_bytes(zero_to_three,s=1_pI64) bytes = base64_to_bytes(zero_to_three,s=1_pI64)
if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) call IO_error(0,ext_msg='base64_to_bytes/1/') if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes/1/'
bytes = base64_to_bytes(zero_to_three,s=2_pI64) bytes = base64_to_bytes(zero_to_three,s=2_pI64)
if(any(bytes /= int([1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 3) call IO_error(0,ext_msg='base64_to_bytes/2/') if(any(bytes /= int([1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes/2/'
bytes = base64_to_bytes(zero_to_three,s=3_pI64) bytes = base64_to_bytes(zero_to_three,s=3_pI64)
if(any(bytes /= int([2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 2) call IO_error(0,ext_msg='base64_to_bytes/3/') if(any(bytes /= int([2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/3/'
bytes = base64_to_bytes(zero_to_three,s=4_pI64) bytes = base64_to_bytes(zero_to_three,s=4_pI64)
if(any(bytes /= int([3],C_SIGNED_CHAR)) .or. size(bytes) /= 1) call IO_error(0,ext_msg='base64_to_bytes/4/') if(any(bytes /= int([3],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/4/'
bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=1_pI64) bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=1_pI64)
if(any(bytes /= int([0],C_SIGNED_CHAR)) .or. size(bytes) /= 1) call IO_error(0,ext_msg='base64_to_bytes/1/1') if(any(bytes /= int([0],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/1/1'
bytes = base64_to_bytes(zero_to_three,s=2_pI64,e=2_pI64) bytes = base64_to_bytes(zero_to_three,s=2_pI64,e=2_pI64)
if(any(bytes /= int([1],C_SIGNED_CHAR)) .or. size(bytes) /= 1) call IO_error(0,ext_msg='base64_to_bytes/2/2') if(any(bytes /= int([1],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/2/2'
bytes = base64_to_bytes(zero_to_three,s=3_pI64,e=3_pI64) bytes = base64_to_bytes(zero_to_three,s=3_pI64,e=3_pI64)
if(any(bytes /= int([2],C_SIGNED_CHAR)) .or. size(bytes) /= 1) call IO_error(0,ext_msg='base64_to_bytes/3/3') if(any(bytes /= int([2],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/3/3'
bytes = base64_to_bytes(zero_to_three,s=4_pI64,e=4_pI64) bytes = base64_to_bytes(zero_to_three,s=4_pI64,e=4_pI64)
if(any(bytes /= int([3],C_SIGNED_CHAR)) .or. size(bytes) /= 1) call IO_error(0,ext_msg='base64_to_bytes/4/4') if(any(bytes /= int([3],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/4/4'
bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=2_pI64) bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=2_pI64)
if(any(bytes /= int([0,1],C_SIGNED_CHAR)) .or. size(bytes) /= 2) call IO_error(0,ext_msg='base64_to_bytes/1/2') if(any(bytes /= int([0,1],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/1/2'
bytes = base64_to_bytes(zero_to_three,s=2_pI64,e=3_pI64) bytes = base64_to_bytes(zero_to_three,s=2_pI64,e=3_pI64)
if(any(bytes /= int([1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 2) call IO_error(0,ext_msg='base64_to_bytes/2/3') if(any(bytes /= int([1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/2/3'
bytes = base64_to_bytes(zero_to_three,s=3_pI64,e=4_pI64) bytes = base64_to_bytes(zero_to_three,s=3_pI64,e=4_pI64)
if(any(bytes /= int([2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 2) call IO_error(0,ext_msg='base64_to_bytes/3/4') if(any(bytes /= int([2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/3/4'
bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=3_pI64) bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=3_pI64)
if(any(bytes /= int([0,1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 3) call IO_error(0,ext_msg='base64_to_bytes/1/3') if(any(bytes /= int([0,1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes/1/3'
bytes = base64_to_bytes(zero_to_three,s=2_pI64,e=4_pI64) bytes = base64_to_bytes(zero_to_three,s=2_pI64,e=4_pI64)
if(any(bytes /= int([1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 3) call IO_error(0,ext_msg='base64_to_bytes/2/4') if(any(bytes /= int([1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes/2/4'
bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=4_pI64) bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=4_pI64)
if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) call IO_error(0,ext_msg='base64_to_bytes/1/4') if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes/1/4'
end subroutine selfTest end subroutine selfTest

16
src/lattice.f90
View File

@ -2299,7 +2299,7 @@ end function equivalent_mu
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief check correctness of some lattice functions !> @brief Check correctness of some lattice functions.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine selfTest subroutine selfTest
@ -2314,21 +2314,19 @@ subroutine selfTest
system = reshape([1.0_pReal+r(1),0.0_pReal,0.0_pReal, 0.0_pReal,1.0_pReal+r(2),0.0_pReal],[6,1]) system = reshape([1.0_pReal+r(1),0.0_pReal,0.0_pReal, 0.0_pReal,1.0_pReal+r(2),0.0_pReal],[6,1])
CoSy = buildCoordinateSystem([1],[1],system,'fcc',0.0_pReal) CoSy = buildCoordinateSystem([1],[1],system,'fcc',0.0_pReal)
if(any(dNeq(CoSy(1:3,1:3,1),math_I3))) & if(any(dNeq(CoSy(1:3,1:3,1),math_I3))) error stop 'buildCoordinateSystem'
call IO_error(0)
call random_number(C) call random_number(C)
C(1,1) = C(1,1) + 1.0_pReal C(1,1) = C(1,1) + 1.0_pReal
C = applyLatticeSymmetryC66(C,'iso') C = applyLatticeSymmetryC66(C,'iso')
if(dNeq(C(6,6),equivalent_mu(C,'voigt'),1.0e-12_pReal)) & if(dNeq(C(6,6),equivalent_mu(C,'voigt'),1.0e-12_pReal)) error stop 'equivalent_mu/voigt'
call IO_error(0,ext_msg='equivalent_mu/voigt') if(dNeq(C(6,6),equivalent_mu(C,'voigt'),1.0e-12_pReal)) error stop 'equivalent_mu/reuss'
if(dNeq(C(6,6),equivalent_mu(C,'voigt'),1.0e-12_pReal)) &
call IO_error(0,ext_msg='equivalent_mu/reuss')
lambda = C(1,2) lambda = C(1,2)
if(dNeq(lambda*0.5_pReal/(lambda+equivalent_mu(C,'voigt')),equivalent_nu(C,'voigt'),1.0e-12_pReal)) & if(dNeq(lambda*0.5_pReal/(lambda+equivalent_mu(C,'voigt')),equivalent_nu(C,'voigt'),1.0e-12_pReal)) &
call IO_error(0,ext_msg='equivalent_nu/voigt') error stop 'equivalent_nu/voigt'
if(dNeq(lambda*0.5_pReal/(lambda+equivalent_mu(C,'reuss')),equivalent_nu(C,'reuss'),1.0e-12_pReal)) & if(dNeq(lambda*0.5_pReal/(lambda+equivalent_mu(C,'reuss')),equivalent_nu(C,'reuss'),1.0e-12_pReal)) &
call IO_error(0,ext_msg='equivalent_nu/reuss') error stop 'equivalent_nu/reuss'
end subroutine selfTest end subroutine selfTest

62
src/math.f90
View File

@ -1154,7 +1154,7 @@ end function math_clip
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief check correctness of some math functions !> @brief Check correctness of some math functions.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine selfTest subroutine selfTest
@ -1181,47 +1181,47 @@ subroutine selfTest
if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal,3.0_pReal,3.0_pReal,3.0_pReal] - & if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal,3.0_pReal,3.0_pReal,3.0_pReal] - &
math_expand([1.0_pReal,2.0_pReal,3.0_pReal],[1,2,3,0])) > tol_math_check)) & math_expand([1.0_pReal,2.0_pReal,3.0_pReal],[1,2,3,0])) > tol_math_check)) &
call IO_error(0,ext_msg='math_expand [1,2,3] by [1,2,3,0] => [1,2,2,3,3,3]') error stop 'math_expand [1,2,3] by [1,2,3,0] => [1,2,2,3,3,3]'
if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal] - & if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal] - &
math_expand([1.0_pReal,2.0_pReal,3.0_pReal],[1,2])) > tol_math_check)) & math_expand([1.0_pReal,2.0_pReal,3.0_pReal],[1,2])) > tol_math_check)) &
call IO_error(0,ext_msg='math_expand [1,2,3] by [1,2] => [1,2,2]') error stop 'math_expand [1,2,3] by [1,2] => [1,2,2]'
if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal,1.0_pReal,1.0_pReal,1.0_pReal] - & if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal,1.0_pReal,1.0_pReal,1.0_pReal] - &
math_expand([1.0_pReal,2.0_pReal],[1,2,3])) > tol_math_check)) & math_expand([1.0_pReal,2.0_pReal],[1,2,3])) > tol_math_check)) &
call IO_error(0,ext_msg='math_expand [1,2] by [1,2,3] => [1,2,2,1,1,1]') error stop 'math_expand [1,2] by [1,2,3] => [1,2,2,1,1,1]'
call math_sort(sort_in_,1,3,2) call math_sort(sort_in_,1,3,2)
if(any(sort_in_ /= sort_out_)) & if(any(sort_in_ /= sort_out_)) &
call IO_error(0,ext_msg='math_sort') error stop 'math_sort'
if(any(math_range(5) /= range_out_)) & if(any(math_range(5) /= range_out_)) &
call IO_error(0,ext_msg='math_range') error stop 'math_range'
if(any(dNeq(math_exp33(math_I3,0),math_I3))) & if(any(dNeq(math_exp33(math_I3,0),math_I3))) &
call IO_error(0,ext_msg='math_exp33(math_I3,1)') error stop 'math_exp33(math_I3,1)'
if(any(dNeq(math_exp33(math_I3,256),exp(1.0_pReal)*math_I3))) & if(any(dNeq(math_exp33(math_I3,256),exp(1.0_pReal)*math_I3))) &
call IO_error(0,ext_msg='math_exp33(math_I3,256)') error stop 'math_exp33(math_I3,256)'
call random_number(v9) call random_number(v9)
if(any(dNeq(math_33to9(math_9to33(v9)),v9))) & if(any(dNeq(math_33to9(math_9to33(v9)),v9))) &
call IO_error(0,ext_msg='math_33to9/math_9to33') error stop 'math_33to9/math_9to33'
call random_number(t99) call random_number(t99)
if(any(dNeq(math_3333to99(math_99to3333(t99)),t99))) & if(any(dNeq(math_3333to99(math_99to3333(t99)),t99))) &
call IO_error(0,ext_msg='math_3333to99/math_99to3333') error stop 'math_3333to99/math_99to3333'
call random_number(v6) call random_number(v6)
if(any(dNeq(math_sym33to6(math_6toSym33(v6)),v6))) & if(any(dNeq(math_sym33to6(math_6toSym33(v6)),v6))) &
call IO_error(0,ext_msg='math_sym33to6/math_6toSym33') error stop 'math_sym33to6/math_6toSym33'
call random_number(t66) call random_number(t66)
if(any(dNeq(math_sym3333to66(math_66toSym3333(t66)),t66))) & if(any(dNeq(math_sym3333to66(math_66toSym3333(t66)),t66))) &
call IO_error(0,ext_msg='math_sym3333to66/math_66toSym3333') error stop 'math_sym3333to66/math_66toSym3333'
call random_number(v6) call random_number(v6)
if(any(dNeq0(math_6toSym33(v6) - math_symmetric33(math_6toSym33(v6))))) & if(any(dNeq0(math_6toSym33(v6) - math_symmetric33(math_6toSym33(v6))))) &
call IO_error(0,ext_msg='math_symmetric33') error stop 'math_symmetric33'
call random_number(v3_1) call random_number(v3_1)
call random_number(v3_2) call random_number(v3_2)
@ -1230,30 +1230,30 @@ subroutine selfTest
if(dNeq(abs(dot_product(math_cross(v3_1-v3_4,v3_2-v3_4),v3_3-v3_4))/6.0, & if(dNeq(abs(dot_product(math_cross(v3_1-v3_4,v3_2-v3_4),v3_3-v3_4))/6.0, &
math_volTetrahedron(v3_1,v3_2,v3_3,v3_4),tol=1.0e-12_pReal)) & math_volTetrahedron(v3_1,v3_2,v3_3,v3_4),tol=1.0e-12_pReal)) &
call IO_error(0,ext_msg='math_volTetrahedron') error stop 'math_volTetrahedron'
call random_number(t33) call random_number(t33)
if(dNeq(math_det33(math_symmetric33(t33)),math_detSym33(math_symmetric33(t33)),tol=1.0e-12_pReal)) & if(dNeq(math_det33(math_symmetric33(t33)),math_detSym33(math_symmetric33(t33)),tol=1.0e-12_pReal)) &
call IO_error(0,ext_msg='math_det33/math_detSym33') error stop 'math_det33/math_detSym33'
if(any(dNeq0(math_eye(3),math_inv33(math_I3)))) & if(any(dNeq0(math_eye(3),math_inv33(math_I3)))) &
call IO_error(0,ext_msg='math_inv33(math_I3)') error stop 'math_inv33(math_I3)'
do while(abs(math_det33(t33))<1.0e-9_pReal) do while(abs(math_det33(t33))<1.0e-9_pReal)
call random_number(t33) call random_number(t33)
enddo enddo
if(any(dNeq0(matmul(t33,math_inv33(t33)) - math_eye(3),tol=1.0e-9_pReal))) & if(any(dNeq0(matmul(t33,math_inv33(t33)) - math_eye(3),tol=1.0e-9_pReal))) &
call IO_error(0,ext_msg='math_inv33') error stop 'math_inv33'
call math_invert33(t33_2,det,e,t33) call math_invert33(t33_2,det,e,t33)
if(any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pReal)) .or. e) & if(any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pReal)) .or. e) &
call IO_error(0,ext_msg='math_invert33: T:T^-1 != I') error stop 'math_invert33: T:T^-1 != I'
if(dNeq(det,math_det33(t33),tol=1.0e-12_pReal)) & if(dNeq(det,math_det33(t33),tol=1.0e-12_pReal)) &
call IO_error(0,ext_msg='math_invert33 (determinant)') error stop 'math_invert33 (determinant)'
call math_invert(t33_2,e,t33) call math_invert(t33_2,e,t33)
if(any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pReal)) .or. e) & if(any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pReal)) .or. e) &
call IO_error(0,ext_msg='math_invert t33') error stop 'math_invert t33'
do while(math_det33(t33)<1.0e-2_pReal) ! O(det(F)) = 1 do while(math_det33(t33)<1.0e-2_pReal) ! O(det(F)) = 1
call random_number(t33) call random_number(t33)
@ -1261,7 +1261,7 @@ subroutine selfTest
t33_2 = math_rotationalPart(transpose(t33)) t33_2 = math_rotationalPart(transpose(t33))
t33 = math_rotationalPart(t33) t33 = math_rotationalPart(t33)
if(any(dNeq0(matmul(t33_2,t33) - math_I3,tol=1.0e-10_pReal))) & if(any(dNeq0(matmul(t33_2,t33) - math_I3,tol=1.0e-10_pReal))) &
call IO_error(0,ext_msg='math_rotationalPart') error stop 'math_rotationalPart'
call random_number(r) call random_number(r)
d = int(r*5.0_pReal) + 1 d = int(r*5.0_pReal) + 1
@ -1269,30 +1269,30 @@ subroutine selfTest
allocate(txx_2(d,d)) allocate(txx_2(d,d))
call math_invert(txx_2,e,txx) call math_invert(txx_2,e,txx)
if(any(dNeq0(txx_2,txx) .or. e)) & if(any(dNeq0(txx_2,txx) .or. e)) &
call IO_error(0,ext_msg='math_invert(txx)/math_eye') error stop 'math_invert(txx)/math_eye'
call math_invert(t99_2,e,t99) ! not sure how likely it is that we get a singular matrix call math_invert(t99_2,e,t99) ! not sure how likely it is that we get a singular matrix
if(any(dNeq0(matmul(t99_2,t99)-math_eye(9),tol=1.0e-9_pReal)) .or. e) & if(any(dNeq0(matmul(t99_2,t99)-math_eye(9),tol=1.0e-9_pReal)) .or. e) &
call IO_error(0,ext_msg='math_invert(t99)') error stop 'math_invert(t99)'
if(any(dNeq(math_clip([4.0_pReal,9.0_pReal],5.0_pReal,6.5_pReal),[5.0_pReal,6.5_pReal]))) & if(any(dNeq(math_clip([4.0_pReal,9.0_pReal],5.0_pReal,6.5_pReal),[5.0_pReal,6.5_pReal]))) &
call IO_error(0,ext_msg='math_clip') error stop 'math_clip'
if(math_factorial(10) /= 3628800) & if(math_factorial(10) /= 3628800) &
call IO_error(0,ext_msg='math_factorial') error stop 'math_factorial'
if(math_binomial(49,6) /= 13983816) & if(math_binomial(49,6) /= 13983816) &
call IO_error(0,ext_msg='math_binomial') error stop 'math_binomial'
ijk = cshift([1,2,3],int(r*1.0e2_pReal)) ijk = cshift([1,2,3],int(r*1.0e2_pReal))
if(dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),+1.0_pReal)) & if(dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),+1.0_pReal)) &
call IO_error(0,ext_msg='math_LeviCivita(even)') error stop 'math_LeviCivita(even)'
ijk = cshift([3,2,1],int(r*2.0e2_pReal)) ijk = cshift([3,2,1],int(r*2.0e2_pReal))
if(dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),-1.0_pReal)) & if(dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),-1.0_pReal)) &
call IO_error(0,ext_msg='math_LeviCivita(odd)') error stop 'math_LeviCivita(odd)'
ijk = cshift([2,2,1],int(r*2.0e2_pReal)) ijk = cshift([2,2,1],int(r*2.0e2_pReal))
if(dNeq0(math_LeviCivita(ijk(1),ijk(2),ijk(3))))& if(dNeq0(math_LeviCivita(ijk(1),ijk(2),ijk(3)))) &
call IO_error(0,ext_msg='math_LeviCivita') error stop 'math_LeviCivita'
end subroutine selfTest end subroutine selfTest

18
src/prec.f90
View File

@ -297,31 +297,29 @@ subroutine selfTest
real(pReal), dimension(1) :: f real(pReal), dimension(1) :: f
integer(pInt), dimension(1) :: i integer(pInt), dimension(1) :: i
real(pReal), dimension(2) :: r real(pReal), dimension(2) :: r
external :: &
quit
realloc_lhs_test = [1,2] realloc_lhs_test = [1,2]
if (any(realloc_lhs_test/=[1,2])) call quit(9000) if (any(realloc_lhs_test/=[1,2])) error stop 'LHS allocation'
call random_number(r) call random_number(r)
r = r/minval(r) r = r/minval(r)
if(.not. all(dEq(r,r+PREAL_EPSILON))) call quit(9000) if(.not. all(dEq(r,r+PREAL_EPSILON))) error stop 'dEq'
if(dEq(r(1),r(2)) .and. dNeq(r(1),r(2))) call quit(9000) if(dEq(r(1),r(2)) .and. dNeq(r(1),r(2))) error stop 'dNeq'
if(.not. all(dEq0(r-(r+PREAL_MIN)))) call quit(9000) if(.not. all(dEq0(r-(r+PREAL_MIN)))) error stop 'dEq0'
! https://www.binaryconvert.com ! https://www.binaryconvert.com
! https://www.rapidtables.com/convert/number/binary-to-decimal.html ! https://www.rapidtables.com/convert/number/binary-to-decimal.html
f = real(bytes_to_C_FLOAT(int([-65,+11,-102,+75],C_SIGNED_CHAR)),pReal) f = real(bytes_to_C_FLOAT(int([-65,+11,-102,+75],C_SIGNED_CHAR)),pReal)
if(dNeq(f(1),20191102.0_pReal,0.0_pReal)) call quit(9000) if(dNeq(f(1),20191102.0_pReal,0.0_pReal)) error stop 'bytes_to_C_FLOAT'
f = real(bytes_to_C_DOUBLE(int([0,0,0,-32,+119,+65,+115,65],C_SIGNED_CHAR)),pReal) f = real(bytes_to_C_DOUBLE(int([0,0,0,-32,+119,+65,+115,65],C_SIGNED_CHAR)),pReal)
if(dNeq(f(1),20191102.0_pReal,0.0_pReal)) call quit(9000) if(dNeq(f(1),20191102.0_pReal,0.0_pReal)) error stop 'bytes_to_C_DOUBLE'
i = int(bytes_to_C_INT32_T(int([+126,+23,+52,+1],C_SIGNED_CHAR)),pInt) i = int(bytes_to_C_INT32_T(int([+126,+23,+52,+1],C_SIGNED_CHAR)),pInt)
if(i(1) /= 20191102_pInt) call quit(9000) if(i(1) /= 20191102_pInt) error stop 'bytes_to_C_INT32_T'
i = int(bytes_to_C_INT64_T(int([+126,+23,+52,+1,0,0,0,0],C_SIGNED_CHAR)),pInt) i = int(bytes_to_C_INT64_T(int([+126,+23,+52,+1,0,0,0,0],C_SIGNED_CHAR)),pInt)
if(i(1) /= 20191102_pInt) call quit(9000) if(i(1) /= 20191102_pInt) error stop 'bytes_to_C_INT64_T'
end subroutine selfTest end subroutine selfTest

53
src/quaternions.f90
View File

@ -7,7 +7,6 @@
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
module quaternions module quaternions
use prec use prec
use IO
implicit none implicit none
private private
@ -464,67 +463,67 @@ subroutine selfTest
real(pReal), dimension(4) :: qu real(pReal), dimension(4) :: qu
type(quaternion) :: q, q_2 type(quaternion) :: q, q_2
if(dNeq(abs(P),1.0_pReal)) call IO_error(0,ext_msg='P not in {-1,+1}') if(dNeq(abs(P),1.0_pReal)) error stop 'P not in {-1,+1}'
call random_number(qu) call random_number(qu)
qu = (qu-0.5_pReal) * 2.0_pReal qu = (qu-0.5_pReal) * 2.0_pReal
q = quaternion(qu) q = quaternion(qu)
q_2= qu q_2= qu
if(any(dNeq(q%asArray(),q_2%asArray()))) call IO_error(0,ext_msg='assign_vec__') if(any(dNeq(q%asArray(),q_2%asArray()))) error stop 'assign_vec__'
q_2 = q + q q_2 = q + q
if(any(dNeq(q_2%asArray(),2.0_pReal*qu))) call IO_error(0,ext_msg='add__') if(any(dNeq(q_2%asArray(),2.0_pReal*qu))) error stop 'add__'
q_2 = q - q q_2 = q - q
if(any(dNeq0(q_2%asArray()))) call IO_error(0,ext_msg='sub__') if(any(dNeq0(q_2%asArray()))) error stop 'sub__'
q_2 = q * 5.0_pReal q_2 = q * 5.0_pReal
if(any(dNeq(q_2%asArray(),5.0_pReal*qu))) call IO_error(0,ext_msg='mul__') if(any(dNeq(q_2%asArray(),5.0_pReal*qu))) error stop 'mul__'
q_2 = q / 0.5_pReal q_2 = q / 0.5_pReal
if(any(dNeq(q_2%asArray(),2.0_pReal*qu))) call IO_error(0,ext_msg='div__') if(any(dNeq(q_2%asArray(),2.0_pReal*qu))) error stop 'div__'
q_2 = q * 0.3_pReal q_2 = q * 0.3_pReal
if(dNeq0(abs(q)) .and. q_2 == q) call IO_error(0,ext_msg='eq__') if(dNeq0(abs(q)) .and. q_2 == q) error stop 'eq__'
q_2 = q q_2 = q
if(q_2 /= q) call IO_error(0,ext_msg='neq__') if(q_2 /= q) error stop 'neq__'
if(dNeq(abs(q),norm2(qu))) call IO_error(0,ext_msg='abs__') if(dNeq(abs(q),norm2(qu))) error stop 'abs__'
if(dNeq(abs(q)**2.0_pReal, real(q*q%conjg()),1.0e-14_pReal)) & if(dNeq(abs(q)**2.0_pReal, real(q*q%conjg()),1.0e-14_pReal)) &
call IO_error(0,ext_msg='abs__/*conjg') error stop 'abs__/*conjg'
if(any(dNeq(q%asArray(),qu))) call IO_error(0,ext_msg='eq__') if(any(dNeq(q%asArray(),qu))) error stop 'eq__'
if(dNeq(q%real(), qu(1))) call IO_error(0,ext_msg='real()') if(dNeq(q%real(), qu(1))) error stop 'real()'
if(any(dNeq(q%aimag(), qu(2:4)))) call IO_error(0,ext_msg='aimag()') if(any(dNeq(q%aimag(), qu(2:4)))) error stop 'aimag()'
q_2 = q%homomorphed() q_2 = q%homomorphed()
if(q /= q_2* (-1.0_pReal)) call IO_error(0,ext_msg='homomorphed') if(q /= q_2* (-1.0_pReal)) error stop 'homomorphed'
if(dNeq(q_2%real(), qu(1)* (-1.0_pReal))) call IO_error(0,ext_msg='homomorphed/real') if(dNeq(q_2%real(), qu(1)* (-1.0_pReal))) error stop 'homomorphed/real'
if(any(dNeq(q_2%aimag(),qu(2:4)*(-1.0_pReal)))) call IO_error(0,ext_msg='homomorphed/aimag') if(any(dNeq(q_2%aimag(),qu(2:4)*(-1.0_pReal)))) error stop 'homomorphed/aimag'
q_2 = conjg(q) q_2 = conjg(q)
if(dNeq(abs(q),abs(q_2))) call IO_error(0,ext_msg='conjg/abs') if(dNeq(abs(q),abs(q_2))) error stop 'conjg/abs'
if(q /= conjg(q_2)) call IO_error(0,ext_msg='conjg/involution') if(q /= conjg(q_2)) error stop 'conjg/involution'
if(dNeq(q_2%real(), q%real())) call IO_error(0,ext_msg='conjg/real') if(dNeq(q_2%real(), q%real())) error stop 'conjg/real'
if(any(dNeq(q_2%aimag(),q%aimag()*(-1.0_pReal)))) call IO_error(0,ext_msg='conjg/aimag') if(any(dNeq(q_2%aimag(),q%aimag()*(-1.0_pReal)))) error stop 'conjg/aimag'
if(abs(q) > 0.0_pReal) then if(abs(q) > 0.0_pReal) then
q_2 = q * q%inverse() q_2 = q * q%inverse()
if( dNeq(real(q_2), 1.0_pReal,1.0e-15_pReal)) call IO_error(0,ext_msg='inverse/real') if( dNeq(real(q_2), 1.0_pReal,1.0e-15_pReal)) error stop 'inverse/real'
if(any(dNeq0(aimag(q_2), 1.0e-15_pReal))) call IO_error(0,ext_msg='inverse/aimag') if(any(dNeq0(aimag(q_2), 1.0e-15_pReal))) error stop 'inverse/aimag'
q_2 = q/abs(q) q_2 = q/abs(q)
q_2 = conjg(q_2) - inverse(q_2) q_2 = conjg(q_2) - inverse(q_2)
if(any(dNeq0(q_2%asArray(),1.0e-15_pReal))) call IO_error(0,ext_msg='inverse/conjg') if(any(dNeq0(q_2%asArray(),1.0e-15_pReal))) error stop 'inverse/conjg'
endif endif
if(dNeq(dot_product(qu,qu),dot_product(q,q))) call IO_error(0,ext_msg='dot_product') if(dNeq(dot_product(qu,qu),dot_product(q,q))) error stop 'dot_product'
#if !(defined(__GFORTRAN__) && __GNUC__ < 9) #if !(defined(__GFORTRAN__) && __GNUC__ < 9)
if (norm2(aimag(q)) > 0.0_pReal) then if (norm2(aimag(q)) > 0.0_pReal) then
if (dNeq0(abs(q-exp(log(q))),1.0e-13_pReal)) call IO_error(0,ext_msg='exp/log') if (dNeq0(abs(q-exp(log(q))),1.0e-13_pReal)) error stop 'exp/log'
if (dNeq0(abs(q-log(exp(q))),1.0e-13_pReal)) call IO_error(0,ext_msg='log/exp') if (dNeq0(abs(q-log(exp(q))),1.0e-13_pReal)) error stop 'log/exp'
endif endif
#endif #endif

54
src/rotations.f90
View File

@ -1371,14 +1371,11 @@ subroutine selfTest
real(pReal), dimension(3) :: x, eu, ho, v3 real(pReal), dimension(3) :: x, eu, ho, v3
real(pReal), dimension(3,3) :: om, t33 real(pReal), dimension(3,3) :: om, t33
real(pReal), dimension(3,3,3,3) :: t3333 real(pReal), dimension(3,3,3,3) :: t3333
character(len=pStringLen) :: msg
real :: A,B real :: A,B
integer :: i integer :: i
do i=1,10 do i=1,10
msg = ''
#if defined(__GFORTRAN__) && __GNUC__<9 #if defined(__GFORTRAN__) && __GNUC__<9
if(i<7) cycle if(i<7) cycle
#endif #endif
@ -1405,55 +1402,54 @@ subroutine selfTest
sin(2.0_pReal*PI*x(1))*A] sin(2.0_pReal*PI*x(1))*A]
if(qu(1)<0.0_pReal) qu = qu * (-1.0_pReal) if(qu(1)<0.0_pReal) qu = qu * (-1.0_pReal)
endif endif
if(.not. quaternion_equal(om2qu(qu2om(qu)),qu)) msg = trim(msg)//'om2qu/qu2om,' if(.not. quaternion_equal(om2qu(qu2om(qu)),qu)) error stop 'om2qu/qu2om'
if(.not. quaternion_equal(eu2qu(qu2eu(qu)),qu)) msg = trim(msg)//'eu2qu/qu2eu,' if(.not. quaternion_equal(eu2qu(qu2eu(qu)),qu)) error stop 'eu2qu/qu2eu'
if(.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) msg = trim(msg)//'ax2qu/qu2ax,' if(.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) error stop 'ax2qu/qu2ax'
if(.not. quaternion_equal(ro2qu(qu2ro(qu)),qu)) msg = trim(msg)//'ro2qu/qu2ro,' if(.not. quaternion_equal(ro2qu(qu2ro(qu)),qu)) error stop 'ro2qu/qu2ro'
if(.not. quaternion_equal(ho2qu(qu2ho(qu)),qu)) msg = trim(msg)//'ho2qu/qu2ho,' if(.not. quaternion_equal(ho2qu(qu2ho(qu)),qu)) error stop 'ho2qu/qu2ho'
if(.not. quaternion_equal(cu2qu(qu2cu(qu)),qu)) msg = trim(msg)//'cu2qu/qu2cu,' if(.not. quaternion_equal(cu2qu(qu2cu(qu)),qu)) error stop 'cu2qu/qu2cu'
om = qu2om(qu) om = qu2om(qu)
if(.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) msg = trim(msg)//'eu2om/om2eu,' if(.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) error stop 'eu2om/om2eu'
if(.not. quaternion_equal(om2qu(ax2om(om2ax(om))),qu)) msg = trim(msg)//'ax2om/om2ax,' if(.not. quaternion_equal(om2qu(ax2om(om2ax(om))),qu)) error stop 'ax2om/om2ax'
if(.not. quaternion_equal(om2qu(ro2om(om2ro(om))),qu)) msg = trim(msg)//'ro2om/om2ro,' if(.not. quaternion_equal(om2qu(ro2om(om2ro(om))),qu)) error stop 'ro2om/om2ro'
if(.not. quaternion_equal(om2qu(ho2om(om2ho(om))),qu)) msg = trim(msg)//'ho2om/om2ho,' if(.not. quaternion_equal(om2qu(ho2om(om2ho(om))),qu)) error stop 'ho2om/om2ho'
if(.not. quaternion_equal(om2qu(cu2om(om2cu(om))),qu)) msg = trim(msg)//'cu2om/om2cu,' if(.not. quaternion_equal(om2qu(cu2om(om2cu(om))),qu)) error stop 'cu2om/om2cu'
eu = qu2eu(qu) eu = qu2eu(qu)
if(.not. quaternion_equal(eu2qu(ax2eu(eu2ax(eu))),qu)) msg = trim(msg)//'ax2eu/eu2ax,' if(.not. quaternion_equal(eu2qu(ax2eu(eu2ax(eu))),qu)) error stop 'ax2eu/eu2ax'
if(.not. quaternion_equal(eu2qu(ro2eu(eu2ro(eu))),qu)) msg = trim(msg)//'ro2eu/eu2ro,' if(.not. quaternion_equal(eu2qu(ro2eu(eu2ro(eu))),qu)) error stop 'ro2eu/eu2ro'
if(.not. quaternion_equal(eu2qu(ho2eu(eu2ho(eu))),qu)) msg = trim(msg)//'ho2eu/eu2ho,' if(.not. quaternion_equal(eu2qu(ho2eu(eu2ho(eu))),qu)) error stop 'ho2eu/eu2ho'
if(.not. quaternion_equal(eu2qu(cu2eu(eu2cu(eu))),qu)) msg = trim(msg)//'cu2eu/eu2cu,' if(.not. quaternion_equal(eu2qu(cu2eu(eu2cu(eu))),qu)) error stop 'cu2eu/eu2cu'
ax = qu2ax(qu) ax = qu2ax(qu)
if(.not. quaternion_equal(ax2qu(ro2ax(ax2ro(ax))),qu)) msg = trim(msg)//'ro2ax/ax2ro,' if(.not. quaternion_equal(ax2qu(ro2ax(ax2ro(ax))),qu)) error stop 'ro2ax/ax2ro'
if(.not. quaternion_equal(ax2qu(ho2ax(ax2ho(ax))),qu)) msg = trim(msg)//'ho2ax/ax2ho,' if(.not. quaternion_equal(ax2qu(ho2ax(ax2ho(ax))),qu)) error stop 'ho2ax/ax2ho'
if(.not. quaternion_equal(ax2qu(cu2ax(ax2cu(ax))),qu)) msg = trim(msg)//'cu2ax/ax2cu,' if(.not. quaternion_equal(ax2qu(cu2ax(ax2cu(ax))),qu)) error stop 'cu2ax/ax2cu'
ro = qu2ro(qu) ro = qu2ro(qu)
if(.not. quaternion_equal(ro2qu(ho2ro(ro2ho(ro))),qu)) msg = trim(msg)//'ho2ro/ro2ho,' if(.not. quaternion_equal(ro2qu(ho2ro(ro2ho(ro))),qu)) error stop 'ho2ro/ro2ho'
if(.not. quaternion_equal(ro2qu(cu2ro(ro2cu(ro))),qu)) msg = trim(msg)//'cu2ro/ro2cu,' if(.not. quaternion_equal(ro2qu(cu2ro(ro2cu(ro))),qu)) error stop 'cu2ro/ro2cu'
ho = qu2ho(qu) ho = qu2ho(qu)
if(.not. quaternion_equal(ho2qu(cu2ho(ho2cu(ho))),qu)) msg = trim(msg)//'cu2ho/ho2cu,' if(.not. quaternion_equal(ho2qu(cu2ho(ho2cu(ho))),qu)) error stop 'cu2ho/ho2cu'
call R%fromMatrix(om) call R%fromMatrix(om)
call random_number(v3) call random_number(v3)
if(all(dNeq(R%rotVector(R%rotVector(v3),active=.true.),v3,1.0e-12_pReal))) & if(all(dNeq(R%rotVector(R%rotVector(v3),active=.true.),v3,1.0e-12_pReal))) &
msg = trim(msg)//'rotVector,' error stop 'rotVector'
call random_number(t33) call random_number(t33)
if(all(dNeq(R%rotTensor2(R%rotTensor2(t33),active=.true.),t33,1.0e-12_pReal))) & if(all(dNeq(R%rotTensor2(R%rotTensor2(t33),active=.true.),t33,1.0e-12_pReal))) &
msg = trim(msg)//'rotTensor2,' error stop 'rotTensor2'
call random_number(t3333) call random_number(t3333)
if(all(dNeq(R%rotTensor4(R%rotTensor4(t3333),active=.true.),t3333,1.0e-12_pReal))) & if(all(dNeq(R%rotTensor4(R%rotTensor4(t3333),active=.true.),t3333,1.0e-12_pReal))) &
msg = trim(msg)//'rotTensor4,' error stop 'rotTensor4'
if(len_trim(msg) /= 0) call IO_error(0,ext_msg=msg)
enddo enddo
contains contains
function quaternion_equal(qu1,qu2) result(ok) function quaternion_equal(qu1,qu2) result(ok)