!-------------------------------------------------------------------------------------------------- !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @brief input/output functions, partly depending on chosen solver !-------------------------------------------------------------------------------------------------- module IO use prec use DAMASK_interface implicit none private character(len=*), parameter, public :: & IO_EOF = '#EOF#' !< end of file string character, parameter, public :: & IO_EOL = new_line(' ') !< end of line str character(len=*), parameter, private :: & IO_DIVIDER = '───────────────────'//& '───────────────────'//& '───────────────────'//& '────────────' public :: & IO_init, & IO_read_ASCII, & IO_open_jobFile_binary, & IO_isBlank, & IO_getTag, & IO_stringPos, & IO_stringValue, & IO_floatValue, & IO_intValue, & IO_lc, & IO_error, & IO_warning #if defined(Marc4DAMASK) || defined(Abaqus) public :: & IO_open_inputFile #if defined(Abaqus) public :: & IO_continuousIntValues, & IO_extractValue, & IO_countDataLines #endif #endif contains !-------------------------------------------------------------------------------------------------- !> @brief does nothing. !-------------------------------------------------------------------------------------------------- subroutine IO_init write(6,'(/,a)') ' <<<+- IO init -+>>>'; flush(6) call unitTest end subroutine IO_init !-------------------------------------------------------------------------------------------------- !> @brief reads an entire ASCII file into an array !-------------------------------------------------------------------------------------------------- function IO_read_ASCII(fileName) result(fileContent) character(len=*), intent(in) :: fileName character(len=pStringLen), dimension(:), allocatable :: fileContent !< file content, separated per lines character(len=pStringLen) :: line character(len=:), allocatable :: rawData integer :: & fileLength, & fileUnit, & startPos, endPos, & myTotalLines, & !< # lines read from file l, & myStat logical :: warned !-------------------------------------------------------------------------------------------------- ! read data as stream inquire(file = fileName, size=fileLength) if (fileLength == 0) then allocate(fileContent(0)) return endif open(newunit=fileUnit, file=fileName, access='stream',& status='old', position='rewind', action='read',iostat=myStat) if(myStat /= 0) call IO_error(100,ext_msg=trim(fileName)) allocate(character(len=fileLength)::rawData) read(fileUnit) rawData close(fileUnit) !-------------------------------------------------------------------------------------------------- ! count lines to allocate string array myTotalLines = 1 do l=1, len(rawData) if (rawData(l:l) == IO_EOL) myTotalLines = myTotalLines+1 enddo allocate(fileContent(myTotalLines)) !-------------------------------------------------------------------------------------------------- ! split raw data at end of line warned = .false. startPos = 1 l = 1 do while (l <= myTotalLines) endPos = merge(startPos + scan(rawData(startPos:),IO_EOL) - 2,len(rawData),l /= myTotalLines) if (endPos - startPos > pStringLen-1) then line = rawData(startPos:startPos+pStringLen-1) if (.not. warned) then call IO_warning(207,ext_msg=trim(fileName),el=l) warned = .true. endif else line = rawData(startPos:endpos) endif startPos = endPos + 2 ! jump to next line start fileContent(l) = line l = l + 1 enddo end function IO_read_ASCII !-------------------------------------------------------------------------------------------------- !> @brief opens an existing file for reading or a new file for writing. Name is the job name !> @details replaces an existing file when writing !-------------------------------------------------------------------------------------------------- integer function IO_open_jobFile_binary(extension,mode) character(len=*), intent(in) :: extension character, intent(in), optional :: mode if (present(mode)) then IO_open_jobFile_binary = IO_open_binary(trim(getSolverJobName())//'.'//trim(extension),mode) else IO_open_jobFile_binary = IO_open_binary(trim(getSolverJobName())//'.'//trim(extension)) endif end function IO_open_jobFile_binary !-------------------------------------------------------------------------------------------------- !> @brief opens an existing file for reading or a new file for writing. !> @details replaces an existing file when writing !-------------------------------------------------------------------------------------------------- integer function IO_open_binary(fileName,mode) character(len=*), intent(in) :: fileName character, intent(in), optional :: mode character :: m integer :: ierr if (present(mode)) then m = mode else m = 'r' endif if (m == 'w') then open(newunit=IO_open_binary, file=trim(fileName),& status='replace',access='stream',action='write',iostat=ierr) if (ierr /= 0) call IO_error(100,ext_msg='could not open file (w): '//trim(fileName)) elseif(m == 'r') then open(newunit=IO_open_binary, file=trim(fileName),& status='old', access='stream',action='read', iostat=ierr) if (ierr /= 0) call IO_error(100,ext_msg='could not open file (r): '//trim(fileName)) else call IO_error(100,ext_msg='unknown access mode: '//m) endif end function IO_open_binary #if defined(Marc4DAMASK) || defined(Abaqus) !-------------------------------------------------------------------------------------------------- !> @brief opens FEM input file for reading located in current working directory to given unit !-------------------------------------------------------------------------------------------------- subroutine IO_open_inputFile(fileUnit) integer, intent(in) :: fileUnit !< file unit integer :: myStat character(len=1024) :: path #if defined(Abaqus) integer :: fileType fileType = 1 ! assume .pes path = trim(getSolverJobName())//inputFileExtension(fileType) ! attempt .pes, if it exists: it should be used open(fileUnit+1,status='old',iostat=myStat,file=path,action='read',position='rewind') if(myStat /= 0) then ! if .pes does not work / exist; use conventional extension, i.e.".inp" fileType = 2 path = trim(getSolverJobName())//inputFileExtension(fileType) open(fileUnit+1,status='old',iostat=myStat,file=path,action='read',position='rewind') endif if (myStat /= 0) call IO_error(100,el=myStat,ext_msg=path) path = trim(getSolverJobName())//inputFileExtension(fileType)//'_assembly' open(fileUnit,iostat=myStat,file=path) if (myStat /= 0) call IO_error(100,el=myStat,ext_msg=path) if (.not.abaqus_assembleInputFile(fileUnit,fileUnit+1)) call IO_error(103) ! strip comments and concatenate any "include"s close(fileUnit+1) contains !-------------------------------------------------------------------------------------------------- !> @brief create a new input file for abaqus simulations by removing all comment lines and !> including "include"s !-------------------------------------------------------------------------------------------------- recursive function abaqus_assembleInputFile(unit1,unit2) result(createSuccess) integer, intent(in) :: unit1, & unit2 integer, allocatable, dimension(:) :: chunkPos character(len=pStringLen :: line,fname logical :: createSuccess,fexist do read(unit2,'(A)',END=220) line chunkPos = IO_stringPos(line) if (IO_lc(IO_StringValue(line,chunkPos,1))=='*include') then fname = trim(line(9+scan(line(9:),'='):)) inquire(file=fname, exist=fexist) if (.not.(fexist)) then write(6,*)'ERROR: file does not exist error in abaqus_assembleInputFile' write(6,*)'filename: ', trim(fname) createSuccess = .false. return endif open(unit2+1,err=200,status='old',file=fname) if (abaqus_assembleInputFile(unit1,unit2+1)) then createSuccess=.true. close(unit2+1) else createSuccess=.false. return endif else if (line(1:2) /= '**' .OR. line(1:8)=='**damask') then write(unit1,'(A)') trim(line) endif enddo 220 createSuccess = .true. return 200 createSuccess =.false. end function abaqus_assembleInputFile #elif defined(Marc4DAMASK) path = trim(getSolverJobName())//inputFileExtension open(fileUnit,status='old',iostat=myStat,file=path) if (myStat /= 0) call IO_error(100,el=myStat,ext_msg=path) #endif end subroutine IO_open_inputFile #endif !-------------------------------------------------------------------------------------------------- !> @brief identifies strings without content !-------------------------------------------------------------------------------------------------- logical pure function IO_isBlank(string) character(len=*), intent(in) :: string !< string to check for content character(len=*), parameter :: blankChar = achar(32)//achar(9)//achar(10)//achar(13) ! whitespaces character(len=*), parameter :: comment = achar(35) ! comment id '#' integer :: posNonBlank, posComment posNonBlank = verify(string,blankChar) posComment = scan(string,comment) IO_isBlank = posNonBlank == 0 .or. posNonBlank == posComment end function IO_isBlank !-------------------------------------------------------------------------------------------------- !> @brief get tagged content of string !-------------------------------------------------------------------------------------------------- pure function IO_getTag(string,openChar,closeChar) character(len=:), allocatable :: IO_getTag character(len=*), intent(in) :: string !< string to check for tag character, intent(in) :: openChar, & !< indicates beginning of tag closeChar !< indicates end of tag character(len=*), parameter :: SEP=achar(32)//achar(9)//achar(10)//achar(13) ! whitespaces integer :: left,right if (openChar /= closeChar) then left = scan(string,openChar) right = scan(string,closeChar) else left = scan(string,openChar) right = left + merge(scan(string(left+1:),openChar),0,len(string) > left) endif foundTag: if (left == verify(string,SEP) .and. right > left) then IO_getTag = string(left+1:right-1) else foundTag IO_getTag = '' endif foundTag end function IO_getTag !-------------------------------------------------------------------------------------------------- !> @brief locates all space-separated chunks in given string and returns array containing number !! them and the left/right position to be used by IO_xxxVal !! Array size is dynamically adjusted to number of chunks found in string !! IMPORTANT: first element contains number of chunks! !-------------------------------------------------------------------------------------------------- pure function IO_stringPos(string) integer, dimension(:), allocatable :: IO_stringPos character(len=*), intent(in) :: string !< string in which chunk positions are searched for character(len=*), parameter :: SEP=achar(44)//achar(32)//achar(9)//achar(10)//achar(13) ! comma and whitespaces integer :: left, right allocate(IO_stringPos(1), source=0) right = 0 do while (verify(string(right+1:),SEP)>0) left = right + verify(string(right+1:),SEP) right = left + scan(string(left:),SEP) - 2 if ( string(left:left) == '#' ) exit IO_stringPos = [IO_stringPos,left,right] IO_stringPos(1) = IO_stringPos(1)+1 endOfString: if (right < left) then IO_stringPos(IO_stringPos(1)*2+1) = len_trim(string) exit endif endOfString enddo end function IO_stringPos !-------------------------------------------------------------------------------------------------- !> @brief reads string value at myChunk from string !-------------------------------------------------------------------------------------------------- function IO_stringValue(string,chunkPos,myChunk) character(len=*), intent(in) :: string !< raw input with known start and end of each chunk integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string integer, intent(in) :: myChunk !< position number of desired chunk character(len=:), allocatable :: IO_stringValue validChunk: if (myChunk > chunkPos(1) .or. myChunk < 1) then IO_stringValue = '' call IO_error(110,el=myChunk,ext_msg='IO_stringValue '//trim(string)) else validChunk IO_stringValue = string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)) endif validChunk end function IO_stringValue !-------------------------------------------------------------------------------------------------- !> @brief reads integer value at myChunk from string !-------------------------------------------------------------------------------------------------- integer function IO_intValue(string,chunkPos,myChunk) character(len=*), intent(in) :: string !< raw input with known start and end of each chunk integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string integer, intent(in) :: myChunk !< position number of desired chunk IO_intValue = verifyIntValue(IO_stringValue(string,chunkPos,myChunk)) end function IO_intValue !-------------------------------------------------------------------------------------------------- !> @brief reads float value at myChunk from string !-------------------------------------------------------------------------------------------------- real(pReal) function IO_floatValue(string,chunkPos,myChunk) character(len=*), intent(in) :: string !< raw input with known start and end of each chunk integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string integer, intent(in) :: myChunk !< position number of desired chunk IO_floatValue = verifyFloatValue(IO_stringValue(string,chunkPos,myChunk)) end function IO_floatValue !-------------------------------------------------------------------------------------------------- !> @brief changes characters in string to lower case !-------------------------------------------------------------------------------------------------- pure function IO_lc(string) character(len=*), intent(in) :: string !< string to convert character(len=len(string)) :: IO_lc character(26), parameter :: LOWER = 'abcdefghijklmnopqrstuvwxyz' character(26), parameter :: UPPER = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' integer :: i,n do i=1,len(string) IO_lc(i:i) = string(i:i) n = index(UPPER,IO_lc(i:i)) if (n/=0) IO_lc(i:i) = LOWER(n:n) enddo end function IO_lc !-------------------------------------------------------------------------------------------------- !> @brief write error statements to standard out and terminate the Marc/spectral run with exit #9xxx !> in ABAQUS either time step is reduced or execution terminated !-------------------------------------------------------------------------------------------------- subroutine IO_error(error_ID,el,ip,g,instance,ext_msg) integer, intent(in) :: error_ID integer, optional, intent(in) :: el,ip,g,instance character(len=*), optional, intent(in) :: ext_msg external :: quit character(len=pStringLen) :: msg character(len=pStringLen) :: formatString select case (error_ID) !-------------------------------------------------------------------------------------------------- ! internal errors case (0) msg = 'internal check failed:' !-------------------------------------------------------------------------------------------------- ! file handling errors case (100) msg = 'could not open file:' case (101) msg = 'write error for file:' case (102) msg = 'could not read file:' case (103) msg = 'could not assemble input files' case (106) msg = 'working directory does not exist:' !-------------------------------------------------------------------------------------------------- ! file parsing errors case (110) msg = 'invalid chunk selected' case (111) msg = 'invalid character for int:' case (112) msg = 'invalid character for float:' !-------------------------------------------------------------------------------------------------- ! lattice error messages case (130) msg = 'unknown lattice structure encountered' case (131) msg = 'hex lattice structure with invalid c/a ratio' case (132) msg = 'trans_lattice_structure not possible' case (133) msg = 'transformed hex lattice structure with invalid c/a ratio' case (134) msg = 'negative lattice parameter' case (135) msg = 'zero entry on stiffness diagonal' case (136) msg = 'zero entry on stiffness diagonal for transformed phase' case (137) msg = 'not defined for lattice structure' case (138) msg = 'not enough interaction parameters given' !-------------------------------------------------------------------------------------------------- ! errors related to the parsing of material.config case (140) msg = 'key not found' case (141) msg = 'number of chunks in string differs' case (142) msg = 'empty list' case (143) msg = 'no value found for key' case (144) msg = 'negative number systems requested' case (145) msg = 'too many systems requested' case (146) msg = 'number of values does not match' case (147) msg = 'not supported anymore' !-------------------------------------------------------------------------------------------------- ! material error messages and related messages in mesh case (150) msg = 'index out of bounds' case (151) msg = 'microstructure has no constituents' case (153) msg = 'sum of phase fractions differs from 1' case (154) msg = 'homogenization index out of bounds' case (155) msg = 'microstructure index out of bounds' case (157) msg = 'invalid texture transformation specified' case (160) msg = 'no entries in config part' case (161) msg = 'config part found twice' case (165) msg = 'homogenization configuration' case (170) msg = 'no homogenization specified via State Variable 2' case (180) msg = 'no microstructure specified via State Variable 3' case (190) msg = 'unknown element type:' case (191) msg = 'mesh consists of more than one element type' !-------------------------------------------------------------------------------------------------- ! plasticity error messages case (200) msg = 'unknown elasticity specified:' case (201) msg = 'unknown plasticity specified:' case (210) msg = 'unknown material parameter:' case (211) msg = 'material parameter out of bounds:' !-------------------------------------------------------------------------------------------------- ! numerics error messages case (300) msg = 'unknown numerics parameter:' case (301) msg = 'numerics parameter out of bounds:' !-------------------------------------------------------------------------------------------------- ! math errors case (400) msg = 'matrix inversion error' case (402) msg = 'invalid orientation specified' !------------------------------------------------------------------------------------------------- ! homogenization errors case (500) msg = 'unknown homogenization specified' !-------------------------------------------------------------------------------------------------- ! user errors case (600) msg = 'Ping-Pong not possible when using non-DAMASK elements' case (601) msg = 'Ping-Pong needed when using non-local plasticity' case (602) msg = 'invalid selection for debug' !------------------------------------------------------------------------------------------------- ! errors related to the grid solver case (809) msg = 'initializing FFTW' case (810) msg = 'FFTW plan creation' case (831) msg = 'mask consistency violated in grid load case' case (832) msg = 'ill-defined L (line partly defined) in grid load case' case (834) msg = 'negative time increment in grid load case' case (835) msg = 'non-positive increments in grid load case' case (836) msg = 'non-positive result frequency in grid load case' case (837) msg = 'incomplete loadcase' case (838) msg = 'mixed boundary conditions allow rotation' case (839) msg = 'non-positive restart frequency in grid load case' case (841) msg = 'missing header length info in grid mesh' case (842) msg = 'incomplete information in grid mesh header' case (843) msg = 'microstructure count mismatch' case (846) msg = 'rotation for load case rotation ill-defined (R:RT != I)' case (891) msg = 'unknown solver type selected' case (892) msg = 'unknown filter type selected' case (894) msg = 'MPI error' !------------------------------------------------------------------------------------------------- ! error messages related to parsing of Abaqus input file case (900) msg = 'improper definition of nodes in input file (Nnodes < 2)' case (901) msg = 'no elements defined in input file (Nelems = 0)' case (902) msg = 'no element sets defined in input file (No *Elset exists)' case (903) msg = 'no materials defined in input file (Look into section assigments)' case (904) msg = 'no elements could be assigned for Elset: ' case (905) msg = 'error in mesh_abaqus_map_materials' case (906) msg = 'error in mesh_abaqus_count_cpElements' case (907) msg = 'size of mesh_mapFEtoCPelem in mesh_abaqus_map_elements' case (908) msg = 'size of mesh_mapFEtoCPnode in mesh_abaqus_map_nodes' case (909) msg = 'size of mesh_node in mesh_abaqus_build_nodes not equal to mesh_Nnodes' !------------------------------------------------------------------------------------------------- ! general error messages case default msg = 'unknown error number...' end select !$OMP CRITICAL (write2out) write(0,'(/,a)') ' ┌'//IO_DIVIDER//'┐' write(0,'(a,24x,a,40x,a)') ' │','error', '│' write(0,'(a,24x,i3,42x,a)') ' │',error_ID, '│' write(0,'(a)') ' ├'//IO_DIVIDER//'┤' write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(msg)),',',& max(1,72-len_trim(msg)-4),'x,a)' write(0,formatString) '│ ',trim(msg), '│' if (present(ext_msg)) then write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(ext_msg)),',',& max(1,72-len_trim(ext_msg)-4),'x,a)' write(0,formatString) '│ ',trim(ext_msg), '│' endif if (present(el)) & write(0,'(a19,1x,i9,44x,a3)') ' │ at element ',el, '│' if (present(ip)) & write(0,'(a19,1x,i9,44x,a3)') ' │ at IP ',ip, '│' if (present(g)) & write(0,'(a19,1x,i9,44x,a3)') ' │ at constituent',g, '│' if (present(instance)) & write(0,'(a19,1x,i9,44x,a3)') ' │ at instance ',instance, '│' write(0,'(a,69x,a)') ' │', '│' write(0,'(a)') ' └'//IO_DIVIDER//'┘' flush(0) call quit(9000+error_ID) !$OMP END CRITICAL (write2out) end subroutine IO_error !-------------------------------------------------------------------------------------------------- !> @brief writes warning statement to standard out !-------------------------------------------------------------------------------------------------- subroutine IO_warning(warning_ID,el,ip,g,ext_msg) integer, intent(in) :: warning_ID integer, optional, intent(in) :: el,ip,g character(len=*), optional, intent(in) :: ext_msg character(len=pStringLen) :: msg character(len=pStringLen) :: formatString select case (warning_ID) case (1) msg = 'unknown key' case (34) msg = 'invalid restart increment given' case (35) msg = 'could not get $DAMASK_NUM_THREADS' case (40) msg = 'found spectral solver parameter' case (42) msg = 'parameter has no effect' case (43) msg = 'main diagonal of C66 close to zero' case (47) msg = 'no valid parameter for FFTW, using FFTW_PATIENT' case (50) msg = 'not all available slip system families are defined' case (51) msg = 'not all available twin system families are defined' case (52) msg = 'not all available parameters are defined' case (53) msg = 'not all available transformation system families are defined' case (101) msg = 'crystallite debugging off' case (201) msg = 'position not found when parsing line' case (207) msg = 'line truncated' case (600) msg = 'crystallite responds elastically' case (601) msg = 'stiffness close to zero' case (650) msg = 'polar decomposition failed' case (700) msg = 'unknown crystal symmetry' case (850) msg = 'max number of cut back exceeded, terminating' case default msg = 'unknown warning number' end select !$OMP CRITICAL (write2out) write(6,'(/,a)') ' ┌'//IO_DIVIDER//'┐' write(6,'(a,24x,a,38x,a)') ' │','warning', '│' write(6,'(a,24x,i3,42x,a)') ' │',warning_ID, '│' write(6,'(a)') ' ├'//IO_DIVIDER//'┤' write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(msg)),',',& max(1,72-len_trim(msg)-4),'x,a)' write(6,formatString) '│ ',trim(msg), '│' if (present(ext_msg)) then write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(ext_msg)),',',& max(1,72-len_trim(ext_msg)-4),'x,a)' write(6,formatString) '│ ',trim(ext_msg), '│' endif if (present(el)) & write(6,'(a19,1x,i9,44x,a3)') ' │ at element ',el, '│' if (present(ip)) & write(6,'(a19,1x,i9,44x,a3)') ' │ at IP ',ip, '│' if (present(g)) & write(6,'(a19,1x,i9,44x,a3)') ' │ at constituent',g, '│' write(6,'(a,69x,a)') ' │', '│' write(6,'(a)') ' └'//IO_DIVIDER//'┘' flush(6) !$OMP END CRITICAL (write2out) end subroutine IO_warning #ifdef Abaqus !-------------------------------------------------------------------------------------------------- !> @brief extracts string value from key=value pair and check whether key matches !-------------------------------------------------------------------------------------------------- character(len=300) pure function IO_extractValue(pair,key) character(len=*), intent(in) :: pair, & !< key=value pair key !< key to be expected character(len=*), parameter :: SEP = achar(61) ! '=' integer :: myChunk !< position number of desired chunk IO_extractValue = '' myChunk = scan(pair,SEP) if (myChunk > 0 .and. pair(:myChunk-1) == key) IO_extractValue = pair(myChunk+1:) ! extract value if key matches end function IO_extractValue !-------------------------------------------------------------------------------------------------- !> @brief count lines containig data up to next *keyword !-------------------------------------------------------------------------------------------------- integer function IO_countDataLines(fileUnit) integer, intent(in) :: fileUnit !< file handle integer, allocatable, dimension(:) :: chunkPos character(len=pStringLen) :: line, & tmp IO_countDataLines = 0 line = '' do while (trim(line) /= IO_EOF) read(fileUnit,'(A)') line chunkPos = IO_stringPos(line) tmp = IO_lc(IO_stringValue(line,chunkPos,1)) if (tmp(1:1) == '*' .and. tmp(2:2) /= '*') then ! found keyword exit else if (tmp(2:2) /= '*') IO_countDataLines = IO_countDataLines + 1 endif enddo backspace(fileUnit) end function IO_countDataLines !-------------------------------------------------------------------------------------------------- !> @brief return integer list corresponding to items in consecutive lines. !! First integer in array is counter !> @details Abaqus: triplet of start,stop,inc or named set !-------------------------------------------------------------------------------------------------- function IO_continuousIntValues(fileUnit,maxN,lookupName,lookupMap,lookupMaxN) integer, intent(in) :: maxN integer, dimension(1+maxN) :: IO_continuousIntValues integer, intent(in) :: fileUnit, & lookupMaxN integer, dimension(:,:), intent(in) :: lookupMap character(len=*), dimension(:), intent(in) :: lookupName integer :: i,first,last integer :: j,l,c integer, allocatable, dimension(:) :: chunkPos character(len=pStringLen) :: line logical :: rangeGeneration IO_continuousIntValues = 0 rangeGeneration = .false. c = IO_countDataLines(fileUnit) do l = 1,c backspace(fileUnit) enddo !-------------------------------------------------------------------------------------------------- ! check if the element values in the elset are auto generated backspace(fileUnit) read(fileUnit,'(A)',end=100) line chunkPos = IO_stringPos(line) do i = 1,chunkPos(1) if (IO_lc(IO_stringValue(line,chunkPos,i)) == 'generate') rangeGeneration = .true. enddo do l = 1,c read(fileUnit,'(A)',end=100) line chunkPos = IO_stringPos(line) if (verify(IO_stringValue(line,chunkPos,1),'0123456789') > 0) then ! a non-int, i.e. set names follow on this line do i = 1,chunkPos(1) ! loop over set names in line do j = 1,lookupMaxN ! look through known set names if (IO_stringValue(line,chunkPos,i) == lookupName(j)) then ! found matching name first = 2 + IO_continuousIntValues(1) ! where to start appending data last = first + lookupMap(1,j) - 1 ! up to where to append data IO_continuousIntValues(first:last) = lookupMap(2:1+lookupMap(1,j),j) ! add resp. entity list IO_continuousIntValues(1) = IO_continuousIntValues(1) + lookupMap(1,j) ! count them endif enddo enddo else if (rangeGeneration) then ! range generation do i = IO_intValue(line,chunkPos,1),& IO_intValue(line,chunkPos,2),& max(1,IO_intValue(line,chunkPos,3)) IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1 IO_continuousIntValues(1+IO_continuousIntValues(1)) = i enddo else ! read individual elem nums do i = 1,chunkPos(1) IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1 IO_continuousIntValues(1+IO_continuousIntValues(1)) = IO_intValue(line,chunkPos,i) enddo endif enddo 100 end function IO_continuousIntValues #endif !-------------------------------------------------------------------------------------------------- ! internal helper functions !-------------------------------------------------------------------------------------------------- !> @brief returns verified integer value in given string !-------------------------------------------------------------------------------------------------- integer function verifyIntValue(string) character(len=*), intent(in) :: string !< string for conversion to int value integer :: readStatus, invalidWhere character(len=*), parameter :: VALIDCHARS = '0123456789+- ' invalidWhere = verify(string,VALIDCHARS) valid: if (invalidWhere == 0) then read(string,*,iostat=readStatus) verifyIntValue if (readStatus /= 0) call IO_error(111,ext_msg=string) else valid verifyIntValue = 0 call IO_error(111,ext_msg=string) endif valid end function verifyIntValue !-------------------------------------------------------------------------------------------------- !> @brief returns verified float value in given string !-------------------------------------------------------------------------------------------------- real(pReal) function verifyFloatValue(string) character(len=*), intent(in) :: string !< string for conversion to float value integer :: readStatus, invalidWhere character(len=*), parameter :: VALIDCHARS = '0123456789eE.+- ' invalidWhere = verify(string,VALIDCHARS) valid: if (invalidWhere == 0) then read(string,*,iostat=readStatus) verifyFloatValue if (readStatus /= 0) call IO_error(112,ext_msg=string) else valid verifyFloatValue = 0.0_pReal call IO_error(112,ext_msg=string) endif valid end function verifyFloatValue !-------------------------------------------------------------------------------------------------- !> @brief check correctness of IO functions !-------------------------------------------------------------------------------------------------- subroutine unitTest integer, dimension(:), allocatable :: chunkPos character(len=:), allocatable :: str if(dNeq(1.0_pReal, verifyFloatValue('1.0'))) call IO_error(0,ext_msg='verifyFloatValue') if(dNeq(1.0_pReal, verifyFloatValue('1e0'))) call IO_error(0,ext_msg='verifyFloatValue') if(dNeq(0.1_pReal, verifyFloatValue('1e-1'))) call IO_error(0,ext_msg='verifyFloatValue') if(3112019 /= verifyIntValue( '3112019')) call IO_error(0,ext_msg='verifyIntValue') if(3112019 /= verifyIntValue(' 3112019')) call IO_error(0,ext_msg='verifyIntValue') if(-3112019 /= verifyIntValue('-3112019')) call IO_error(0,ext_msg='verifyIntValue') if(3112019 /= verifyIntValue('+3112019 ')) call IO_error(0,ext_msg='verifyIntValue') 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') 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') str='M 3112019 F' chunkPos = IO_stringPos(str) if(3112019 /= IO_intValue(str,chunkPos,2)) call IO_error(0,ext_msg='IO_intValue') end subroutine unitTest end module IO