From 5b83c8ad3ca20eef6b9fcd1cd82713a0f0e9cb12 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 13 Sep 2020 12:09:32 +0200 Subject: [PATCH] use 'error stop' - does not require IO - prints stack trace --- src/HDF5_utilities.f90 | 4 +- src/IO.f90 | 50 ++++++++--------- src/YAML_parse.f90 | 120 +++++++++++++++++++++-------------------- src/YAML_types.f90 | 28 +++++----- src/base64.f90 | 52 +++++++++--------- src/lattice.f90 | 16 +++--- src/math.f90 | 62 ++++++++++----------- src/prec.f90 | 18 +++---- src/quaternions.f90 | 53 +++++++++--------- src/rotations.f90 | 54 +++++++++---------- 10 files changed, 225 insertions(+), 232 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index d50ff6aa5..faeff03e3 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -98,12 +98,12 @@ subroutine HDF5_utilities_init 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 (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) 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) & - 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 diff --git a/src/IO.f90 b/src/IO.f90 index 23e2c7c1b..53781653e 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -657,49 +657,49 @@ subroutine selfTest integer, dimension(:), allocatable :: chunkPos 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('1e0'))) call IO_error(0,ext_msg='IO_stringAsFloat') - if(dNeq(0.1_pReal, IO_stringAsFloat('1e-1'))) 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'))) error stop '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')) call IO_error(0,ext_msg='IO_stringAsInt') - if(-3112019 /= IO_stringAsInt('-3112019')) call IO_error(0,ext_msg='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')) error stop 'IO_stringAsInt' + if(-3112019 /= IO_stringAsInt('-3112019')) error stop '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 ')) call IO_error(0,ext_msg='IO_stringAsBool') - if( IO_stringAsBool(' false')) call IO_error(0,ext_msg='IO_stringAsBool') - if( IO_stringAsBool('False')) call IO_error(0,ext_msg='IO_stringAsBool') + if(.not. IO_stringAsBool(' true')) error stop 'IO_stringAsBool' + if(.not. IO_stringAsBool(' True ')) error stop 'IO_stringAsBool' + if( IO_stringAsBool(' false')) error stop '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([2,2,3,5,5] /= IO_stringPos(' aa b'))) 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'))) error stop 'IO_stringPos' str=' 1.0 xxx' 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' 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(' #isBlank')) call IO_error(0,ext_msg='IO_isBlank/2') - if( IO_isBlank(' i#s')) call IO_error(0,ext_msg='IO_isBlank/3') + if(.not. IO_isBlank(' ')) error stop 'IO_isBlank/1' + if(.not. IO_isBlank(' #isBlank')) error stop 'IO_isBlank/2' + if( IO_isBlank(' i#s')) error stop 'IO_isBlank/3' 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(' #') - 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(' # ') - 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') - 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') - 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#') - 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 #') - 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 diff --git a/src/YAML_parse.f90 b/src/YAML_parse.f90 index 88f49c060..85ec508ab 100644 --- a/src/YAML_parse.f90 +++ b/src/YAML_parse.f90 @@ -11,7 +11,7 @@ module YAML_parse implicit none private - + public :: & YAML_init, & parse_flow, & @@ -47,7 +47,7 @@ recursive function parse_flow(YAML_flow) result(node) e, & ! end position of dictionary or list s, & ! start position of dictionary or list d ! position of key: value separator (':') - + flow_string = trim(adjustl(YAML_flow(:))) if (len_trim(flow_string) == 0) then node => emptyDict @@ -57,12 +57,12 @@ recursive function parse_flow(YAML_flow) result(node) allocate(tDict::node) do while (e < len_trim(flow_string)) s = e - d = s + scan(flow_string(s+1:),':') - e = d + find_end(flow_string(d+1:),'}') + d = s + scan(flow_string(s+1:),':') + e = d + find_end(flow_string(d+1:),'}') key = trim(adjustl(flow_string(s+1:d-1))) myVal => parse_flow(flow_string(d+1:e-1)) ! parse items (recursively) - + select type (node) class is (tDict) call node%set(key,myVal) @@ -208,7 +208,7 @@ logical function isKey(line) if(len(IO_rmComment(line)) == 0) then isKey = .false. else - isKey = IO_rmComment(line(len(IO_rmComment(line)):len(IO_rmComment(line)))) == ':' & + isKey = IO_rmComment(line(len(IO_rmComment(line)):len(IO_rmComment(line)))) == ':' & .and. .not. isFlow(line) endif @@ -224,19 +224,19 @@ recursive subroutine line_isFlow(flow,s_flow,line) character(len=*), intent(inout) :: flow !< YAML in flow style only integer, intent(inout) :: s_flow !< start position in flow character(len=*), intent(in) :: line - + integer :: & s, & list_chunk, & dict_chunk - + if(index(adjustl(line),'[') == 1) then s = index(line,'[') flow(s_flow:s_flow) = '[' s_flow = s_flow +1 do while(s < len_trim(line)) list_chunk = s + find_end(line(s+1:),']') - if(iskeyValue(line(s+1:list_chunk-1))) then + if(iskeyValue(line(s+1:list_chunk-1))) then flow(s_flow:s_flow) = '{' s_flow = s_flow +1 call keyValue_toFlow(flow,s_flow,line(s+1:list_chunk-1)) @@ -252,10 +252,10 @@ recursive subroutine line_isFlow(flow,s_flow,line) s = s + find_end(line(s+1:),']') enddo s_flow = s_flow - 1 - if (flow(s_flow-1:s_flow-1) == ',') s_flow = s_flow - 1 + if (flow(s_flow-1:s_flow-1) == ',') s_flow = s_flow - 1 flow(s_flow:s_flow) = ']' s_flow = s_flow+1 - + elseif(index(adjustl(line),'{') == 1) then s = index(line,'{') flow(s_flow:s_flow) = '{' @@ -275,21 +275,21 @@ recursive subroutine line_isFlow(flow,s_flow,line) else call line_toFlow(flow,s_flow,line) endif - + end subroutine line_isFlow !------------------------------------------------------------------------------------------------- ! @brief reads a line of YAML block of type : and places it in the YAML flow style structure -! @details Makes sure that the is consistent with the input required in DAMASK YAML parser +! @details Makes sure that the is consistent with the input required in DAMASK YAML parser !------------------------------------------------------------------------------------------------- recursive subroutine keyValue_toFlow(flow,s_flow,line) - + character(len=*), intent(inout) :: flow !< YAML in flow style only integer, intent(inout) :: s_flow !< start position in flow character(len=*), intent(in) :: line - - character(len=:), allocatable :: line_asStandard ! standard form of : + + character(len=:), allocatable :: line_asStandard ! standard form of : integer :: & d_flow, & col_pos, & @@ -318,7 +318,7 @@ subroutine line_toFlow(flow,s_flow,line) character(len=*), intent(inout) :: flow !< YAML in flow style only integer, intent(inout) :: s_flow !< start position in flow character(len=*), intent(in) :: line - + integer :: & d_flow @@ -398,7 +398,7 @@ recursive subroutine lst(blck,flow,s_blck,s_flow,offset) if(isScalar(line) .or. isFlow(line)) then flow(s_flow:s_flow+1) = ', ' - s_flow = s_flow +2 + s_flow = s_flow + 2 endif end do @@ -441,7 +441,7 @@ recursive subroutine dct(blck,flow,s_blck,s_flow,offset) elseif(indentDepth(line,offset) < indent) then if(isScalar(line) .or. isFlow(line) .and. previous_isKey) & call IO_error(701,ext_msg=line) - offset = 0 + offset = 0 exit ! job done (lower level) elseif(indentDepth(line,offset) > indent .or. isListItem(line)) then offset = 0 @@ -455,20 +455,20 @@ recursive subroutine dct(blck,flow,s_blck,s_flow,offset) flow(s_flow-1:s_flow) = ', ' s_flow = s_flow + 1 endif - + if(isKeyValue(line)) then call keyValue_toFlow(flow,s_flow,line) else call line_toFlow(flow,s_flow,line) endif - + s_blck = e_blck +2 end if if(isScalar(line) .or. isKeyValue(line)) then flow(s_flow:s_flow) = ',' s_flow = s_flow + 1 - previous_isKey = .false. + previous_isKey = .false. else previous_isKey = .true. endif @@ -540,7 +540,7 @@ function to_flow(blck) s_flow, & !< start position in flow offset, & !< counts leading '- ' in nested lists end_line - if(isFlow(blck)) then + if(isFlow(blck)) then to_flow = trim(adjustl(blck)) else allocate(character(len=len(blck)*2)::to_flow) @@ -552,43 +552,45 @@ function to_flow(blck) to_flow = trim(to_flow(:s_flow-1)) endif end_line = index(to_flow,IO_EOL) - if(end_line > 0) to_flow = to_flow(:end_line-1) + if(end_line > 0) to_flow = to_flow(:end_line-1) 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') /= 0) call IO_error(0,ext_msg='indentDepth') - if (indentDepth('x ') /= 0) call IO_error(0,ext_msg='indentDepth') + if (indentDepth(' a') /= 1) error stop 'indentDepth' + if (indentDepth('a') /= 0) error stop 'indentDepth' + if (indentDepth('x ') /= 0) error stop 'indentDepth' - if ( isFlow(' a')) call IO_error(0,ext_msg='isFLow') - if (.not. isFlow('{')) call IO_error(0,ext_msg='isFlow') - if (.not. isFlow(' [')) call IO_error(0,ext_msg='isFlow') + if ( isFlow(' a')) error stop 'isFLow' + if (.not. isFlow('{')) error stop 'isFlow' + if (.not. isFlow(' [')) error stop 'isFlow' - if ( isListItem(' a')) call IO_error(0,ext_msg='isListItem') - if ( isListItem(' -b')) call IO_error(0,ext_msg='isListItem') - if (.not. isListItem('- a ')) call IO_error(0,ext_msg='isListItem') - if (.not. isListItem('- -a ')) call IO_error(0,ext_msg='isListItem') + if ( isListItem(' a')) error stop 'isListItem' + if ( isListItem(' -b')) error stop 'isListItem' + if (.not. isListItem('- a ')) error stop 'isListItem' + if (.not. isListItem('- -a ')) error stop 'isListItem' - if ( isKeyValue(' a')) call IO_error(0,ext_msg='isKeyValue') - if ( isKeyValue(' a: ')) call IO_error(0,ext_msg='isKeyValue') - if (.not. isKeyValue(' a: b')) call IO_error(0,ext_msg='isKeyValue') + if ( isKeyValue(' a')) error stop 'isKeyValue' + if ( isKeyValue(' a: ')) error stop 'isKeyValue' + if (.not. isKeyValue(' a: b')) error stop 'isKeyValue' - if ( isKey(' a')) call IO_error(0,ext_msg='isKey') - if ( isKey('{a:b}')) call IO_error(0,ext_msg='isKey') - if ( isKey(' a:b')) call IO_error(0,ext_msg='isKey') - if (.not. isKey(' a: ')) call IO_error(0,ext_msg='isKey') - if (.not. isKey(' a:')) call IO_error(0,ext_msg='isKey') - if (.not. isKey(' a: #')) call IO_error(0,ext_msg='isKey') + if ( isKey(' a')) error stop 'isKey' + if ( isKey('{a:b}')) error stop 'isKey' + if ( isKey(' a:b')) error stop 'isKey' + if (.not. isKey(' a: ')) error stop 'isKey' + if (.not. isKey(' a:')) error stop 'isKey' + if (.not. isKey(' a: #')) error stop 'isKey' - if( isScalar('a: ')) call IO_error(0,ext_msg='isScalar') - if( isScalar('a: b')) call IO_error(0,ext_msg='isScalar') - if( isScalar('{a:b}')) call IO_error(0,ext_msg='isScalar') - if( isScalar('- a:')) call IO_error(0,ext_msg='isScalar') - if(.not. isScalar(' a')) call IO_error(0,ext_msg='isScalar') + if( isScalar('a: ')) error stop 'isScalar' + if( isScalar('a: b')) error stop 'isScalar' + if( isScalar('{a:b}')) error stop 'isScalar' + if( isScalar('- a:')) error stop 'isScalar' + if(.not. isScalar(' a')) error stop 'isScalar' basic_list: block character(len=*), parameter :: block_list = & @@ -602,8 +604,8 @@ subroutine selfTest() character(len=*), parameter :: flow_list = & "[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_newline) == 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) error stop 'to_flow' end block basic_list basic_dict: block @@ -618,10 +620,10 @@ subroutine selfTest() character(len=*), parameter :: flow_dict = & "{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_newline) == 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) error stop 'to_flow' end block basic_dict - + basic_flow: block character(len=*), parameter :: flow_braces = & " source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]"//IO_EOL @@ -629,9 +631,9 @@ subroutine selfTest() " source: [param: 1, {param: 2}, param: 3, {param: 4}]"//IO_EOL character(len=*), parameter :: flow = & "{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_mixed_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) error stop 'to_flow' end block basic_flow basic_mixed: block @@ -644,8 +646,8 @@ subroutine selfTest() " - {param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}"//IO_EOL 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]}}]}]}" - - 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 subroutine selfTest diff --git a/src/YAML_types.f90 b/src/YAML_types.f90 index 9f82e622a..eb16ce260 100644 --- a/src/YAML_types.f90 +++ b/src/YAML_types.f90 @@ -207,11 +207,11 @@ subroutine selfTest select type(s1) class is(tScalar) s1 = '1' - if(s1%asInt() /= 1) call IO_error(0,ext_msg='tScalar_asInt') - if(dNeq(s1%asFloat(),1.0_pReal)) call IO_error(0,ext_msg='tScalar_asFloat') + if(s1%asInt() /= 1) error stop 'tScalar_asInt' + if(dNeq(s1%asFloat(),1.0_pReal)) error stop 'tScalar_asFloat' s1 = 'true' - if(.not. s1%asBool()) call IO_error(0,ext_msg='tScalar_asBool') - if(s1%asString() /= 'true') call IO_error(0,ext_msg='tScalar_asString') + if(.not. s1%asBool()) error stop 'tScalar_asBool' + if(s1%asString() /= 'true') error stop 'tScalar_asString' end select block @@ -232,18 +232,18 @@ subroutine selfTest call l1%append(s1) call l1%append(s2) n => l1 - if(any(l1%asInts() /= [2,3])) call IO_error(0,ext_msg='tList_asInts') - if(any(dNeq(l1%asFloats(),[2.0_pReal,3.0_pReal]))) call IO_error(0,ext_msg='tList_asFloats') - if(n%get_asInt(1) /= 2) call IO_error(0,ext_msg='byIndex_asInt') - if(dNeq(n%get_asFloat(2),3.0_pReal)) call IO_error(0,ext_msg='byIndex_asFloat') + if(any(l1%asInts() /= [2,3])) error stop 'tList_asInts' + if(any(dNeq(l1%asFloats(),[2.0_pReal,3.0_pReal]))) error stop 'tList_asFloats' + if(n%get_asInt(1) /= 2) error stop 'byIndex_asInt' + if(dNeq(n%get_asFloat(2),3.0_pReal)) error stop 'byIndex_asFloat' endselect allocate(tList::l2) select type(l2) class is(tList) call l2%append(l1) - if(any(l2%get_asInts(1) /= [2,3])) call IO_error(0,ext_msg='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(l2%get_asInts(1) /= [2,3])) error stop 'byIndex_asInts' + if(any(dNeq(l2%get_asFloats(1),[2.0_pReal,3.0_pReal]))) error stop 'byIndex_asFloats' n => l2 end select deallocate(n) @@ -265,10 +265,10 @@ subroutine selfTest call l1%append(s2) n => l1 - if(any(l1%asBools() .neqv. [.true., .false.])) call IO_error(0,ext_msg='tList_asBools') - if(any(l1%asStrings() /= ['true ','False'])) call IO_error(0,ext_msg='tList_asStrings') - if(n%get_asBool(2)) call IO_error(0,ext_msg='byIndex_asBool') - if(n%get_asString(1) /= 'true') call IO_error(0,ext_msg='byIndex_asString') + if(any(l1%asBools() .neqv. [.true., .false.])) error stop 'tList_asBools' + if(any(l1%asStrings() /= ['true ','False'])) error stop 'tList_asStrings' + if(n%get_asBool(2)) error stop 'byIndex_asBool' + if(n%get_asString(1) /= 'true') error stop 'byIndex_asString' end block end subroutine selfTest diff --git a/src/base64.f90 b/src/base64.f90 index 3d7a51987..a9cd4eacf 100644 --- a/src/base64.f90 +++ b/src/base64.f90 @@ -167,59 +167,59 @@ subroutine selfTest character(len=*), parameter :: zero_to_three = 'AAECAw==' ! 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(19_pI64) /= 28_pI64) call IO_error(0,ext_msg='base64_nChar/19/28') - if(base64_nChar(18_pI64) /= 24_pI64) call IO_error(0,ext_msg='base64_nChar/18/24') - if(base64_nChar(17_pI64) /= 24_pI64) call IO_error(0,ext_msg='base64_nChar/17/24') - if(base64_nChar(16_pI64) /= 24_pI64) call IO_error(0,ext_msg='base64_nChar/16/24') + if(base64_nChar(20_pI64) /= 28_pI64) error stop 'base64_nChar/20/28' + if(base64_nChar(19_pI64) /= 28_pI64) error stop 'base64_nChar/19/28' + if(base64_nChar(18_pI64) /= 24_pI64) error stop 'base64_nChar/18/24' + if(base64_nChar(17_pI64) /= 24_pI64) error stop 'base64_nChar/17/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(8_pI64) /= 6_pI64) call IO_error(0,ext_msg='base64_nByte/8/6') + if(base64_nByte(4_pI64) /= 3_pI64) error stop 'base64_nByte/4/3' + if(base64_nByte(8_pI64) /= 6_pI64) error stop 'base64_nByte/8/6' 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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) - 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 diff --git a/src/lattice.f90 b/src/lattice.f90 index 659025bb1..e046bc091 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -2299,7 +2299,7 @@ end function equivalent_mu !-------------------------------------------------------------------------------------------------- -!> @brief check correctness of some lattice functions +!> @brief Check correctness of some lattice functions. !-------------------------------------------------------------------------------------------------- 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]) CoSy = buildCoordinateSystem([1],[1],system,'fcc',0.0_pReal) - if(any(dNeq(CoSy(1:3,1:3,1),math_I3))) & - call IO_error(0) + if(any(dNeq(CoSy(1:3,1:3,1),math_I3))) error stop 'buildCoordinateSystem' call random_number(C) C(1,1) = C(1,1) + 1.0_pReal C = applyLatticeSymmetryC66(C,'iso') - if(dNeq(C(6,6),equivalent_mu(C,'voigt'),1.0e-12_pReal)) & - call IO_error(0,ext_msg='equivalent_mu/voigt') - if(dNeq(C(6,6),equivalent_mu(C,'voigt'),1.0e-12_pReal)) & - call IO_error(0,ext_msg='equivalent_mu/reuss') + if(dNeq(C(6,6),equivalent_mu(C,'voigt'),1.0e-12_pReal)) error stop 'equivalent_mu/voigt' + if(dNeq(C(6,6),equivalent_mu(C,'voigt'),1.0e-12_pReal)) error stop 'equivalent_mu/reuss' + lambda = C(1,2) 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)) & - call IO_error(0,ext_msg='equivalent_nu/reuss') + error stop 'equivalent_nu/reuss' end subroutine selfTest diff --git a/src/math.f90 b/src/math.f90 index d41226ed2..5b0e2b987 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -1154,7 +1154,7 @@ end function math_clip !-------------------------------------------------------------------------------------------------- -!> @brief check correctness of some math functions +!> @brief Check correctness of some math functions. !-------------------------------------------------------------------------------------------------- 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] - & 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] - & 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] - & 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) 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_)) & - call IO_error(0,ext_msg='math_range') + error stop 'math_range' - if(any(dNeq(math_exp33(math_I3,0),math_I3))) & - call IO_error(0,ext_msg='math_exp33(math_I3,1)') + if(any(dNeq(math_exp33(math_I3,0),math_I3))) & + error stop 'math_exp33(math_I3,1)' 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) 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) 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) 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) 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) 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_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, & 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) 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)))) & - 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) call random_number(t33) enddo 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) 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)) & - call IO_error(0,ext_msg='math_invert33 (determinant)') + error stop 'math_invert33 (determinant)' call math_invert(t33_2,e,t33) 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 call random_number(t33) @@ -1261,7 +1261,7 @@ subroutine selfTest t33_2 = math_rotationalPart(transpose(t33)) t33 = math_rotationalPart(t33) 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) d = int(r*5.0_pReal) + 1 @@ -1269,30 +1269,30 @@ subroutine selfTest allocate(txx_2(d,d)) call math_invert(txx_2,e,txx) 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 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]))) & - call IO_error(0,ext_msg='math_clip') + error stop 'math_clip' if(math_factorial(10) /= 3628800) & - call IO_error(0,ext_msg='math_factorial') + error stop 'math_factorial' 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)) 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)) 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)) - if(dNeq0(math_LeviCivita(ijk(1),ijk(2),ijk(3))))& - call IO_error(0,ext_msg='math_LeviCivita') + if(dNeq0(math_LeviCivita(ijk(1),ijk(2),ijk(3)))) & + error stop 'math_LeviCivita' end subroutine selfTest diff --git a/src/prec.f90 b/src/prec.f90 index d3ec108fe..6ee3a7e79 100644 --- a/src/prec.f90 +++ b/src/prec.f90 @@ -297,31 +297,29 @@ subroutine selfTest real(pReal), dimension(1) :: f integer(pInt), dimension(1) :: i real(pReal), dimension(2) :: r - external :: & - quit 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) r = r/minval(r) - if(.not. all(dEq(r,r+PREAL_EPSILON))) call quit(9000) - if(dEq(r(1),r(2)) .and. dNeq(r(1),r(2))) call quit(9000) - if(.not. all(dEq0(r-(r+PREAL_MIN)))) 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))) error stop 'dNeq' + if(.not. all(dEq0(r-(r+PREAL_MIN)))) error stop 'dEq0' ! https://www.binaryconvert.com ! 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) - 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) - 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) - 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) - if(i(1) /= 20191102_pInt) call quit(9000) + if(i(1) /= 20191102_pInt) error stop 'bytes_to_C_INT64_T' end subroutine selfTest diff --git a/src/quaternions.f90 b/src/quaternions.f90 index a396f7f67..b5478d634 100644 --- a/src/quaternions.f90 +++ b/src/quaternions.f90 @@ -7,7 +7,6 @@ !--------------------------------------------------------------------------------------------------- module quaternions use prec - use IO implicit none private @@ -464,67 +463,67 @@ subroutine selfTest real(pReal), dimension(4) :: qu 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) qu = (qu-0.5_pReal) * 2.0_pReal q = quaternion(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 - 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 - 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 - 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 - 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 - 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 - 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)) & - 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(dNeq(q%real(), qu(1))) call IO_error(0,ext_msg='real()') - if(any(dNeq(q%aimag(), qu(2:4)))) call IO_error(0,ext_msg='aimag()') + if(any(dNeq(q%asArray(),qu))) error stop 'eq__' + if(dNeq(q%real(), qu(1))) error stop 'real()' + if(any(dNeq(q%aimag(), qu(2:4)))) error stop 'aimag()' q_2 = q%homomorphed() - if(q /= q_2* (-1.0_pReal)) call IO_error(0,ext_msg='homomorphed') - if(dNeq(q_2%real(), qu(1)* (-1.0_pReal))) call IO_error(0,ext_msg='homomorphed/real') - if(any(dNeq(q_2%aimag(),qu(2:4)*(-1.0_pReal)))) call IO_error(0,ext_msg='homomorphed/aimag') + if(q /= q_2* (-1.0_pReal)) error stop 'homomorphed' + 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)))) error stop 'homomorphed/aimag' q_2 = conjg(q) - if(dNeq(abs(q),abs(q_2))) call IO_error(0,ext_msg='conjg/abs') - if(q /= conjg(q_2)) call IO_error(0,ext_msg='conjg/involution') - if(dNeq(q_2%real(), q%real())) call IO_error(0,ext_msg='conjg/real') - if(any(dNeq(q_2%aimag(),q%aimag()*(-1.0_pReal)))) call IO_error(0,ext_msg='conjg/aimag') + if(dNeq(abs(q),abs(q_2))) error stop 'conjg/abs' + if(q /= conjg(q_2)) error stop 'conjg/involution' + if(dNeq(q_2%real(), q%real())) error stop 'conjg/real' + if(any(dNeq(q_2%aimag(),q%aimag()*(-1.0_pReal)))) error stop 'conjg/aimag' if(abs(q) > 0.0_pReal) then 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(any(dNeq0(aimag(q_2), 1.0e-15_pReal))) call IO_error(0,ext_msg='inverse/aimag') + 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))) error stop 'inverse/aimag' q_2 = q/abs(q) 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 - 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 (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-log(exp(q))),1.0e-13_pReal)) call IO_error(0,ext_msg='log/exp') + 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)) error stop 'log/exp' endif #endif diff --git a/src/rotations.f90 b/src/rotations.f90 index ee1cf6b96..baa8cff38 100644 --- a/src/rotations.f90 +++ b/src/rotations.f90 @@ -1371,14 +1371,11 @@ subroutine selfTest real(pReal), dimension(3) :: x, eu, ho, v3 real(pReal), dimension(3,3) :: om, t33 real(pReal), dimension(3,3,3,3) :: t3333 - character(len=pStringLen) :: msg real :: A,B integer :: i do i=1,10 - msg = '' - #if defined(__GFORTRAN__) && __GNUC__<9 if(i<7) cycle #endif @@ -1405,55 +1402,54 @@ subroutine selfTest sin(2.0_pReal*PI*x(1))*A] if(qu(1)<0.0_pReal) qu = qu * (-1.0_pReal) endif - if(.not. quaternion_equal(om2qu(qu2om(qu)),qu)) msg = trim(msg)//'om2qu/qu2om,' - if(.not. quaternion_equal(eu2qu(qu2eu(qu)),qu)) msg = trim(msg)//'eu2qu/qu2eu,' - if(.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) msg = trim(msg)//'ax2qu/qu2ax,' - if(.not. quaternion_equal(ro2qu(qu2ro(qu)),qu)) msg = trim(msg)//'ro2qu/qu2ro,' - if(.not. quaternion_equal(ho2qu(qu2ho(qu)),qu)) msg = trim(msg)//'ho2qu/qu2ho,' - if(.not. quaternion_equal(cu2qu(qu2cu(qu)),qu)) msg = trim(msg)//'cu2qu/qu2cu,' + if(.not. quaternion_equal(om2qu(qu2om(qu)),qu)) error stop 'om2qu/qu2om' + if(.not. quaternion_equal(eu2qu(qu2eu(qu)),qu)) error stop 'eu2qu/qu2eu' + if(.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) error stop 'ax2qu/qu2ax' + if(.not. quaternion_equal(ro2qu(qu2ro(qu)),qu)) error stop 'ro2qu/qu2ro' + if(.not. quaternion_equal(ho2qu(qu2ho(qu)),qu)) error stop 'ho2qu/qu2ho' + if(.not. quaternion_equal(cu2qu(qu2cu(qu)),qu)) error stop 'cu2qu/qu2cu' om = qu2om(qu) - if(.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) msg = trim(msg)//'eu2om/om2eu,' - if(.not. quaternion_equal(om2qu(ax2om(om2ax(om))),qu)) msg = trim(msg)//'ax2om/om2ax,' - if(.not. quaternion_equal(om2qu(ro2om(om2ro(om))),qu)) msg = trim(msg)//'ro2om/om2ro,' - if(.not. quaternion_equal(om2qu(ho2om(om2ho(om))),qu)) msg = trim(msg)//'ho2om/om2ho,' - if(.not. quaternion_equal(om2qu(cu2om(om2cu(om))),qu)) msg = trim(msg)//'cu2om/om2cu,' + if(.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) error stop 'eu2om/om2eu' + if(.not. quaternion_equal(om2qu(ax2om(om2ax(om))),qu)) error stop 'ax2om/om2ax' + if(.not. quaternion_equal(om2qu(ro2om(om2ro(om))),qu)) error stop 'ro2om/om2ro' + if(.not. quaternion_equal(om2qu(ho2om(om2ho(om))),qu)) error stop 'ho2om/om2ho' + if(.not. quaternion_equal(om2qu(cu2om(om2cu(om))),qu)) error stop 'cu2om/om2cu' eu = qu2eu(qu) - if(.not. quaternion_equal(eu2qu(ax2eu(eu2ax(eu))),qu)) msg = trim(msg)//'ax2eu/eu2ax,' - if(.not. quaternion_equal(eu2qu(ro2eu(eu2ro(eu))),qu)) msg = trim(msg)//'ro2eu/eu2ro,' - if(.not. quaternion_equal(eu2qu(ho2eu(eu2ho(eu))),qu)) msg = trim(msg)//'ho2eu/eu2ho,' - if(.not. quaternion_equal(eu2qu(cu2eu(eu2cu(eu))),qu)) msg = trim(msg)//'cu2eu/eu2cu,' + if(.not. quaternion_equal(eu2qu(ax2eu(eu2ax(eu))),qu)) error stop 'ax2eu/eu2ax' + if(.not. quaternion_equal(eu2qu(ro2eu(eu2ro(eu))),qu)) error stop 'ro2eu/eu2ro' + if(.not. quaternion_equal(eu2qu(ho2eu(eu2ho(eu))),qu)) error stop 'ho2eu/eu2ho' + if(.not. quaternion_equal(eu2qu(cu2eu(eu2cu(eu))),qu)) error stop 'cu2eu/eu2cu' ax = qu2ax(qu) - if(.not. quaternion_equal(ax2qu(ro2ax(ax2ro(ax))),qu)) msg = trim(msg)//'ro2ax/ax2ro,' - if(.not. quaternion_equal(ax2qu(ho2ax(ax2ho(ax))),qu)) msg = trim(msg)//'ho2ax/ax2ho,' - if(.not. quaternion_equal(ax2qu(cu2ax(ax2cu(ax))),qu)) msg = trim(msg)//'cu2ax/ax2cu,' + if(.not. quaternion_equal(ax2qu(ro2ax(ax2ro(ax))),qu)) error stop 'ro2ax/ax2ro' + if(.not. quaternion_equal(ax2qu(ho2ax(ax2ho(ax))),qu)) error stop 'ho2ax/ax2ho' + if(.not. quaternion_equal(ax2qu(cu2ax(ax2cu(ax))),qu)) error stop 'cu2ax/ax2cu' ro = qu2ro(qu) - if(.not. quaternion_equal(ro2qu(ho2ro(ro2ho(ro))),qu)) msg = trim(msg)//'ho2ro/ro2ho,' - if(.not. quaternion_equal(ro2qu(cu2ro(ro2cu(ro))),qu)) msg = trim(msg)//'cu2ro/ro2cu,' + if(.not. quaternion_equal(ro2qu(ho2ro(ro2ho(ro))),qu)) error stop 'ho2ro/ro2ho' + if(.not. quaternion_equal(ro2qu(cu2ro(ro2cu(ro))),qu)) error stop 'cu2ro/ro2cu' 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 random_number(v3) 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) 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) if(all(dNeq(R%rotTensor4(R%rotTensor4(t3333),active=.true.),t3333,1.0e-12_pReal))) & - msg = trim(msg)//'rotTensor4,' - - if(len_trim(msg) /= 0) call IO_error(0,ext_msg=msg) + error stop 'rotTensor4' enddo + contains function quaternion_equal(qu1,qu2) result(ok)