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

Fortran style adjustments

This commit is contained in:
Martin Diehl 2022-12-07 17:29:03 +00:00
parent 0b24a17a4b
commit aaae8a701b
27 changed files with 539 additions and 539 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/CLI.f90
View File

@ -209,7 +209,7 @@ subroutine setWorkingDirectory(workingDirectoryArg)
workingDirectory = trim(rectifyPath(workingDirectory)) workingDirectory = trim(rectifyPath(workingDirectory))
error = setCWD(trim(workingDirectory)) error = setCWD(trim(workingDirectory))
if(error) then if (error) then
print*, 'ERROR: Invalid Working directory: '//trim(workingDirectory) print*, 'ERROR: Invalid Working directory: '//trim(workingDirectory)
call quit(1) call quit(1)
end if end if
@ -324,7 +324,7 @@ function rectifyPath(path)
end if end if
i = j+index(rectifyPath(j+1:l),'../') i = j+index(rectifyPath(j+1:l),'../')
end do end do
if(len_trim(rectifyPath) == 0) rectifyPath = '/' if (len_trim(rectifyPath) == 0) rectifyPath = '/'
rectifyPath = trim(rectifyPath) rectifyPath = trim(rectifyPath)

262
src/HDF5_utilities.f90
View File

@ -183,7 +183,7 @@ integer(HID_T) function HDF5_openFile(fileName,mode,parallel)
end if end if
call H5Pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) call H5Pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
#ifdef PETSC #ifdef PETSC
if (present(parallel)) then if (present(parallel)) then
@ -197,24 +197,24 @@ integer(HID_T) function HDF5_openFile(fileName,mode,parallel)
call H5Pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) call H5Pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr)
#endif #endif
end if end if
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
#endif #endif
if (m == 'w') then if (m == 'w') then
call H5Fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) call H5Fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
elseif(m == 'a') then elseif (m == 'a') then
call H5Fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) call H5Fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
elseif(m == 'r') then elseif (m == 'r') then
call H5Fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) call H5Fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
else else
error stop 'unknown access mode' error stop 'unknown access mode'
end if end if
call H5Pclose_f(plist_id, hdferr) call H5Pclose_f(plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end function HDF5_openFile end function HDF5_openFile
@ -229,7 +229,7 @@ subroutine HDF5_closeFile(fileHandle)
integer :: hdferr integer :: hdferr
call H5Fclose_f(fileHandle,hdferr) call H5Fclose_f(fileHandle,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_closeFile end subroutine HDF5_closeFile
@ -248,19 +248,19 @@ integer(HID_T) function HDF5_addGroup(fileHandle,groupName)
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! creating a property list for data access properties ! creating a property list for data access properties
call H5Pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) call H5Pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! setting I/O mode to collective ! setting I/O mode to collective
#ifdef PETSC #ifdef PETSC
call H5Pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) call H5Pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
#endif #endif
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! Create group ! Create group
call H5Gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) call H5Gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Pclose_f(aplist_id,hdferr) call H5Pclose_f(aplist_id,hdferr)
@ -284,19 +284,19 @@ integer(HID_T) function HDF5_openGroup(fileHandle,groupName)
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! creating a property list for data access properties ! creating a property list for data access properties
call H5Pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) call H5Pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! setting I/O mode to collective ! setting I/O mode to collective
#ifdef PETSC #ifdef PETSC
call H5Pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) call H5Pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
#endif #endif
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! opening the group ! opening the group
call H5Gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) call H5Gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Pclose_f(aplist_id,hdferr) call H5Pclose_f(aplist_id,hdferr)
@ -313,7 +313,7 @@ subroutine HDF5_closeGroup(group_id)
integer :: hdferr integer :: hdferr
call H5Gclose_f(group_id, hdferr) call H5Gclose_f(group_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_closeGroup end subroutine HDF5_closeGroup
@ -337,11 +337,11 @@ logical function HDF5_objectExists(loc_id,path)
end if end if
call H5Lexists_f(loc_id, p, HDF5_objectExists, hdferr) call H5Lexists_f(loc_id, p, HDF5_objectExists, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
if(HDF5_objectExists) then if (HDF5_objectExists) then
call H5Oexists_by_name_f(loc_id, p, HDF5_objectExists, hdferr) call H5Oexists_by_name_f(loc_id, p, HDF5_objectExists, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
end function HDF5_objectExists end function HDF5_objectExists
@ -374,24 +374,24 @@ subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path)
ptr(1) = c_loc(attrValue_(1)) ptr(1) = c_loc(attrValue_(1))
call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) call H5Screate_f(H5S_SCALAR_F,space_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
if (attrExists) then if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_STRING,space_id,attr_id,hdferr) call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_STRING,space_id,attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Awrite_f(attr_id, H5T_STRING, c_loc(ptr), hdferr) ! ptr instead of c_loc(ptr) works on gfortran, not on ifort call H5Awrite_f(attr_id, H5T_STRING, c_loc(ptr), hdferr) ! ptr instead of c_loc(ptr) works on gfortran, not on ifort
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aclose_f(attr_id,hdferr) call H5Aclose_f(attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(space_id,hdferr) call H5Sclose_f(space_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_addAttribute_str end subroutine HDF5_addAttribute_str
@ -419,24 +419,24 @@ subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path)
end if end if
call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) call H5Screate_f(H5S_SCALAR_F,space_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
if (attrExists) then if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, int([1],HSIZE_T), hdferr) call H5Awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, int([1],HSIZE_T), hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aclose_f(attr_id,hdferr) call H5Aclose_f(attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(space_id,hdferr) call H5Sclose_f(space_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_addAttribute_int end subroutine HDF5_addAttribute_int
@ -464,24 +464,24 @@ subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path)
end if end if
call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) call H5Screate_f(H5S_SCALAR_F,space_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
if (attrExists) then if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, int([1],HSIZE_T), hdferr) call H5Awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, int([1],HSIZE_T), hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aclose_f(attr_id,hdferr) call H5Aclose_f(attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(space_id,hdferr) call H5Sclose_f(space_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_addAttribute_real end subroutine HDF5_addAttribute_real
@ -516,24 +516,24 @@ subroutine HDF5_addAttribute_str_array(loc_id,attrLabel,attrValue,path)
end do end do
call H5Screate_simple_f(1,shape(attrValue_,kind=HSIZE_T),space_id,hdferr,shape(attrValue_,kind=HSIZE_T)) call H5Screate_simple_f(1,shape(attrValue_,kind=HSIZE_T),space_id,hdferr,shape(attrValue_,kind=HSIZE_T))
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
if (attrExists) then if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_STRING,space_id,attr_id,hdferr) call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_STRING,space_id,attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Awrite_f(attr_id, H5T_STRING, c_loc(ptr), hdferr) ! ptr instead of c_loc(ptr) works on gfortran, not on ifort call H5Awrite_f(attr_id, H5T_STRING, c_loc(ptr), hdferr) ! ptr instead of c_loc(ptr) works on gfortran, not on ifort
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aclose_f(attr_id,hdferr) call H5Aclose_f(attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(space_id,hdferr) call H5Sclose_f(space_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_addAttribute_str_array end subroutine HDF5_addAttribute_str_array
@ -564,24 +564,24 @@ subroutine HDF5_addAttribute_int_array(loc_id,attrLabel,attrValue,path)
array_size = size(attrValue,kind=HSIZE_T) array_size = size(attrValue,kind=HSIZE_T)
call H5Screate_simple_f(1, array_size, space_id, hdferr, array_size) call H5Screate_simple_f(1, array_size, space_id, hdferr, array_size)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
if (attrExists) then if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, array_size, hdferr) call H5Awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, array_size, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aclose_f(attr_id,hdferr) call H5Aclose_f(attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(space_id,hdferr) call H5Sclose_f(space_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_addAttribute_int_array end subroutine HDF5_addAttribute_int_array
@ -612,24 +612,24 @@ subroutine HDF5_addAttribute_real_array(loc_id,attrLabel,attrValue,path)
array_size = size(attrValue,kind=HSIZE_T) array_size = size(attrValue,kind=HSIZE_T)
call H5Screate_simple_f(1, array_size, space_id, hdferr, array_size) call H5Screate_simple_f(1, array_size, space_id, hdferr, array_size)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
if (attrExists) then if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, array_size, hdferr) call H5Awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, array_size, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Aclose_f(attr_id,hdferr) call H5Aclose_f(attr_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(space_id,hdferr) call H5Sclose_f(space_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_addAttribute_real_array end subroutine HDF5_addAttribute_real_array
@ -645,13 +645,13 @@ subroutine HDF5_setLink(loc_id,target_name,link_name)
logical :: linkExists logical :: linkExists
call H5Lexists_f(loc_id, link_name,linkExists, hdferr) call H5Lexists_f(loc_id, link_name,linkExists, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
if (linkExists) then if (linkExists) then
call H5Ldelete_f(loc_id,link_name, hdferr) call H5Ldelete_f(loc_id,link_name, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call H5Lcreate_soft_f(target_name, loc_id, link_name, hdferr) call H5Lcreate_soft_f(target_name, loc_id, link_name, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_setLink end subroutine HDF5_setLink
@ -687,7 +687,7 @@ subroutine HDF5_read_real1(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -724,7 +724,7 @@ subroutine HDF5_read_real2(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -761,7 +761,7 @@ subroutine HDF5_read_real3(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -799,7 +799,7 @@ subroutine HDF5_read_real4(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -837,7 +837,7 @@ subroutine HDF5_read_real5(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -875,7 +875,7 @@ subroutine HDF5_read_real6(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -913,7 +913,7 @@ subroutine HDF5_read_real7(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -951,7 +951,7 @@ subroutine HDF5_read_int1(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -989,7 +989,7 @@ subroutine HDF5_read_int2(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -1026,7 +1026,7 @@ subroutine HDF5_read_int3(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -1063,7 +1063,7 @@ subroutine HDF5_read_int4(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -1100,7 +1100,7 @@ subroutine HDF5_read_int5(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -1138,7 +1138,7 @@ subroutine HDF5_read_int6(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -1176,7 +1176,7 @@ subroutine HDF5_read_int7(dataset,loc_id,datasetName,parallel)
call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,&
file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
@ -1218,7 +1218,7 @@ subroutine HDF5_write_real1(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1259,7 +1259,7 @@ subroutine HDF5_write_real2(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1300,7 +1300,7 @@ subroutine HDF5_write_real3(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1341,7 +1341,7 @@ subroutine HDF5_write_real4(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1383,7 +1383,7 @@ subroutine HDF5_write_real5(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1424,7 +1424,7 @@ subroutine HDF5_write_real6(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1465,7 +1465,7 @@ subroutine HDF5_write_real7(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1529,7 +1529,7 @@ subroutine HDF5_write_real(dataset,loc_id,datasetName,parallel)
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
end select end select
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1556,14 +1556,14 @@ subroutine HDF5_write_str(dataset,loc_id,datasetName)
dataset_ = trim(dataset) dataset_ = trim(dataset)
call H5Tcopy_f(H5T_C_S1, filetype_id, hdferr) call H5Tcopy_f(H5T_C_S1, filetype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tset_size_f(filetype_id, int(len(dataset_)+1,HSIZE_T), hdferr) ! +1 for NULL call H5Tset_size_f(filetype_id, int(len(dataset_)+1,HSIZE_T), hdferr) ! +1 for NULL
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tcopy_f(H5T_FORTRAN_S1, memtype_id, hdferr) call H5Tcopy_f(H5T_FORTRAN_S1, memtype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tset_size_f(memtype_id, int(len(dataset_),HSIZE_T), hdferr) call H5Tset_size_f(memtype_id, int(len(dataset_),HSIZE_T), hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, hdferr) call H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, hdferr)
if (hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
@ -1579,23 +1579,23 @@ subroutine HDF5_write_str(dataset,loc_id,datasetName)
end if end if
call H5Screate_simple_f(1, [1_HSIZE_T], space_id, hdferr) call H5Screate_simple_f(1, [1_HSIZE_T], space_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
CALL H5Dcreate_f(loc_id, datasetName, filetype_id, space_id, dataset_id, hdferr, dcpl) CALL H5Dcreate_f(loc_id, datasetName, filetype_id, space_id, dataset_id, hdferr, dcpl)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dwrite_f(dataset_id, memtype_id, c_loc(dataset_(1:1)), hdferr) call H5Dwrite_f(dataset_id, memtype_id, c_loc(dataset_(1:1)), hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Pclose_f(dcpl, hdferr) call H5Pclose_f(dcpl, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dclose_f(dataset_id, hdferr) call H5Dclose_f(dataset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(space_id, hdferr) call H5Sclose_f(space_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tclose_f(memtype_id, hdferr) call H5Tclose_f(memtype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tclose_f(filetype_id, hdferr) call H5Tclose_f(filetype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_write_str end subroutine HDF5_write_str
@ -1635,7 +1635,7 @@ subroutine HDF5_write_int1(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1676,7 +1676,7 @@ subroutine HDF5_write_int2(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1717,7 +1717,7 @@ subroutine HDF5_write_int3(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1758,7 +1758,7 @@ subroutine HDF5_write_int4(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1799,7 +1799,7 @@ subroutine HDF5_write_int5(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1840,7 +1840,7 @@ subroutine HDF5_write_int6(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1881,7 +1881,7 @@ subroutine HDF5_write_int7(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1945,7 +1945,7 @@ subroutine HDF5_write_int(dataset,loc_id,datasetName,parallel)
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,&
file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
end select end select
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
@ -1978,7 +1978,7 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! creating a property list for transfer properties (is collective for MPI) ! creating a property list for transfer properties (is collective for MPI)
call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
readSize = 0_MPI_INTEGER_KIND readSize = 0_MPI_INTEGER_KIND
@ -1986,7 +1986,7 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_
#ifdef PETSC #ifdef PETSC
if (parallel) then if (parallel) then
call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call MPI_Allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get total output size over each process call MPI_Allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get total output size over each process
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
end if end if
@ -1997,35 +1997,35 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_
if (any(globalShape == 0)) then if (any(globalShape == 0)) then
call H5Pclose_f(plist_id, hdferr) call H5Pclose_f(plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
return return
end if end if
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape) ! create dataspace in memory (local shape)
call H5Screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) call H5Screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! creating a property list for IO and set it to collective ! creating a property list for IO and set it to collective
call H5Pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) call H5Pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
#ifdef PETSC #ifdef PETSC
call H5Pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) call H5Pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
#endif #endif
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! open the dataset in the file and get the space ID ! open the dataset in the file and get the space ID
call H5Dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) call H5Dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dget_space_f(dset_id, filespace_id, hdferr) call H5Dget_space_f(dset_id, filespace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! select a hyperslab (the portion of the current process) in the file ! select a hyperslab (the portion of the current process) in the file
call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine initialize_read end subroutine initialize_read
@ -2039,15 +2039,15 @@ subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id
integer :: hdferr integer :: hdferr
call H5Pclose_f(plist_id, hdferr) call H5Pclose_f(plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Pclose_f(aplist_id, hdferr) call H5Pclose_f(aplist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dclose_f(dset_id, hdferr) call H5Dclose_f(dset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(filespace_id, hdferr) call H5Sclose_f(filespace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(memspace_id, hdferr) call H5Sclose_f(memspace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine finalize_read end subroutine finalize_read
@ -2080,11 +2080,11 @@ subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! creating a property list for transfer properties (is collective when writing in parallel) ! creating a property list for transfer properties (is collective when writing in parallel)
call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
#ifdef PETSC #ifdef PETSC
if (parallel) then if (parallel) then
call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
#endif #endif
@ -2129,19 +2129,19 @@ subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape) and in file (global shape) ! create dataspace in memory (local shape) and in file (global shape)
call H5Screate_simple_f(size(myShape), myShape, memspace_id, hdferr, myShape) call H5Screate_simple_f(size(myShape), myShape, memspace_id, hdferr, myShape)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Screate_simple_f(size(totalShape), totalShape, filespace_id, hdferr, totalShape) call H5Screate_simple_f(size(totalShape), totalShape, filespace_id, hdferr, totalShape)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! create dataset in the file and select a hyperslab from it (the portion of the current process) ! create dataset in the file and select a hyperslab from it (the portion of the current process)
call H5Dcreate_f(loc_id, trim(datasetName), datatype, filespace_id, dset_id, hdferr, dcpl) call H5Dcreate_f(loc_id, trim(datasetName), datatype, filespace_id, dset_id, hdferr, dcpl)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, myShape, hdferr) call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, myShape, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Pclose_f(dcpl , hdferr) call H5Pclose_f(dcpl , hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
contains contains
!------------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------------
@ -2170,13 +2170,13 @@ subroutine finalize_write(plist_id, dset_id, filespace_id, memspace_id)
integer :: hdferr integer :: hdferr
call H5Pclose_f(plist_id, hdferr) call H5Pclose_f(plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dclose_f(dset_id, hdferr) call H5Dclose_f(dset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(filespace_id, hdferr) call H5Sclose_f(filespace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(memspace_id, hdferr) call H5Sclose_f(memspace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine finalize_write end subroutine finalize_write

8
src/Marc/DAMASK_Marc.f90
View File

@ -105,7 +105,7 @@ logical function solverIsSymmetric()
status='old', position='rewind', action='read',iostat=myStat) status='old', position='rewind', action='read',iostat=myStat)
do do
read (fileUnit,'(A)',END=100) line read (fileUnit,'(A)',END=100) line
if(index(trim(lc(line)),'solver') == 1) then if (index(trim(lc(line)),'solver') == 1) then
read (fileUnit,'(A)',END=100) line ! next line read (fileUnit,'(A)',END=100) line ! next line
s = verify(line, ' ') ! start of first chunk s = verify(line, ' ') ! start of first chunk
s = s + verify(line(s+1:),' ') ! start of second chunk s = s + verify(line(s+1:),' ') ! start of second chunk
@ -286,7 +286,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
type(tList), pointer :: & type(tList), pointer :: &
debug_Marc ! pointer to Marc debug options debug_Marc ! pointer to Marc debug options
if(debug_basic) then if (debug_basic) then
print'(a,/,i8,i8,i2)', ' MSC.Marc information on shape of element(2), IP:', m, nn print'(a,/,i8,i8,i2)', ' MSC.Marc information on shape of element(2), IP:', m, nn
print'(a,2(i1))', ' Jacobian: ', ngens,ngens print'(a,2(i1))', ' Jacobian: ', ngens,ngens
print'(a,i1)', ' Direct stress: ', ndi print'(a,i1)', ' Direct stress: ', ndi
@ -369,7 +369,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
d = ddsdde(1:ngens,1:ngens) d = ddsdde(1:ngens,1:ngens)
s = stress(1:ndi+nshear) s = stress(1:ndi+nshear)
g = 0.0_pReal g = 0.0_pReal
if(symmetricSolver) d = 0.5_pReal*(d+transpose(d)) if (symmetricSolver) d = 0.5_pReal*(d+transpose(d))
call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value
@ -428,7 +428,7 @@ subroutine uedinc(inc,incsub)
do n = lbound(discretization_Marc_FEM2DAMASK_node,1), ubound(discretization_Marc_FEM2DAMASK_node,1) do n = lbound(discretization_Marc_FEM2DAMASK_node,1), ubound(discretization_Marc_FEM2DAMASK_node,1)
if (discretization_Marc_FEM2DAMASK_node(n) /= -1) then if (discretization_Marc_FEM2DAMASK_node(n) /= -1) then
call nodvar(1,n,d_n(1:3,discretization_Marc_FEM2DAMASK_node(n)),nqncomp,nqdatatype) call nodvar(1,n,d_n(1:3,discretization_Marc_FEM2DAMASK_node(n)),nqncomp,nqdatatype)
if(nqncomp == 2) d_n(3,discretization_Marc_FEM2DAMASK_node(n)) = 0.0_pReal if (nqncomp == 2) d_n(3,discretization_Marc_FEM2DAMASK_node(n)) = 0.0_pReal
end if end if
end do end do

66
src/Marc/discretization_Marc.f90
View File

@ -271,8 +271,8 @@ subroutine inputRead_fileFormat(fileFormat,fileContent)
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 2) cycle if (chunkPos(1) < 2) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'version') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'version') then
fileFormat = IO_intValue(fileContent(l),chunkPos,2) fileFormat = IO_intValue(fileContent(l),chunkPos,2)
exit exit
end if end if
@ -297,8 +297,8 @@ subroutine inputRead_tableStyles(initialcond,hypoelastic,fileContent)
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 6) cycle if (chunkPos(1) < 6) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'table') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'table') then
initialcond = IO_intValue(fileContent(l),chunkPos,4) initialcond = IO_intValue(fileContent(l),chunkPos,4)
hypoelastic = IO_intValue(fileContent(l),chunkPos,5) hypoelastic = IO_intValue(fileContent(l),chunkPos,5)
exit exit
@ -324,8 +324,8 @@ subroutine inputRead_matNumber(matNumber, &
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'hypoelastic') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'hypoelastic') then
if (len_trim(fileContent(l+1))/=0) then if (len_trim(fileContent(l+1))/=0) then
chunkPos = IO_stringPos(fileContent(l+1)) chunkPos = IO_stringPos(fileContent(l+1))
data_blocks = IO_intValue(fileContent(l+1),chunkPos,1) data_blocks = IO_intValue(fileContent(l+1),chunkPos,1)
@ -362,10 +362,10 @@ subroutine inputRead_NnodesAndElements(nNodes,nElems,&
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'sizing') then if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'sizing') then
nElems = IO_IntValue (fileContent(l),chunkPos,3) nElems = IO_IntValue (fileContent(l),chunkPos,3)
elseif(IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'coordinates') then elseif (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'coordinates') then
chunkPos = IO_stringPos(fileContent(l+1)) chunkPos = IO_stringPos(fileContent(l+1))
nNodes = IO_IntValue (fileContent(l+1),chunkPos,2) nNodes = IO_IntValue (fileContent(l+1),chunkPos,2)
end if end if
@ -392,13 +392,13 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,&
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 2) cycle if (chunkPos(1) < 2) cycle
if(IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'define' .and. & if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'define' .and. &
IO_lc(IO_StringValue(fileContent(l),chunkPos,2)) == 'element') then IO_lc(IO_StringValue(fileContent(l),chunkPos,2)) == 'element') then
nElemSets = nElemSets + 1 nElemSets = nElemSets + 1
chunkPos = IO_stringPos(fileContent(l+1)) chunkPos = IO_stringPos(fileContent(l+1))
if(containsRange(fileContent(l+1),chunkPos)) then if (containsRange(fileContent(l+1),chunkPos)) then
elemInCurrentSet = 1 + abs( IO_intValue(fileContent(l+1),chunkPos,3) & elemInCurrentSet = 1 + abs( IO_intValue(fileContent(l+1),chunkPos,3) &
-IO_intValue(fileContent(l+1),chunkPos,1)) -IO_intValue(fileContent(l+1),chunkPos,1))
else else
@ -408,7 +408,7 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,&
i = i + 1 i = i + 1
chunkPos = IO_stringPos(fileContent(l+i)) chunkPos = IO_stringPos(fileContent(l+i))
elemInCurrentSet = elemInCurrentSet + chunkPos(1) - 1 ! add line's count when assuming 'c' elemInCurrentSet = elemInCurrentSet + chunkPos(1) - 1 ! add line's count when assuming 'c'
if(IO_lc(IO_stringValue(fileContent(l+i),chunkPos,chunkPos(1))) /= 'c') then ! line finished, read last value if (IO_lc(IO_stringValue(fileContent(l+i),chunkPos,chunkPos(1))) /= 'c') then ! line finished, read last value
elemInCurrentSet = elemInCurrentSet + 1 ! data ended elemInCurrentSet = elemInCurrentSet + 1 ! data ended
exit exit
end if end if
@ -442,8 +442,8 @@ subroutine inputRead_mapElemSets(nameElemSet,mapElemSet,&
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 2) cycle if (chunkPos(1) < 2) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'define' .and. & if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'define' .and. &
IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'element') then IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'element') then
elemSet = elemSet+1 elemSet = elemSet+1
nameElemSet(elemSet) = trim(IO_stringValue(fileContent(l),chunkPos,4)) nameElemSet(elemSet) = trim(IO_stringValue(fileContent(l),chunkPos,4))
@ -473,8 +473,8 @@ subroutine inputRead_mapElems(FEM2DAMASK, &
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then
j = 0 j = 0
do i = 1,nElems do i = 1,nElems
chunkPos = IO_stringPos(fileContent(l+1+i+j)) chunkPos = IO_stringPos(fileContent(l+1+i+j))
@ -517,8 +517,8 @@ subroutine inputRead_mapNodes(FEM2DAMASK, &
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then
chunkPos = [1,1,10] chunkPos = [1,1,10]
do i = 1,nNodes do i = 1,nNodes
map_unsorted(:,i) = [IO_intValue(fileContent(l+1+i),chunkPos,1),i] map_unsorted(:,i) = [IO_intValue(fileContent(l+1+i),chunkPos,1),i]
@ -554,8 +554,8 @@ subroutine inputRead_elemNodes(nodes, &
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then
chunkPos = [4,1,10,11,30,31,50,51,70] chunkPos = [4,1,10,11,30,31,50,51,70]
do i=1,nNode do i=1,nNode
m = discretization_Marc_FEM2DAMASK_node(IO_intValue(fileContent(l+1+i),chunkPos,1)) m = discretization_Marc_FEM2DAMASK_node(IO_intValue(fileContent(l+1+i),chunkPos,1))
@ -585,8 +585,8 @@ subroutine inputRead_elemType(elem, &
t = -1 t = -1
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then
j = 0 j = 0
do i=1,nElem ! read all elements do i=1,nElem ! read all elements
chunkPos = IO_stringPos(fileContent(l+1+i+j)) chunkPos = IO_stringPos(fileContent(l+1+i+j))
@ -676,8 +676,8 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent)
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then
j = 0 j = 0
do i = 1,nElem do i = 1,nElem
chunkPos = IO_stringPos(fileContent(l+1+i+j)) chunkPos = IO_stringPos(fileContent(l+1+i+j))
@ -733,8 +733,8 @@ subroutine inputRead_material(materialAt,&
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 2) cycle if (chunkPos(1) < 2) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'initial' .and. & if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'initial' .and. &
IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'state') then IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'state') then
k = merge(2,1,initialcondTableStyle == 2) k = merge(2,1,initialcondTableStyle == 2)
chunkPos = IO_stringPos(fileContent(l+k)) chunkPos = IO_stringPos(fileContent(l+k))
@ -756,7 +756,7 @@ subroutine inputRead_material(materialAt,&
end if end if
end do end do
if(any(materialAt < 1)) call IO_error(180) if (any(materialAt < 1)) call IO_error(180)
end subroutine inputRead_material end subroutine inputRead_material
@ -1122,8 +1122,8 @@ function IPneighborhood(elem)
e = 1 e = 1
do while (e < size(face,2)) do while (e < size(face,2))
e = e + 1 e = e + 1
if(any(face(:c,s) /= face(:c,e))) then if (any(face(:c,s) /= face(:c,e))) then
if(e-1/=s) call math_sort(face(:,s:e-1),sortDim=c) if (e-1/=s) call math_sort(face(:,s:e-1),sortDim=c)
s = e s = e
end if end if
end do end do
@ -1131,7 +1131,7 @@ function IPneighborhood(elem)
IPneighborhood = 0 IPneighborhood = 0
do c=1, size(face,2) - 1 do c=1, size(face,2) - 1
if(all(face(:n-1,c) == face(:n-1,c+1))) then if (all(face(:n-1,c) == face(:n-1,c+1))) then
IPneighborhood(:,face(n+2,c+1),face(n+1,c+1),face(n+0,c+1)) = face(n:n+3,c+0) IPneighborhood(:,face(n+2,c+1),face(n+1,c+1),face(n+0,c+1)) = face(n:n+3,c+0)
IPneighborhood(:,face(n+2,c+0),face(n+1,c+0),face(n+0,c+0)) = face(n:n+3,c+1) IPneighborhood(:,face(n+2,c+0),face(n+1,c+0),face(n+0,c+0)) = face(n:n+3,c+1)
end if end if
@ -1174,7 +1174,7 @@ function continuousIntValues(fileContent,maxN,lookupName,lookupMap,lookupMaxN)
end if end if
end do end do
exit exit
elseif(containsRange(fileContent(l),chunkPos)) then elseif (containsRange(fileContent(l),chunkPos)) then
first = IO_intValue(fileContent(l),chunkPos,1) first = IO_intValue(fileContent(l),chunkPos,1)
last = IO_intValue(fileContent(l),chunkPos,3) last = IO_intValue(fileContent(l),chunkPos,3)
do i = first, last, sign(1,last-first) do i = first, last, sign(1,last-first)
@ -1208,8 +1208,8 @@ logical function containsRange(str,chunkPos)
containsRange = .False. containsRange = .False.
if(chunkPos(1) == 3) then if (chunkPos(1) == 3) then
if(IO_lc(IO_stringValue(str,chunkPos,2)) == 'to') containsRange = .True. if (IO_lc(IO_stringValue(str,chunkPos,2)) == 'to') containsRange = .True.
end if end if
end function containsRange end function containsRange

38
src/Marc/materialpoint_Marc.f90
View File

@ -72,26 +72,26 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Initialize all modules. !> @brief Initialize all modules.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_initAll subroutine materialpoint_initAll()
call DAMASK_interface_init call DAMASK_interface_init()
call prec_init call prec_init()
call IO_init call IO_init()
call YAML_types_init call YAML_types_init()
call YAML_parse_init call YAML_parse_init()
call HDF5_utilities_init call HDF5_utilities_init()
call results_init(.false.) call results_init(.false.)
call config_init call config_init()
call math_init call math_init()
call rotations_init call rotations_init()
call polynomials_init call polynomials_init()
call lattice_init call lattice_init()
call discretization_Marc_init call discretization_Marc_init()
call material_init(.false.) call material_init(.false.)
call phase_init call phase_init()
call homogenization_init call homogenization_init()
call materialpoint_init call materialpoint_init()
call config_deallocate call config_deallocate()
end subroutine materialpoint_initAll end subroutine materialpoint_initAll
@ -99,7 +99,7 @@ end subroutine materialpoint_initAll
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief allocate the arrays defined in module materialpoint and initialize them !> @brief allocate the arrays defined in module materialpoint and initialize them
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_init subroutine materialpoint_init()
type(tList), pointer :: & type(tList), pointer :: &
debug_materialpoint debug_materialpoint
@ -121,7 +121,7 @@ subroutine materialpoint_init
debugmaterialpoint%element = config_debug%get_asInt('element',defaultVal = 1) debugmaterialpoint%element = config_debug%get_asInt('element',defaultVal = 1)
debugmaterialpoint%ip = config_debug%get_asInt('integrationpoint',defaultVal = 1) debugmaterialpoint%ip = config_debug%get_asInt('integrationpoint',defaultVal = 1)
if(debugmaterialpoint%basic) then if (debugmaterialpoint%basic) then
print'(a32,1x,6(i8,1x))', 'materialpoint_cs: ', shape(materialpoint_cs) print'(a32,1x,6(i8,1x))', 'materialpoint_cs: ', shape(materialpoint_cs)
print'(a32,1x,6(i8,1x))', 'materialpoint_dcsdE: ', shape(materialpoint_dcsdE) print'(a32,1x,6(i8,1x))', 'materialpoint_dcsdE: ', shape(materialpoint_dcsdE)
print'(a32,1x,6(i8,1x),/)', 'materialpoint_dcsdE_knownGood: ', shape(materialpoint_dcsdE_knownGood) print'(a32,1x,6(i8,1x),/)', 'materialpoint_dcsdE_knownGood: ', shape(materialpoint_dcsdE_knownGood)

288
src/YAML_parse.f90
View File

@ -118,7 +118,7 @@ recursive function parse_flow(YAML_flow) result(node)
d = s + scan(flow_string(s+1:),':') d = s + scan(flow_string(s+1:),':')
e = d + find_end(flow_string(d+1:),'}') e = d + find_end(flow_string(d+1:),'}')
key = trim(adjustl(flow_string(s+1:d-1))) key = trim(adjustl(flow_string(s+1:d-1)))
if(quotedString(key)) key = key(2:len(key)-1) if (quotedString(key)) key = key(2:len(key)-1)
myVal => parse_flow(flow_string(d+1:e-1)) ! parse items (recursively) myVal => parse_flow(flow_string(d+1:e-1)) ! parse items (recursively)
select type (node) select type (node)
@ -143,7 +143,7 @@ recursive function parse_flow(YAML_flow) result(node)
allocate(tScalar::node) allocate(tScalar::node)
select type (node) select type (node)
class is (tScalar) class is (tScalar)
if(quotedString(flow_string)) then if (quotedString(flow_string)) then
node = trim(adjustl(flow_string(2:len(flow_string)-1))) node = trim(adjustl(flow_string(2:len(flow_string)-1)))
else else
node = trim(adjustl(flow_string)) node = trim(adjustl(flow_string))
@ -198,7 +198,7 @@ logical function quotedString(line)
if (scan(line(:1),IO_QUOTES) == 1) then if (scan(line(:1),IO_QUOTES) == 1) then
quotedString = .true. quotedString = .true.
if(line(len(line):len(line)) /= line(:1)) call IO_error(710,ext_msg=line) if (line(len(line):len(line)) /= line(:1)) call IO_error(710,ext_msg=line)
end if end if
end function quotedString end function quotedString
@ -245,7 +245,7 @@ integer function indentDepth(line,offset)
integer, optional,intent(in) :: offset integer, optional,intent(in) :: offset
indentDepth = verify(line,IO_WHITESPACE) -1 indentDepth = verify(line,IO_WHITESPACE) -1
if(present(offset)) indentDepth = indentDepth + offset if (present(offset)) indentDepth = indentDepth + offset
end function indentDepth end function indentDepth
@ -285,7 +285,7 @@ logical function isListItem(line)
character(len=*), intent(in) :: line character(len=*), intent(in) :: line
isListItem = .false. isListItem = .false.
if(len_trim(adjustl(line))> 2 .and. index(trim(adjustl(line)), '-') == 1) then if (len_trim(adjustl(line))> 2 .and. index(trim(adjustl(line)), '-') == 1) then
isListItem = scan(trim(adjustl(line)),' ') == 2 isListItem = scan(trim(adjustl(line)),' ') == 2
else else
isListItem = trim(adjustl(line)) == '-' isListItem = trim(adjustl(line)) == '-'
@ -302,8 +302,8 @@ logical function isKeyValue(line)
character(len=*), intent(in) :: line character(len=*), intent(in) :: line
isKeyValue = .false. isKeyValue = .false.
if( .not. isKey(line) .and. index(IO_rmComment(line),':') > 0 .and. .not. isFlow(line)) then if ( .not. isKey(line) .and. index(IO_rmComment(line),':') > 0 .and. .not. isFlow(line)) then
if(index(IO_rmComment(line),': ') > 0) isKeyValue = .true. if (index(IO_rmComment(line),': ') > 0) isKeyValue = .true.
end if end if
end function isKeyValue end function isKeyValue
@ -317,7 +317,7 @@ logical function isKey(line)
character(len=*), intent(in) :: line character(len=*), intent(in) :: line
if(len(IO_rmComment(line)) == 0) then if (len(IO_rmComment(line)) == 0) then
isKey = .false. isKey = .false.
else else
isKey = index(IO_rmComment(line),':',back=.false.) == len(IO_rmComment(line)) .and. & isKey = index(IO_rmComment(line),':',back=.false.) == len(IO_rmComment(line)) .and. &
@ -354,7 +354,7 @@ subroutine skip_empty_lines(blck,s_blck)
empty = .true. empty = .true.
do while(empty .and. len_trim(blck(s_blck:)) /= 0) do while(empty .and. len_trim(blck(s_blck:)) /= 0)
empty = len_trim(IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))) == 0 empty = len_trim(IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))) == 0
if(empty) s_blck = s_blck + index(blck(s_blck:),IO_EOL) if (empty) s_blck = s_blck + index(blck(s_blck:),IO_EOL)
end do end do
end subroutine skip_empty_lines end subroutine skip_empty_lines
@ -372,10 +372,10 @@ subroutine skip_file_header(blck,s_blck)
character(len=:), allocatable :: line character(len=:), allocatable :: line
line = IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2)) line = IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))
if(index(adjustl(line),'%YAML') == 1) then if (index(adjustl(line),'%YAML') == 1) then
s_blck = s_blck + index(blck(s_blck:),IO_EOL) s_blck = s_blck + index(blck(s_blck:),IO_EOL)
call skip_empty_lines(blck,s_blck) call skip_empty_lines(blck,s_blck)
if(trim(IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))) == '---') then if (trim(IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))) == '---') then
s_blck = s_blck + index(blck(s_blck:),IO_EOL) s_blck = s_blck + index(blck(s_blck:),IO_EOL)
else else
call IO_error(708,ext_msg = line) call IO_error(708,ext_msg = line)
@ -400,8 +400,8 @@ logical function flow_is_closed(str,e_char)
flow_is_closed = .false. flow_is_closed = .false.
N_sq = 0 N_sq = 0
N_cu = 0 N_cu = 0
if(e_char == ']') line = str(index(str(:),'[')+1:) if (e_char == ']') line = str(index(str(:),'[')+1:)
if(e_char == '}') line = str(index(str(:),'{')+1:) if (e_char == '}') line = str(index(str(:),'{')+1:)
do i = 1, len_trim(line) do i = 1, len_trim(line)
flow_is_closed = (N_sq==0 .and. N_cu==0 .and. scan(line(i:i),e_char) == 1) flow_is_closed = (N_sq==0 .and. N_cu==0 .and. scan(line(i:i),e_char) == 1)
@ -463,7 +463,7 @@ subroutine list_item_inline(blck,s_blck,inline,offset)
indent_next = indentDepth(blck(s_blck:)) indent_next = indentDepth(blck(s_blck:))
end do end do
if(scan(inline,",") > 0) inline = '"'//inline//'"' if (scan(inline,",") > 0) inline = '"'//inline//'"'
end subroutine list_item_inline end subroutine list_item_inline
@ -483,19 +483,19 @@ recursive subroutine line_isFlow(flow,s_flow,line)
list_chunk, & list_chunk, &
dict_chunk dict_chunk
if(index(adjustl(line),'[') == 1) then if (index(adjustl(line),'[') == 1) then
s = index(line,'[') s = index(line,'[')
flow(s_flow:s_flow) = '[' flow(s_flow:s_flow) = '['
s_flow = s_flow +1 s_flow = s_flow +1
do while(s < len_trim(line)) do while(s < len_trim(line))
list_chunk = s + find_end(line(s+1:),']') 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) = '{' flow(s_flow:s_flow) = '{'
s_flow = s_flow +1 s_flow = s_flow +1
call keyValue_toFlow(flow,s_flow,line(s+1:list_chunk-1)) call keyValue_toFlow(flow,s_flow,line(s+1:list_chunk-1))
flow(s_flow:s_flow) = '}' flow(s_flow:s_flow) = '}'
s_flow = s_flow +1 s_flow = s_flow +1
elseif(isFlow(line(s+1:list_chunk-1))) then elseif (isFlow(line(s+1:list_chunk-1))) then
call line_isFlow(flow,s_flow,line(s+1:list_chunk-1)) call line_isFlow(flow,s_flow,line(s+1:list_chunk-1))
else else
call line_toFlow(flow,s_flow,line(s+1:list_chunk-1)) call line_toFlow(flow,s_flow,line(s+1:list_chunk-1))
@ -509,20 +509,20 @@ recursive subroutine line_isFlow(flow,s_flow,line)
flow(s_flow:s_flow) = ']' flow(s_flow:s_flow) = ']'
s_flow = s_flow+1 s_flow = s_flow+1
elseif(index(adjustl(line),'{') == 1) then elseif (index(adjustl(line),'{') == 1) then
s = index(line,'{') s = index(line,'{')
flow(s_flow:s_flow) = '{' flow(s_flow:s_flow) = '{'
s_flow = s_flow +1 s_flow = s_flow +1
do while(s < len_trim(line)) do while(s < len_trim(line))
dict_chunk = s + find_end(line(s+1:),'}') dict_chunk = s + find_end(line(s+1:),'}')
if( .not. iskeyValue(line(s+1:dict_chunk-1))) call IO_error(705,ext_msg=line) if ( .not. iskeyValue(line(s+1:dict_chunk-1))) call IO_error(705,ext_msg=line)
call keyValue_toFlow(flow,s_flow,line(s+1:dict_chunk-1)) call keyValue_toFlow(flow,s_flow,line(s+1:dict_chunk-1))
flow(s_flow:s_flow+1) = ', ' flow(s_flow:s_flow+1) = ', '
s_flow = s_flow +2 s_flow = s_flow +2
s = s + find_end(line(s+1:),'}') s = s + find_end(line(s+1:),'}')
end do end do
s_flow = s_flow -1 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) = '}' flow(s_flow:s_flow) = '}'
s_flow = s_flow +1 s_flow = s_flow +1
else else
@ -549,8 +549,8 @@ recursive subroutine keyValue_toFlow(flow,s_flow,line)
offset_value offset_value
col_pos = index(line,':') col_pos = index(line,':')
if(line(col_pos+1:col_pos+1) /= ' ') call IO_error(704,ext_msg=line) if (line(col_pos+1:col_pos+1) /= ' ') call IO_error(704,ext_msg=line)
if(isFlow(line(col_pos+1:))) then if (isFlow(line(col_pos+1:))) then
d_flow = len_trim(adjustl(line(:col_pos))) d_flow = len_trim(adjustl(line(:col_pos)))
flow(s_flow:s_flow+d_flow+1) = trim(adjustl(line(:col_pos)))//' ' flow(s_flow:s_flow+d_flow+1) = trim(adjustl(line(:col_pos)))//' '
s_flow = s_flow + d_flow+1 s_flow = s_flow + d_flow+1
@ -605,35 +605,35 @@ recursive subroutine lst(blck,flow,s_blck,s_flow,offset)
do while (s_blck <= len_trim(blck)) do while (s_blck <= len_trim(blck))
e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2
line = IO_rmComment(blck(s_blck:e_blck)) line = IO_rmComment(blck(s_blck:e_blck))
if(trim(line) == '---' .or. trim(line) == '...') then if (trim(line) == '---' .or. trim(line) == '...') then
exit exit
elseif (len_trim(line) == 0) then elseif (len_trim(line) == 0) then
s_blck = e_blck + 2 ! forward to next line s_blck = e_blck + 2 ! forward to next line
cycle cycle
elseif(indentDepth(line,offset) > indent) then elseif (indentDepth(line,offset) > indent) then
call decide(blck,flow,s_blck,s_flow,offset) call decide(blck,flow,s_blck,s_flow,offset)
offset = 0 offset = 0
flow(s_flow:s_flow+1) = ', ' flow(s_flow:s_flow+1) = ', '
s_flow = s_flow + 2 s_flow = s_flow + 2
elseif(indentDepth(line,offset) < indent .or. .not. isListItem(line)) then elseif (indentDepth(line,offset) < indent .or. .not. isListItem(line)) then
offset = 0 offset = 0
exit ! job done (lower level) exit ! job done (lower level)
else else
if(trim(adjustl(line)) == '-') then ! list item in next line if (trim(adjustl(line)) == '-') then ! list item in next line
s_blck = e_blck + 2 s_blck = e_blck + 2
call skip_empty_lines(blck,s_blck) call skip_empty_lines(blck,s_blck)
e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2
line = IO_rmComment(blck(s_blck:e_blck)) line = IO_rmComment(blck(s_blck:e_blck))
if(trim(line) == '---') call IO_error(707,ext_msg=line) if (trim(line) == '---') call IO_error(707,ext_msg=line)
if(indentDepth(line) < indent .or. indentDepth(line) == indent) & if (indentDepth(line) < indent .or. indentDepth(line) == indent) &
call IO_error(701,ext_msg=line) call IO_error(701,ext_msg=line)
if(isScalar(line)) then if (isScalar(line)) then
call line_toFlow(flow,s_flow,line) call line_toFlow(flow,s_flow,line)
s_blck = e_blck +2 s_blck = e_blck +2
offset = 0 offset = 0
elseif(isFlow(line)) then elseif (isFlow(line)) then
if(isFlowList(line)) then if (isFlowList(line)) then
call remove_line_break(blck,s_blck,']',flow_line) call remove_line_break(blck,s_blck,']',flow_line)
else else
call remove_line_break(blck,s_blck,'}',flow_line) call remove_line_break(blck,s_blck,'}',flow_line)
@ -643,13 +643,13 @@ recursive subroutine lst(blck,flow,s_blck,s_flow,offset)
end if end if
else ! list item in the same line else ! list item in the same line
line = line(indentDepth(line)+3:) line = line(indentDepth(line)+3:)
if(isScalar(line)) then if (isScalar(line)) then
call list_item_inline(blck,s_blck,inline,offset) call list_item_inline(blck,s_blck,inline,offset)
offset = 0 offset = 0
call line_toFlow(flow,s_flow,inline) call line_toFlow(flow,s_flow,inline)
elseif(isFlow(line)) then elseif (isFlow(line)) then
s_blck = s_blck + index(blck(s_blck:),'-') s_blck = s_blck + index(blck(s_blck:),'-')
if(isFlowList(line)) then if (isFlowList(line)) then
call remove_line_break(blck,s_blck,']',flow_line) call remove_line_break(blck,s_blck,']',flow_line)
else else
call remove_line_break(blck,s_blck,'}',flow_line) call remove_line_break(blck,s_blck,'}',flow_line)
@ -663,7 +663,7 @@ recursive subroutine lst(blck,flow,s_blck,s_flow,offset)
end if end if
end if end if
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
end if end if
@ -702,33 +702,33 @@ recursive subroutine dct(blck,flow,s_blck,s_flow,offset)
do while (s_blck <= len_trim(blck)) do while (s_blck <= len_trim(blck))
e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2
line = IO_rmComment(blck(s_blck:e_blck)) line = IO_rmComment(blck(s_blck:e_blck))
if(trim(line) == '---' .or. trim(line) == '...') then if (trim(line) == '---' .or. trim(line) == '...') then
exit exit
elseif (len_trim(line) == 0) then elseif (len_trim(line) == 0) then
s_blck = e_blck + 2 ! forward to next line s_blck = e_blck + 2 ! forward to next line
cycle cycle
elseif(indentDepth(line,offset) < indent) then elseif (indentDepth(line,offset) < indent) then
if(isScalar(line) .or. isFlow(line) .and. previous_isKey) & if (isScalar(line) .or. isFlow(line) .and. previous_isKey) &
call IO_error(701,ext_msg=line) call IO_error(701,ext_msg=line)
offset = 0 offset = 0
exit ! job done (lower level) exit ! job done (lower level)
elseif(indentDepth(line,offset) > indent .or. isListItem(line)) then elseif (indentDepth(line,offset) > indent .or. isListItem(line)) then
offset = 0 offset = 0
call decide(blck,flow,s_blck,s_flow,offset) call decide(blck,flow,s_blck,s_flow,offset)
else else
if(isScalar(line)) call IO_error(701,ext_msg=line) if (isScalar(line)) call IO_error(701,ext_msg=line)
if(isFlow(line)) call IO_error(702,ext_msg=line) if (isFlow(line)) call IO_error(702,ext_msg=line)
line = line(indentDepth(line)+1:) line = line(indentDepth(line)+1:)
if(previous_isKey) then if (previous_isKey) then
flow(s_flow-1:s_flow) = ', ' flow(s_flow-1:s_flow) = ', '
s_flow = s_flow + 1 s_flow = s_flow + 1
end if end if
if(isKeyValue(line)) then if (isKeyValue(line)) then
col_pos = index(line,':') col_pos = index(line,':')
if(isFlow(line(col_pos+1:))) then if (isFlow(line(col_pos+1:))) then
if(isFlowList(line(col_pos+1:))) then if (isFlowList(line(col_pos+1:))) then
call remove_line_break(blck,s_blck,']',flow_line) call remove_line_break(blck,s_blck,']',flow_line)
else else
call remove_line_break(blck,s_blck,'}',flow_line) call remove_line_break(blck,s_blck,'}',flow_line)
@ -744,7 +744,7 @@ recursive subroutine dct(blck,flow,s_blck,s_flow,offset)
end if end if
end if end if
if(isScalar(line) .or. isKeyValue(line)) then if (isScalar(line) .or. isKeyValue(line)) then
flow(s_flow:s_flow) = ',' flow(s_flow:s_flow) = ','
s_flow = s_flow + 1 s_flow = s_flow + 1
previous_isKey = .false. previous_isKey = .false.
@ -776,13 +776,13 @@ recursive subroutine decide(blck,flow,s_blck,s_flow,offset)
integer :: e_blck integer :: e_blck
character(len=:), allocatable :: line,flow_line character(len=:), allocatable :: line,flow_line
if(s_blck <= len(blck)) then if (s_blck <= len(blck)) then
call skip_empty_lines(blck,s_blck) call skip_empty_lines(blck,s_blck)
e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2
line = IO_rmComment(blck(s_blck:e_blck)) line = IO_rmComment(blck(s_blck:e_blck))
if(trim(line) == '---' .or. trim(line) == '...') then if (trim(line) == '---' .or. trim(line) == '...') then
continue ! end parsing at this point but not stop the simulation continue ! end parsing at this point but not stop the simulation
elseif(len_trim(line) == 0) then elseif (len_trim(line) == 0) then
s_blck = e_blck +2 s_blck = e_blck +2
call decide(blck,flow,s_blck,s_flow,offset) call decide(blck,flow,s_blck,s_flow,offset)
elseif (isListItem(line)) then elseif (isListItem(line)) then
@ -791,14 +791,14 @@ recursive subroutine decide(blck,flow,s_blck,s_flow,offset)
call lst(blck,flow,s_blck,s_flow,offset) call lst(blck,flow,s_blck,s_flow,offset)
flow(s_flow:s_flow) = ']' flow(s_flow:s_flow) = ']'
s_flow = s_flow + 1 s_flow = s_flow + 1
elseif(isKey(line) .or. isKeyValue(line)) then elseif (isKey(line) .or. isKeyValue(line)) then
flow(s_flow:s_flow) = '{' flow(s_flow:s_flow) = '{'
s_flow = s_flow + 1 s_flow = s_flow + 1
call dct(blck,flow,s_blck,s_flow,offset) call dct(blck,flow,s_blck,s_flow,offset)
flow(s_flow:s_flow) = '}' flow(s_flow:s_flow) = '}'
s_flow = s_flow + 1 s_flow = s_flow + 1
elseif(isFlow(line)) then elseif (isFlow(line)) then
if(isFlowList(line)) then if (isFlowList(line)) then
call remove_line_break(blck,s_blck,']',flow_line) call remove_line_break(blck,s_blck,']',flow_line)
else else
call remove_line_break(blck,s_blck,'}',flow_line) call remove_line_break(blck,s_blck,'}',flow_line)
@ -833,18 +833,18 @@ function to_flow(blck)
s_blck = 1 s_blck = 1
offset = 0 offset = 0
if(len_trim(blck) /= 0) then if (len_trim(blck) /= 0) then
call skip_empty_lines(blck,s_blck) call skip_empty_lines(blck,s_blck)
call skip_file_header(blck,s_blck) call skip_file_header(blck,s_blck)
line = IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2)) line = IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))
if(trim(line) == '---') s_blck = s_blck + index(blck(s_blck:),IO_EOL) if (trim(line) == '---') s_blck = s_blck + index(blck(s_blck:),IO_EOL)
call decide(blck,to_flow,s_blck,s_flow,offset) call decide(blck,to_flow,s_blck,s_flow,offset)
end if end if
line = IO_rmComment(blck(s_blck:s_blck+index(blck(s_blck:),IO_EOL)-2)) line = IO_rmComment(blck(s_blck:s_blck+index(blck(s_blck:),IO_EOL)-2))
if(trim(line)== '---') call IO_warning(709,ext_msg=line) if (trim(line)== '---') call IO_warning(709,ext_msg=line)
to_flow = trim(to_flow(:s_flow-1)) to_flow = trim(to_flow(:s_flow-1))
end_line = index(to_flow,IO_EOL) 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 end function to_flow
@ -852,7 +852,7 @@ end function to_flow
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Check correctness of some YAML functions. !> @brief Check correctness of some YAML functions.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine selfTest subroutine selfTest()
if (indentDepth(' a') /= 1) error stop 'indentDepth' if (indentDepth(' a') /= 1) error stop 'indentDepth'
if (indentDepth('a') /= 0) error stop 'indentDepth' if (indentDepth('a') /= 0) error stop 'indentDepth'
@ -880,122 +880,122 @@ subroutine selfTest
if (.not. isKey(' a:')) 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: ')) error stop 'isScalar' if ( isScalar('a: ')) error stop 'isScalar'
if( isScalar('a: b')) error stop 'isScalar' if ( isScalar('a: b')) error stop 'isScalar'
if( isScalar('{a:b}')) error stop 'isScalar' if ( isScalar('{a:b}')) error stop 'isScalar'
if( isScalar('- a:')) error stop 'isScalar' if ( isScalar('- a:')) error stop 'isScalar'
if(.not. isScalar(' a')) error stop 'isScalar' if (.not. isScalar(' a')) error stop 'isScalar'
basic_list: block basic_list: block
character(len=*), parameter :: block_list = & character(len=*), parameter :: block_list = &
" - Casablanca"//IO_EOL//& " - Casablanca"//IO_EOL//&
" - North by Northwest"//IO_EOL " - North by Northwest"//IO_EOL
character(len=*), parameter :: block_list_newline = & character(len=*), parameter :: block_list_newline = &
" -"//IO_EOL//& " -"//IO_EOL//&
" Casablanca"//IO_EOL//& " Casablanca"//IO_EOL//&
" -"//IO_EOL//& " -"//IO_EOL//&
" North by Northwest"//IO_EOL " North by Northwest"//IO_EOL
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) error stop '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' 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
character(len=*), parameter :: block_dict = & character(len=*), parameter :: block_dict = &
" aa: Casablanca"//IO_EOL//& " aa: Casablanca"//IO_EOL//&
" bb: North by Northwest"//IO_EOL " bb: North by Northwest"//IO_EOL
character(len=*), parameter :: block_dict_newline = & character(len=*), parameter :: block_dict_newline = &
" aa:"//IO_EOL//& " aa:"//IO_EOL//&
" Casablanca"//IO_EOL//& " Casablanca"//IO_EOL//&
" bb:"//IO_EOL//& " bb:"//IO_EOL//&
" North by Northwest"//IO_EOL " North by Northwest"//IO_EOL
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) error stop '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' if (.not. to_flow(block_dict_newline) == flow_dict) error stop 'to_flow'
end block basic_dict end block basic_dict
only_flow: block only_flow: block
character(len=*), parameter :: flow_dict = & character(len=*), parameter :: flow_dict = &
" {a: [b,c: {d: e}, f: g, e]}"//IO_EOL " {a: [b,c: {d: e}, f: g, e]}"//IO_EOL
character(len=*), parameter :: flow_list = & character(len=*), parameter :: flow_list = &
" [a,b: c, d,e: {f: g}]"//IO_EOL " [a,b: c, d,e: {f: g}]"//IO_EOL
character(len=*), parameter :: flow_1 = & character(len=*), parameter :: flow_1 = &
"{a: [b, {c: {d: e}}, {f: g}, e]}" "{a: [b, {c: {d: e}}, {f: g}, e]}"
character(len=*), parameter :: flow_2 = & character(len=*), parameter :: flow_2 = &
"[a, {b: c}, d, {e: {f: g}}]" "[a, {b: c}, d, {e: {f: g}}]"
if (.not. to_flow(flow_dict) == flow_1) error stop 'to_flow' if (.not. to_flow(flow_dict) == flow_1) error stop 'to_flow'
if (.not. to_flow(flow_list) == flow_2) error stop 'to_flow' if (.not. to_flow(flow_list) == flow_2) error stop 'to_flow'
end block only_flow end block only_flow
basic_flow: block basic_flow: block
character(len=*), parameter :: flow_braces = & character(len=*), parameter :: flow_braces = &
" source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]"//IO_EOL " source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]"//IO_EOL
character(len=*), parameter :: flow_mixed_braces = & character(len=*), parameter :: flow_mixed_braces = &
" source: [param: 1, {param: 2}, param: 3, {param: 4}]"//IO_EOL " source: [param: 1, {param: 2}, param: 3, {param: 4}]"//IO_EOL
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) error stop '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' if (.not. to_flow(flow_mixed_braces) == flow) error stop 'to_flow'
end block basic_flow end block basic_flow
multi_line_flow1: block multi_line_flow1: block
character(len=*), parameter :: flow_multi = & character(len=*), parameter :: flow_multi = &
'%YAML 1.1'//IO_EOL//& '%YAML 1.1'//IO_EOL//&
'---'//IO_EOL//& '---'//IO_EOL//&
'a: ["b",'//IO_EOL//& 'a: ["b",'//IO_EOL//&
'c: '//IO_EOL//& 'c: '//IO_EOL//&
'"d", "e"]'//IO_EOL '"d", "e"]'//IO_EOL
character(len=*), parameter :: flow = & character(len=*), parameter :: flow = &
'{a: ["b", {c: "d"}, "e"]}' '{a: ["b", {c: "d"}, "e"]}'
if( .not. to_flow(flow_multi) == flow) error stop 'to_flow' if ( .not. to_flow(flow_multi) == flow) error stop 'to_flow'
end block multi_line_flow1 end block multi_line_flow1
multi_line_flow2: block multi_line_flow2: block
character(len=*), parameter :: flow_multi = & character(len=*), parameter :: flow_multi = &
"%YAML 1.1"//IO_EOL//& "%YAML 1.1"//IO_EOL//&
"---"//IO_EOL//& "---"//IO_EOL//&
"-"//IO_EOL//& "-"//IO_EOL//&
" a: {b:"//IO_EOL//& " a: {b:"//IO_EOL//&
"[c,"//IO_EOL//& "[c,"//IO_EOL//&
"d"//IO_EOL//& "d"//IO_EOL//&
"e, f]}"//IO_EOL "e, f]}"//IO_EOL
character(len=*), parameter :: flow = & character(len=*), parameter :: flow = &
"[{a: {b: [c, d e, f]}}]" "[{a: {b: [c, d e, f]}}]"
if( .not. to_flow(flow_multi) == flow) error stop 'to_flow' if ( .not. to_flow(flow_multi) == flow) error stop 'to_flow'
end block multi_line_flow2 end block multi_line_flow2
basic_mixed: block basic_mixed: block
character(len=*), parameter :: block_flow = & character(len=*), parameter :: block_flow = &
"%YAML 1.1"//IO_EOL//& "%YAML 1.1"//IO_EOL//&
" "//IO_EOL//& " "//IO_EOL//&
" "//IO_EOL//& " "//IO_EOL//&
"---"//IO_EOL//& "---"//IO_EOL//&
" aa:"//IO_EOL//& " aa:"//IO_EOL//&
" - "//IO_EOL//& " - "//IO_EOL//&
" "//IO_EOL//& " "//IO_EOL//&
" "//IO_EOL//& " "//IO_EOL//&
" param_1: [a: b, c, {d: {e: [f: g, h]}}]"//IO_EOL//& " param_1: [a: b, c, {d: {e: [f: g, h]}}]"//IO_EOL//&
" - c:d"//IO_EOL//& " - c:d"//IO_EOL//&
" e.f,"//IO_EOL//& " e.f,"//IO_EOL//&
" bb:"//IO_EOL//& " bb:"//IO_EOL//&
" "//IO_EOL//& " "//IO_EOL//&
" - "//IO_EOL//& " - "//IO_EOL//&
" {param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}"//IO_EOL//& " {param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}"//IO_EOL//&
"..."//IO_EOL "..."//IO_EOL
character(len=*), parameter :: mixed_flow = & character(len=*), parameter :: mixed_flow = &
'{aa: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}, "c:d e.f,"], bb: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}]}' '{aa: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}, "c:d e.f,"], bb: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}]}'
if(.not. to_flow(block_flow) == mixed_flow) error stop '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

2
src/discretization.f90
View File

@ -64,7 +64,7 @@ subroutine discretization_init(materialAt,&
discretization_NodeCoords0 = NodeCoords0 discretization_NodeCoords0 = NodeCoords0
discretization_NodeCoords = NodeCoords0 discretization_NodeCoords = NodeCoords0
if(present(sharedNodesBegin)) then if (present(sharedNodesBegin)) then
discretization_sharedNodesBegin = sharedNodesBegin discretization_sharedNodesBegin = sharedNodesBegin
else else
discretization_sharedNodesBegin = size(discretization_NodeCoords0,2) discretization_sharedNodesBegin = size(discretization_NodeCoords0,2)

8
src/geometry_plastic_nonlocal.f90
View File

@ -92,16 +92,16 @@ end subroutine geometry_plastic_nonlocal_setIPareaNormal
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_disable subroutine geometry_plastic_nonlocal_disable
if(allocated(geometry_plastic_nonlocal_IPneighborhood)) & if (allocated(geometry_plastic_nonlocal_IPneighborhood)) &
deallocate(geometry_plastic_nonlocal_IPneighborhood) deallocate(geometry_plastic_nonlocal_IPneighborhood)
if(allocated(geometry_plastic_nonlocal_IPvolume0)) & if (allocated(geometry_plastic_nonlocal_IPvolume0)) &
deallocate(geometry_plastic_nonlocal_IPvolume0) deallocate(geometry_plastic_nonlocal_IPvolume0)
if(allocated(geometry_plastic_nonlocal_IParea0)) & if (allocated(geometry_plastic_nonlocal_IParea0)) &
deallocate(geometry_plastic_nonlocal_IParea0) deallocate(geometry_plastic_nonlocal_IParea0)
if(allocated(geometry_plastic_nonlocal_IPareaNormal0)) & if (allocated(geometry_plastic_nonlocal_IPareaNormal0)) &
deallocate(geometry_plastic_nonlocal_IPareaNormal0) deallocate(geometry_plastic_nonlocal_IPareaNormal0)
end subroutine geometry_plastic_nonlocal_disable end subroutine geometry_plastic_nonlocal_disable

74
src/grid/base64.f90
View File

@ -73,10 +73,10 @@ function base64_to_bytes(base64_str,s,e) result(bytes)
integer(pI64) :: s_bytes, e_bytes, s_str, e_str integer(pI64) :: s_bytes, e_bytes, s_str, e_str
integer(C_SIGNED_CHAR), dimension(:), allocatable :: bytes integer(C_SIGNED_CHAR), dimension(:), allocatable :: bytes
if(.not. validBase64(base64_str)) call IO_error(114,ext_msg='invalid character') if (.not. validBase64(base64_str)) call IO_error(114,ext_msg='invalid character')
if(present(s)) then if (present(s)) then
if(s<1_pI64) call IO_error(114, ext_msg='s out of range') if (s<1_pI64) call IO_error(114, ext_msg='s out of range')
s_str = ((s-1_pI64)/3_pI64)*4_pI64 + 1_pI64 s_str = ((s-1_pI64)/3_pI64)*4_pI64 + 1_pI64
s_bytes = mod(s-1_pI64,3_pI64) + 1_pI64 s_bytes = mod(s-1_pI64,3_pI64) + 1_pI64
else else
@ -84,15 +84,15 @@ function base64_to_bytes(base64_str,s,e) result(bytes)
s_bytes = 1_pI64 s_bytes = 1_pI64
end if end if
if(present(e)) then if (present(e)) then
if(e>base64_nByte(len(base64_str,kind=pI64))) call IO_error(114, ext_msg='e out of range') if (e>base64_nByte(len(base64_str,kind=pI64))) call IO_error(114, ext_msg='e out of range')
e_str = ((e-1_pI64)/3_pI64)*4_pI64 + 4_pI64 e_str = ((e-1_pI64)/3_pI64)*4_pI64 + 4_pI64
e_bytes = e - base64_nByte(s_str) e_bytes = e - base64_nByte(s_str)
else else
e_str = len(base64_str,kind=pI64) e_str = len(base64_str,kind=pI64)
e_bytes = base64_nByte(len(base64_str,kind=pI64)) - base64_nByte(s_str) e_bytes = base64_nByte(len(base64_str,kind=pI64)) - base64_nByte(s_str)
if(base64_str(e_str-0_pI64:e_str-0_pI64) == '=') e_bytes = e_bytes - 1_pI64 if (base64_str(e_str-0_pI64:e_str-0_pI64) == '=') e_bytes = e_bytes - 1_pI64
if(base64_str(e_str-1_pI64:e_str-1_pI64) == '=') e_bytes = e_bytes - 1_pI64 if (base64_str(e_str-1_pI64:e_str-1_pI64) == '=') e_bytes = e_bytes - 1_pI64
end if end if
bytes = decodeBase64(base64_str(s_str:e_str)) bytes = decodeBase64(base64_str(s_str:e_str))
@ -118,7 +118,7 @@ pure function decodeBase64(base64_str) result(bytes)
do while(c < len(base64_str,kind=pI64)) do while(c < len(base64_str,kind=pI64))
do p=0_pI64,3_pI64 do p=0_pI64,3_pI64
if(c+p<=len(base64_str,kind=pI64)) then if (c+p<=len(base64_str,kind=pI64)) then
charPos(p) = int(index(base64_encoding,base64_str(c+p:c+p))-1,C_SIGNED_CHAR) charPos(p) = int(index(base64_encoding,base64_str(c+p:c+p))-1,C_SIGNED_CHAR)
else else
charPos(p) = 0_C_SIGNED_CHAR charPos(p) = 0_C_SIGNED_CHAR
@ -151,9 +151,9 @@ pure logical function validBase64(base64_str)
l = len(base64_str,pI64) l = len(base64_str,pI64)
validBase64 = .true. validBase64 = .true.
if(mod(l,4_pI64)/=0_pI64 .or. l < 4_pI64) validBase64 = .false. if (mod(l,4_pI64)/=0_pI64 .or. l < 4_pI64) validBase64 = .false.
if(verify(base64_str(:l-2_pI64),base64_encoding, kind=pI64) /= 0_pI64) validBase64 = .false. if (verify(base64_str(:l-2_pI64),base64_encoding, kind=pI64) /= 0_pI64) validBase64 = .false.
if(verify(base64_str(l-1_pI64:),base64_encoding//'=',kind=pI64) /= 0_pI64) validBase64 = .false. if (verify(base64_str(l-1_pI64:),base64_encoding//'=',kind=pI64) /= 0_pI64) validBase64 = .false.
end function validBase64 end function validBase64
@ -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) error stop 'base64_nChar/20/28' 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(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(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(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_nChar(16_pI64) /= 24_pI64) error stop 'base64_nChar/16/24'
if(base64_nByte(4_pI64) /= 3_pI64) error stop 'base64_nByte/4/3' 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' 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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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) error stop '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/grid/grid_mech_FEM.f90
View File

@ -179,7 +179,7 @@ subroutine grid_mechanical_FEM_init
localK = 0_pPetscInt localK = 0_pPetscInt
localK(worldrank) = int(cells3,pPetscInt) localK(worldrank) = int(cells3,pPetscInt)
call MPI_Allreduce(MPI_IN_PLACE,localK,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) call MPI_Allreduce(MPI_IN_PLACE,localK,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
call DMDACreate3d(PETSC_COMM_WORLD, & call DMDACreate3d(PETSC_COMM_WORLD, &
DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, & DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, &
DMDA_STENCIL_BOX, & DMDA_STENCIL_BOX, &
@ -252,16 +252,16 @@ subroutine grid_mechanical_FEM_init
call HDF5_read(P_aim,groupHandle,'P_aim',.false.) call HDF5_read(P_aim,groupHandle,'P_aim',.false.)
call MPI_Bcast(P_aim,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) call MPI_Bcast(P_aim,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI)
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
call HDF5_read(F_aim,groupHandle,'F_aim',.false.) call HDF5_read(F_aim,groupHandle,'F_aim',.false.)
call MPI_Bcast(F_aim,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) call MPI_Bcast(F_aim,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI)
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
call HDF5_read(F_aim_lastInc,groupHandle,'F_aim_lastInc',.false.) call HDF5_read(F_aim_lastInc,groupHandle,'F_aim_lastInc',.false.)
call MPI_Bcast(F_aim_lastInc,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) call MPI_Bcast(F_aim_lastInc,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI)
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
call HDF5_read(F_aimDot,groupHandle,'F_aimDot',.false.) call HDF5_read(F_aimDot,groupHandle,'F_aimDot',.false.)
call MPI_Bcast(F_aimDot,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) call MPI_Bcast(F_aimDot,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI)
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
call HDF5_read(temp33n,groupHandle,'F') call HDF5_read(temp33n,groupHandle,'F')
F = reshape(temp33n,[3,3,cells(1),cells(2),cells3]) F = reshape(temp33n,[3,3,cells(1),cells(2),cells3])
call HDF5_read(temp33n,groupHandle,'F_lastInc') call HDF5_read(temp33n,groupHandle,'F_lastInc')
@ -290,10 +290,10 @@ subroutine grid_mechanical_FEM_init
print'(1x,a,i0,a)', 'reading more restart data of increment ', CLI_restartInc, ' from file' print'(1x,a,i0,a)', 'reading more restart data of increment ', CLI_restartInc, ' from file'
call HDF5_read(C_volAvg,groupHandle,'C_volAvg',.false.) call HDF5_read(C_volAvg,groupHandle,'C_volAvg',.false.)
call MPI_Bcast(C_volAvg,81_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) call MPI_Bcast(C_volAvg,81_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI)
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
call HDF5_read(C_volAvgLastInc,groupHandle,'C_volAvgLastInc',.false.) call HDF5_read(C_volAvgLastInc,groupHandle,'C_volAvgLastInc',.false.)
call MPI_Bcast(C_volAvgLastInc,81_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) call MPI_Bcast(C_volAvgLastInc,81_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI)
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
call HDF5_closeGroup(groupHandle) call HDF5_closeGroup(groupHandle)
call HDF5_closeFile(fileHandle) call HDF5_closeFile(fileHandle)
@ -590,7 +590,7 @@ subroutine formResidual(da_local,x_local, &
P_av,C_volAvg,devNull, & P_av,C_volAvg,devNull, &
F,params%Delta_t,params%rotation_BC) F,params%Delta_t,params%rotation_BC)
call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1_MPI_INTEGER_KIND,MPI_LOGICAL,MPI_LOR,MPI_COMM_WORLD,err_MPI) call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1_MPI_INTEGER_KIND,MPI_LOGICAL,MPI_LOR,MPI_COMM_WORLD,err_MPI)
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! stress BC handling ! stress BC handling

10
src/homogenization.f90
View File

@ -245,8 +245,8 @@ subroutine homogenization_mechanical_response(Delta_t,cell_start,cell_end)
call phase_restore(ce,.false.) ! wrong name (is more a forward function) call phase_restore(ce,.false.) ! wrong name (is more a forward function)
if(homogState(ho)%sizeState > 0) homogState(ho)%state(:,en) = homogState(ho)%state0(:,en) if (homogState(ho)%sizeState > 0) homogState(ho)%state(:,en) = homogState(ho)%state0(:,en)
if(damageState_h(ho)%sizeState > 0) damageState_h(ho)%state(:,en) = damageState_h(ho)%state0(:,en) if (damageState_h(ho)%sizeState > 0) damageState_h(ho)%state(:,en) = damageState_h(ho)%state0(:,en)
call damage_partition(ce) call damage_partition(ce)
doneAndHappy = [.false.,.true.] doneAndHappy = [.false.,.true.]
@ -381,7 +381,7 @@ subroutine homogenization_forward
do ho = 1, size(material_name_homogenization) do ho = 1, size(material_name_homogenization)
homogState (ho)%state0 = homogState (ho)%state homogState (ho)%state0 = homogState (ho)%state
if(damageState_h(ho)%sizeState > 0) & if (damageState_h(ho)%sizeState > 0) &
damageState_h(ho)%state0 = damageState_h(ho)%state damageState_h(ho)%state0 = damageState_h(ho)%state
end do end do
@ -406,7 +406,7 @@ subroutine homogenization_restartWrite(fileHandle)
call HDF5_write(homogState(ho)%state,groupHandle(2),'omega_mechanical') ! ToDo: should be done by mech call HDF5_write(homogState(ho)%state,groupHandle(2),'omega_mechanical') ! ToDo: should be done by mech
if(damageState_h(ho)%sizeState > 0) & if (damageState_h(ho)%sizeState > 0) &
call HDF5_write(damageState_h(ho)%state,groupHandle(2),'omega_damage') ! ToDo: should be done by mech call HDF5_write(damageState_h(ho)%state,groupHandle(2),'omega_damage') ! ToDo: should be done by mech
call HDF5_closeGroup(groupHandle(2)) call HDF5_closeGroup(groupHandle(2))
@ -436,7 +436,7 @@ subroutine homogenization_restartRead(fileHandle)
call HDF5_read(homogState(ho)%state0,groupHandle(2),'omega_mechanical') ! ToDo: should be done by mech call HDF5_read(homogState(ho)%state0,groupHandle(2),'omega_mechanical') ! ToDo: should be done by mech
if(damageState_h(ho)%sizeState > 0) & if (damageState_h(ho)%sizeState > 0) &
call HDF5_read(damageState_h(ho)%state0,groupHandle(2),'omega_damage') ! ToDo: should be done by mech call HDF5_read(damageState_h(ho)%state0,groupHandle(2),'omega_damage') ! ToDo: should be done by mech
call HDF5_closeGroup(groupHandle(2)) call HDF5_closeGroup(groupHandle(2))

2
src/homogenization_damage.f90
View File

@ -83,7 +83,7 @@ module subroutine damage_partition(ce)
integer :: co integer :: co
if(damageState_h(material_homogenizationID(ce))%sizeState < 1) return if (damageState_h(material_homogenizationID(ce))%sizeState < 1) return
phi = damagestate_h(material_homogenizationID(ce))%state(1,material_homogenizationEntry(ce)) phi = damagestate_h(material_homogenizationID(ce))%state(1,material_homogenizationEntry(ce))
do co = 1, homogenization_Nconstituents(material_homogenizationID(ce)) do co = 1, homogenization_Nconstituents(material_homogenizationID(ce))
call phase_set_phi(phi,co,ce) call phase_set_phi(phi,co,ce)

62
src/materialpoint.f90
View File

@ -40,37 +40,37 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Initialize all modules. !> @brief Initialize all modules.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_initAll subroutine materialpoint_initAll()
call parallelization_init call parallelization_init()
call CLI_init ! Spectral and FEM interface to commandline call CLI_init() ! grid and mesh commandline interface
call signals_init call signals_init()
call prec_init call prec_init()
call IO_init call IO_init()
#if defined(MESH) #if defined(MESH)
call FEM_quadrature_init call FEM_quadrature_init()
#elif defined(GRID) #elif defined(GRID)
call base64_init call base64_init()
#endif #endif
call YAML_types_init call YAML_types_init()
call YAML_parse_init call YAML_parse_init()
call HDF5_utilities_init call HDF5_utilities_init()
call results_init(restart=CLI_restartInc>0) call results_init(restart=CLI_restartInc>0)
call config_init call config_init()
call math_init call math_init()
call rotations_init call rotations_init()
call polynomials_init call polynomials_init()
call lattice_init call lattice_init()
#if defined(MESH) #if defined(MESH)
call discretization_mesh_init(restart=CLI_restartInc>0) call discretization_mesh_init(restart=CLI_restartInc>0)
#elif defined(GRID) #elif defined(GRID)
call discretization_grid_init(restart=CLI_restartInc>0) call discretization_grid_init(restart=CLI_restartInc>0)
#endif #endif
call material_init(restart=CLI_restartInc>0) call material_init(restart=CLI_restartInc>0)
call phase_init call phase_init()
call homogenization_init call homogenization_init()
call materialpoint_init call materialpoint_init()
call config_deallocate call config_deallocate()
end subroutine materialpoint_initAll end subroutine materialpoint_initAll
@ -78,7 +78,7 @@ end subroutine materialpoint_initAll
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Read restart information if needed. !> @brief Read restart information if needed.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_init subroutine materialpoint_init()
integer(HID_T) :: fileHandle integer(HID_T) :: fileHandle
@ -103,7 +103,7 @@ end subroutine materialpoint_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Write restart information. !> @brief Write restart information.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_restartWrite subroutine materialpoint_restartWrite()
integer(HID_T) :: fileHandle integer(HID_T) :: fileHandle
@ -123,10 +123,10 @@ end subroutine materialpoint_restartWrite
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Forward data for new time increment. !> @brief Forward data for new time increment.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_forward subroutine materialpoint_forward()
call homogenization_forward call homogenization_forward()
call phase_forward call phase_forward()
end subroutine materialpoint_forward end subroutine materialpoint_forward
@ -139,13 +139,13 @@ subroutine materialpoint_results(inc,time)
integer, intent(in) :: inc integer, intent(in) :: inc
real(pReal), intent(in) :: time real(pReal), intent(in) :: time
call results_openJobFile call results_openJobFile()
call results_addIncrement(inc,time) call results_addIncrement(inc,time)
call phase_results call phase_results()
call homogenization_results call homogenization_results()
call discretization_results call discretization_results()
call results_finalizeIncrement call results_finalizeIncrement()
call results_closeJobFile call results_closeJobFile()
end subroutine materialpoint_results end subroutine materialpoint_results

4
src/mesh/FEM_utilities.f90
View File

@ -120,14 +120,14 @@ subroutine FEM_utilities_init
debug_mesh => config_debug%get_dict('mesh',defaultVal=emptyDict) debug_mesh => config_debug%get_dict('mesh',defaultVal=emptyDict)
debugPETSc = debug_mesh%contains('PETSc') debugPETSc = debug_mesh%contains('PETSc')
if(debugPETSc) print'(3(/,1x,a),/)', & if (debugPETSc) print'(3(/,1x,a),/)', &
'Initializing PETSc with debug options: ', & 'Initializing PETSc with debug options: ', &
trim(PETScDebug), & trim(PETScDebug), &
'add more using the "PETSc_options" keyword in numerics.yaml' 'add more using the "PETSc_options" keyword in numerics.yaml'
flush(IO_STDOUT) flush(IO_STDOUT)
call PetscOptionsClear(PETSC_NULL_OPTIONS,err_PETSc) call PetscOptionsClear(PETSC_NULL_OPTIONS,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
if(debugPETSc) call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(PETSCDEBUG),err_PETSc) if (debugPETSc) call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(PETSCDEBUG),err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-mechanical_snes_type newtonls & call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-mechanical_snes_type newtonls &
&-mechanical_snes_linesearch_type cp -mechanical_snes_ksp_ew & &-mechanical_snes_linesearch_type cp -mechanical_snes_ksp_ew &

4
src/parallelization.f90
View File

@ -53,7 +53,7 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Initialize shared memory (openMP) and distributed memory (MPI) parallelization. !> @brief Initialize shared memory (openMP) and distributed memory (MPI) parallelization.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine parallelization_init subroutine parallelization_init()
integer(MPI_INTEGER_KIND) :: err_MPI, typeSize, version, subversion, devNull integer(MPI_INTEGER_KIND) :: err_MPI, typeSize, version, subversion, devNull
character(len=4) :: rank_str character(len=4) :: rank_str
@ -136,7 +136,7 @@ subroutine parallelization_init
error stop 'Mismatch between MPI_DOUBLE and DAMASK pReal' error stop 'Mismatch between MPI_DOUBLE and DAMASK pReal'
!$ call get_environment_variable(name='OMP_NUM_THREADS',value=NumThreadsString,STATUS=got_env) !$ call get_environment_variable(name='OMP_NUM_THREADS',value=NumThreadsString,STATUS=got_env)
!$ if(got_env /= 0) then !$ if (got_env /= 0) then
!$ print'(1x,a)', 'Could not get $OMP_NUM_THREADS, using default' !$ print'(1x,a)', 'Could not get $OMP_NUM_THREADS, using default'
!$ OMP_NUM_THREADS = 4_pI32 !$ OMP_NUM_THREADS = 4_pI32
!$ else !$ else

18
src/phase_mechanical.f90
View File

@ -596,7 +596,7 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b
dotState_last(1:sizeDotState,1) = dotState dotState_last(1:sizeDotState,1) = dotState
broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en)
if(broken) exit iteration if (broken) exit iteration
dotState = plastic_dotState(Delta_t,ph,en) dotState = plastic_dotState(Delta_t,ph,en)
if (any(IEEE_is_NaN(dotState))) exit iteration if (any(IEEE_is_NaN(dotState))) exit iteration
@ -677,7 +677,7 @@ function integrateStateEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result
#endif #endif
broken = plastic_deltaState(ph,en) broken = plastic_deltaState(ph,en)
if(broken) return if (broken) return
broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en)
@ -720,10 +720,10 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en
#endif #endif
broken = plastic_deltaState(ph,en) broken = plastic_deltaState(ph,en)
if(broken) return if (broken) return
broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en)
if(broken) return if (broken) return
dotState = plastic_dotState(Delta_t,ph,en) dotState = plastic_dotState(Delta_t,ph,en)
if (any(IEEE_is_NaN(dotState))) return if (any(IEEE_is_NaN(dotState))) return
@ -852,13 +852,13 @@ function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB)
#endif #endif
broken = integrateStress(F_0+(F-F_0)*Delta_t*C(stage),subFp0,subFi0,Delta_t*C(stage), ph,en) broken = integrateStress(F_0+(F-F_0)*Delta_t*C(stage),subFp0,subFi0,Delta_t*C(stage), ph,en)
if(broken) exit if (broken) exit
dotState = plastic_dotState(Delta_t*C(stage), ph,en) dotState = plastic_dotState(Delta_t*C(stage), ph,en)
if (any(IEEE_is_NaN(dotState))) exit if (any(IEEE_is_NaN(dotState))) exit
end do end do
if(broken) return if (broken) return
plastic_RKdotState(1:sizeDotState,size(B)) = dotState plastic_RKdotState(1:sizeDotState,size(B)) = dotState
@ -869,15 +869,15 @@ function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB)
plasticState(ph)%state(1:sizeDotState,en) = IEEE_FMA(dotState,Delta_t,subState0) plasticState(ph)%state(1:sizeDotState,en) = IEEE_FMA(dotState,Delta_t,subState0)
#endif #endif
if(present(DB)) & if (present(DB)) &
broken = .not. converged(matmul(plastic_RKdotState(1:sizeDotState,1:size(DB)),DB) * Delta_t, & broken = .not. converged(matmul(plastic_RKdotState(1:sizeDotState,1:size(DB)),DB) * Delta_t, &
plasticState(ph)%state(1:sizeDotState,en), & plasticState(ph)%state(1:sizeDotState,en), &
plasticState(ph)%atol(1:sizeDotState)) plasticState(ph)%atol(1:sizeDotState))
if(broken) return if (broken) return
broken = plastic_deltaState(ph,en) broken = plastic_deltaState(ph,en)
if(broken) return if (broken) return
broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en)

2
src/phase_mechanical_eigen_cleavageopening.f90
View File

@ -19,7 +19,7 @@ module function damage_anisobrittle_init() result(myKinematics)
myKinematics = kinematics_active2('anisobrittle') myKinematics = kinematics_active2('anisobrittle')
if(count(myKinematics) == 0) return if (count(myKinematics) == 0) return
print'(/,1x,a)', '<<<+- phase:mechanical:eigen:cleavageopening init -+>>>' print'(/,1x,a)', '<<<+- phase:mechanical:eigen:cleavageopening init -+>>>'
print'(/,a,i2)', ' # phases: ',count(myKinematics); flush(IO_STDOUT) print'(/,a,i2)', ' # phases: ',count(myKinematics); flush(IO_STDOUT)

4
src/phase_mechanical_plastic_isotropic.f90
View File

@ -64,7 +64,7 @@ module function plastic_isotropic_init() result(myPlasticity)
myPlasticity = plastic_active('isotropic') myPlasticity = plastic_active('isotropic')
if(count(myPlasticity) == 0) return if (count(myPlasticity) == 0) return
print'(/,1x,a)', '<<<+- phase:mechanical:plastic:isotropic init -+>>>' print'(/,1x,a)', '<<<+- phase:mechanical:plastic:isotropic init -+>>>'
print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT) print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT)
@ -77,7 +77,7 @@ module function plastic_isotropic_init() result(myPlasticity)
allocate(state(phases%length)) allocate(state(phases%length))
do ph = 1, phases%length do ph = 1, phases%length
if(.not. myPlasticity(ph)) cycle if (.not. myPlasticity(ph)) cycle
associate(prm => param(ph), stt => state(ph)) associate(prm => param(ph), stt => state(ph))

8
src/phase_mechanical_plastic_kinehardening.f90
View File

@ -86,7 +86,7 @@ module function plastic_kinehardening_init() result(myPlasticity)
pl pl
myPlasticity = plastic_active('kinehardening') myPlasticity = plastic_active('kinehardening')
if(count(myPlasticity) == 0) return if (count(myPlasticity) == 0) return
print'(/,1x,a)', '<<<+- phase:mechanical:plastic:kinehardening init -+>>>' print'(/,1x,a)', '<<<+- phase:mechanical:plastic:kinehardening init -+>>>'
print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT) print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT)
@ -127,7 +127,7 @@ module function plastic_kinehardening_init() result(myPlasticity)
if (phase_lattice(ph) == 'cI') then if (phase_lattice(ph) == 'cI') then
a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray) a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray)
if(size(a) > 0) prm%nonSchmidActive = .true. if (size(a) > 0) prm%nonSchmidActive = .true.
prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1) prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1)
prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1) prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1)
else else
@ -189,7 +189,7 @@ module function plastic_kinehardening_init() result(myPlasticity)
stt%xi => plasticState(ph)%state(startIndex:endIndex,:) stt%xi => plasticState(ph)%state(startIndex:endIndex,:)
stt%xi = spread(xi_0, 2, Nmembers) stt%xi = spread(xi_0, 2, Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal)
if(any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi'
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl endIndex = endIndex + prm%sum_N_sl
@ -202,7 +202,7 @@ module function plastic_kinehardening_init() result(myPlasticity)
idx_dot%gamma = [startIndex,endIndex] idx_dot%gamma = [startIndex,endIndex]
stt%gamma => plasticState(ph)%state(startIndex:endIndex,:) stt%gamma => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal)
if(any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma'
o = plasticState(ph)%offsetDeltaState o = plasticState(ph)%offsetDeltaState
startIndex = endIndex + 1 startIndex = endIndex + 1

8
src/phase_mechanical_plastic_nonlocal.f90
View File

@ -251,7 +251,7 @@ module function plastic_nonlocal_init() result(myPlasticity)
if (phase_lattice(ph) == 'cI') then if (phase_lattice(ph) == 'cI') then
a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray) a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray)
if(size(a) > 0) prm%nonSchmidActive = .true. if (size(a) > 0) prm%nonSchmidActive = .true.
prm%P_nS_pos = lattice_nonSchmidMatrix(ini%N_sl,a,+1) prm%P_nS_pos = lattice_nonSchmidMatrix(ini%N_sl,a,+1)
prm%P_nS_neg = lattice_nonSchmidMatrix(ini%N_sl,a,-1) prm%P_nS_neg = lattice_nonSchmidMatrix(ini%N_sl,a,-1)
else else
@ -416,7 +416,7 @@ module function plastic_nonlocal_init() result(myPlasticity)
allocate(geom(ph)%IPcoordinates(3,Nmembers)) allocate(geom(ph)%IPcoordinates(3,Nmembers))
call storeGeometry(ph) call storeGeometry(ph)
if(plasticState(ph)%nonlocal .and. .not. allocated(IPneighborhood)) & if (plasticState(ph)%nonlocal .and. .not. allocated(IPneighborhood)) &
call IO_error(212,ext_msg='IPneighborhood does not exist') call IO_error(212,ext_msg='IPneighborhood does not exist')
st0%rho => plasticState(ph)%state0 (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:) st0%rho => plasticState(ph)%state0 (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
@ -485,7 +485,7 @@ module function plastic_nonlocal_init() result(myPlasticity)
dot%gamma => plasticState(ph)%dotState (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers) dot%gamma => plasticState(ph)%dotState (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers)
del%gamma => plasticState(ph)%deltaState (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers) del%gamma => plasticState(ph)%deltaState (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers)
plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl ) = pl%get_asFloat('atol_gamma', defaultVal = 1.0e-6_pReal) plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl ) = pl%get_asFloat('atol_gamma', defaultVal = 1.0e-6_pReal)
if(any(plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl) < 0.0_pReal)) & if (any(plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl) < 0.0_pReal)) &
extmsg = trim(extmsg)//' atol_gamma' extmsg = trim(extmsg)//' atol_gamma'
stt%rho_forest => plasticState(ph)%state (11*prm%sum_N_sl + 1:12*prm%sum_N_sl,1:Nmembers) stt%rho_forest => plasticState(ph)%state (11*prm%sum_N_sl + 1:12*prm%sum_N_sl,1:Nmembers)
@ -518,7 +518,7 @@ module function plastic_nonlocal_init() result(myPlasticity)
do ph = 1, phases%length do ph = 1, phases%length
if(.not. myPlasticity(ph)) cycle if (.not. myPlasticity(ph)) cycle
phase => phases%get_dict(ph) phase => phases%get_dict(ph)
Nmembers = count(material_phaseID == ph) Nmembers = count(material_phaseID == ph)

8
src/phase_mechanical_plastic_phenopowerlaw.f90
View File

@ -100,7 +100,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
myPlasticity = plastic_active('phenopowerlaw') myPlasticity = plastic_active('phenopowerlaw')
if(count(myPlasticity) == 0) return if (count(myPlasticity) == 0) return
print'(/,1x,a)', '<<<+- phase:mechanical:plastic:phenopowerlaw init -+>>>' print'(/,1x,a)', '<<<+- phase:mechanical:plastic:phenopowerlaw init -+>>>'
print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT) print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT)
@ -131,7 +131,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
if (phase_lattice(ph) == 'cI') then if (phase_lattice(ph) == 'cI') then
a = pl%get_as1dFloat('a_nonSchmid',defaultVal=emptyRealArray) a = pl%get_as1dFloat('a_nonSchmid',defaultVal=emptyRealArray)
if(size(a) > 0) prm%nonSchmidActive = .true. if (size(a) > 0) prm%nonSchmidActive = .true.
prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1) prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1)
prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1) prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1)
else else
@ -243,7 +243,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
stt%xi_sl => plasticState(ph)%state(startIndex:endIndex,:) stt%xi_sl => plasticState(ph)%state(startIndex:endIndex,:)
stt%xi_sl = spread(xi_0_sl, 2, Nmembers) stt%xi_sl = spread(xi_0_sl, 2, Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal)
if(any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi'
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tw endIndex = endIndex + prm%sum_N_tw
@ -257,7 +257,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
idx_dot%gamma_sl = [startIndex,endIndex] idx_dot%gamma_sl = [startIndex,endIndex]
stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:) stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal)
if(any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma'
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tw endIndex = endIndex + prm%sum_N_tw

2
src/phase_thermal_dissipation.f90
View File

@ -37,7 +37,7 @@ module function dissipation_init(source_length) result(mySources)
mySources = thermal_active('dissipation',source_length) mySources = thermal_active('dissipation',source_length)
if(count(mySources) == 0) return if (count(mySources) == 0) return
print'(/,1x,a)', '<<<+- phase:thermal:dissipation init -+>>>' print'(/,1x,a)', '<<<+- phase:thermal:dissipation init -+>>>'
print'(/,a,i2)', ' # phases: ',count(mySources); flush(IO_STDOUT) print'(/,a,i2)', ' # phases: ',count(mySources); flush(IO_STDOUT)

2
src/phase_thermal_externalheat.f90
View File

@ -44,7 +44,7 @@ module function externalheat_init(source_length) result(mySources)
mySources = thermal_active('externalheat',source_length) mySources = thermal_active('externalheat',source_length)
if(count(mySources) == 0) return if (count(mySources) == 0) return
print'(/,1x,a)', '<<<+- phase:thermal:externalheat init -+>>>' print'(/,1x,a)', '<<<+- phase:thermal:externalheat init -+>>>'
print'(/,a,i2)', ' # phases: ',count(mySources); flush(IO_STDOUT) print'(/,a,i2)', ' # phases: ',count(mySources); flush(IO_STDOUT)

10
src/polynomials.f90
View File

@ -1,6 +1,6 @@
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @author Martin Diehl, KU Leuven !> @author Martin Diehl, KU Leuven
!> @brief Polynomial representation for variable data !> @brief Polynomial representation for variable data.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module polynomials module polynomials
use prec use prec
@ -19,8 +19,8 @@ module polynomials
end type tPolynomial end type tPolynomial
interface polynomial interface polynomial
module procedure polynomial_from_dict
module procedure polynomial_from_coef module procedure polynomial_from_coef
module procedure polynomial_from_dict
end interface polynomial end interface polynomial
public :: & public :: &
@ -43,7 +43,7 @@ end subroutine polynomials_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Initialize a Polynomial from Coefficients. !> @brief Initialize a polynomial from coefficients.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function polynomial_from_coef(coef,x_ref) result(p) pure function polynomial_from_coef(coef,x_ref) result(p)
@ -59,7 +59,7 @@ end function polynomial_from_coef
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Initialize a Polynomial from a Dictionary with Coefficients. !> @brief Initialize a polynomial from a dictionary with coefficients.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function polynomial_from_dict(dict,y,x) result(p) function polynomial_from_dict(dict,y,x) result(p)
@ -93,7 +93,7 @@ end function polynomial_from_dict
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Evaluate a Polynomial. !> @brief Evaluate a polynomial.
!> @details https://nvlpubs.nist.gov/nistpubs/jres/71b/jresv71bn1p11_a1b.pdf (eq. 1.2) !> @details https://nvlpubs.nist.gov/nistpubs/jres/71b/jresv71bn1p11_a1b.pdf (eq. 1.2)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function eval(self,x) result(y) pure function eval(self,x) result(y)

124
src/results.f90
View File

@ -421,15 +421,15 @@ subroutine results_writeTensorDataset_real(dataset,group,label,description,SIuni
real(pReal), dimension(:,:,:), allocatable :: dataset_transposed real(pReal), dimension(:,:,:), allocatable :: dataset_transposed
if(present(transposed)) then if (present(transposed)) then
transposed_ = transposed transposed_ = transposed
else else
transposed_ = .true. transposed_ = .true.
end if end if
groupHandle = results_openGroup(group) groupHandle = results_openGroup(group)
if(transposed_) then if (transposed_) then
if(size(dataset,1) /= size(dataset,2)) error stop 'transpose non-symmetric tensor' if (size(dataset,1) /= size(dataset,2)) error stop 'transpose non-symmetric tensor'
allocate(dataset_transposed,mold=dataset) allocate(dataset_transposed,mold=dataset)
do i=1,size(dataset_transposed,3) do i=1,size(dataset_transposed,3)
dataset_transposed(:,:,i) = transpose(dataset(:,:,i)) dataset_transposed(:,:,i) = transpose(dataset(:,:,i))
@ -527,7 +527,7 @@ subroutine results_mapping_phase(ID,entry,label)
writeSize(worldrank) = size(entry(1,:)) ! total number of entries of this process writeSize(worldrank) = size(entry(1,:)) ! total number of entries of this process
call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
#ifndef PETSC #ifndef PETSC
entryGlobal = int(entry -1,pI64) ! 0-based entryGlobal = int(entry -1,pI64) ! 0-based
@ -535,10 +535,10 @@ subroutine results_mapping_phase(ID,entry,label)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! MPI settings and communication ! MPI settings and communication
call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call MPI_Allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get output at each process call MPI_Allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get output at each process
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
entryOffset = 0_pI64 entryOffset = 0_pI64
do co = 1, size(ID,1) do co = 1, size(ID,1)
@ -547,7 +547,7 @@ subroutine results_mapping_phase(ID,entry,label)
end do end do
end do end do
call MPI_Allreduce(MPI_IN_PLACE,entryOffset,size(entryOffset),MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,err_MPI)! get offset at each process call MPI_Allreduce(MPI_IN_PLACE,entryOffset,size(entryOffset),MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,err_MPI)! get offset at each process
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
entryOffset(:,worldrank) = sum(entryOffset(:,0:worldrank-1),2) entryOffset(:,worldrank) = sum(entryOffset(:,0:worldrank-1),2)
do co = 1, size(ID,1) do co = 1, size(ID,1)
do ce = 1, size(ID,2) do ce = 1, size(ID,2)
@ -563,80 +563,80 @@ subroutine results_mapping_phase(ID,entry,label)
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
! compound type: label(ID) + entry ! compound type: label(ID) + entry
call H5Tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr) call H5Tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr) call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tget_size_f(dt_id, type_size_string, hdferr) call H5Tget_size_f(dt_id, type_size_string, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND) pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND)
call H5Tget_size_f(pI64_t, type_size_int, hdferr) call H5Tget_size_f(pI64_t, type_size_int, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr) call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr) call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr) call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! create memory types for each component of the compound type ! create memory types for each component of the compound type
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr) call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr) call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tcreate_f(H5T_COMPOUND_F, type_size_int, entry_id, hdferr) call H5Tcreate_f(H5T_COMPOUND_F, type_size_int, entry_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tinsert_f(entry_id, 'entry', 0_SIZE_T, pI64_t, hdferr) call H5Tinsert_f(entry_id, 'entry', 0_SIZE_T, pI64_t, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tclose_f(dt_id, hdferr) call H5Tclose_f(dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape = hyperslab) and in file (global shape) ! create dataspace in memory (local shape = hyperslab) and in file (global shape)
call H5Screate_simple_f(2,myShape,memspace_id,hdferr,myShape) call H5Screate_simple_f(2,myShape,memspace_id,hdferr,myShape)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Screate_simple_f(2,totalShape,filespace_id,hdferr,totalShape) call H5Screate_simple_f(2,totalShape,filespace_id,hdferr,totalShape)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, hdferr) call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! write the components of the compound type individually ! write the components of the compound type individually
call H5Pset_preserve_f(plist_id, .true., hdferr) call H5Pset_preserve_f(plist_id, .true., hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
loc_id = results_openGroup('/cell_to') loc_id = results_openGroup('/cell_to')
call H5Dcreate_f(loc_id, 'phase', dtype_id, filespace_id, dset_id, hdferr) call H5Dcreate_f(loc_id, 'phase', dtype_id, filespace_id, dset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dwrite_f(dset_id, label_id, reshape(label(pack(ID,.true.)),myShape), & call H5Dwrite_f(dset_id, label_id, reshape(label(pack(ID,.true.)),myShape), &
myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dwrite_f(dset_id, entry_id, reshape(pack(entryGlobal,.true.),myShape), & call H5Dwrite_f(dset_id, entry_id, reshape(pack(entryGlobal,.true.),myShape), &
myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! close all ! close all
call HDF5_closeGroup(loc_id) call HDF5_closeGroup(loc_id)
call H5Pclose_f(plist_id, hdferr) call H5Pclose_f(plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(filespace_id, hdferr) call H5Sclose_f(filespace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(memspace_id, hdferr) call H5Sclose_f(memspace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dclose_f(dset_id, hdferr) call H5Dclose_f(dset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tclose_f(dtype_id, hdferr) call H5Tclose_f(dtype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tclose_f(label_id, hdferr) call H5Tclose_f(label_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tclose_f(entry_id, hdferr) call H5Tclose_f(entry_id, hdferr)
call executionStamp('cell_to/phase','cell ID and constituent ID to phase results') call executionStamp('cell_to/phase','cell ID and constituent ID to phase results')
@ -683,7 +683,7 @@ subroutine results_mapping_homogenization(ID,entry,label)
writeSize(worldrank) = size(entry) ! total number of entries of this process writeSize(worldrank) = size(entry) ! total number of entries of this process
call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
#ifndef PETSC #ifndef PETSC
entryGlobal = int(entry -1,pI64) ! 0-based entryGlobal = int(entry -1,pI64) ! 0-based
@ -691,17 +691,17 @@ subroutine results_mapping_homogenization(ID,entry,label)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! MPI settings and communication ! MPI settings and communication
call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call MPI_Allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get output at each process call MPI_Allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get output at each process
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
entryOffset = 0_pI64 entryOffset = 0_pI64
do ce = 1, size(ID,1) do ce = 1, size(ID,1)
entryOffset(ID(ce),worldrank) = entryOffset(ID(ce),worldrank) +1_pI64 entryOffset(ID(ce),worldrank) = entryOffset(ID(ce),worldrank) +1_pI64
end do end do
call MPI_Allreduce(MPI_IN_PLACE,entryOffset,size(entryOffset),MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,err_MPI)! get offset at each process call MPI_Allreduce(MPI_IN_PLACE,entryOffset,size(entryOffset),MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,err_MPI)! get offset at each process
if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
entryOffset(:,worldrank) = sum(entryOffset(:,0:worldrank-1),2) entryOffset(:,worldrank) = sum(entryOffset(:,0:worldrank-1),2)
do ce = 1, size(ID,1) do ce = 1, size(ID,1)
entryGlobal(ce) = int(entry(ce),pI64) -1_pI64 + entryOffset(ID(ce),worldrank) entryGlobal(ce) = int(entry(ce),pI64) -1_pI64 + entryOffset(ID(ce),worldrank)
@ -715,82 +715,82 @@ subroutine results_mapping_homogenization(ID,entry,label)
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
! compound type: label(ID) + entry ! compound type: label(ID) + entry
call H5Tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr) call H5Tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr) call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tget_size_f(dt_id, type_size_string, hdferr) call H5Tget_size_f(dt_id, type_size_string, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND) pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND)
call H5Tget_size_f(pI64_t, type_size_int, hdferr) call H5Tget_size_f(pI64_t, type_size_int, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr) call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr) call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr) call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! create memory types for each component of the compound type ! create memory types for each component of the compound type
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr) call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr) call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tcreate_f(H5T_COMPOUND_F, type_size_int, entry_id, hdferr) call H5Tcreate_f(H5T_COMPOUND_F, type_size_int, entry_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tinsert_f(entry_id, 'entry', 0_SIZE_T, pI64_t, hdferr) call H5Tinsert_f(entry_id, 'entry', 0_SIZE_T, pI64_t, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tclose_f(dt_id, hdferr) call H5Tclose_f(dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape = hyperslab) and in file (global shape) ! create dataspace in memory (local shape = hyperslab) and in file (global shape)
call H5Screate_simple_f(1,myShape,memspace_id,hdferr,myShape) call H5Screate_simple_f(1,myShape,memspace_id,hdferr,myShape)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Screate_simple_f(1,totalShape,filespace_id,hdferr,totalShape) call H5Screate_simple_f(1,totalShape,filespace_id,hdferr,totalShape)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, hdferr) call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! write the components of the compound type individually ! write the components of the compound type individually
call H5Pset_preserve_f(plist_id, .true., hdferr) call H5Pset_preserve_f(plist_id, .true., hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
loc_id = results_openGroup('/cell_to') loc_id = results_openGroup('/cell_to')
call H5Dcreate_f(loc_id, 'homogenization', dtype_id, filespace_id, dset_id, hdferr) call H5Dcreate_f(loc_id, 'homogenization', dtype_id, filespace_id, dset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dwrite_f(dset_id, label_id, reshape(label(pack(ID,.true.)),myShape), & call H5Dwrite_f(dset_id, label_id, reshape(label(pack(ID,.true.)),myShape), &
myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dwrite_f(dset_id, entry_id, reshape(pack(entryGlobal,.true.),myShape), & call H5Dwrite_f(dset_id, entry_id, reshape(pack(entryGlobal,.true.),myShape), &
myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! close all ! close all
call HDF5_closeGroup(loc_id) call HDF5_closeGroup(loc_id)
call H5Pclose_f(plist_id, hdferr) call H5Pclose_f(plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(filespace_id, hdferr) call H5Sclose_f(filespace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Sclose_f(memspace_id, hdferr) call H5Sclose_f(memspace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Dclose_f(dset_id, hdferr) call H5Dclose_f(dset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tclose_f(dtype_id, hdferr) call H5Tclose_f(dtype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tclose_f(label_id, hdferr) call H5Tclose_f(label_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call H5Tclose_f(entry_id, hdferr) call H5Tclose_f(entry_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
call executionStamp('cell_to/homogenization','cell ID to homogenization results') call executionStamp('cell_to/homogenization','cell ID to homogenization results')

38
src/rotations.f90
View File

@ -212,10 +212,10 @@ subroutine fromAxisAngle(self,ax,degrees,P)
axis = ax(1:3) axis = ax(1:3)
else else
axis = ax(1:3) * merge(-1.0_pReal,1.0_pReal,P == 1) axis = ax(1:3) * merge(-1.0_pReal,1.0_pReal,P == 1)
if(abs(P) /= 1) call IO_error(402,ext_msg='fromAxisAngle (P)') if (abs(P) /= 1) call IO_error(402,ext_msg='fromAxisAngle (P)')
end if end if
if(dNeq(norm2(axis),1.0_pReal) .or. angle < 0.0_pReal .or. angle > PI) & if (dNeq(norm2(axis),1.0_pReal) .or. angle < 0.0_pReal .or. angle > PI) &
call IO_error(402,ext_msg='fromAxisAngle') call IO_error(402,ext_msg='fromAxisAngle')
self%q = ax2qu([axis,angle]) self%q = ax2qu([axis,angle])
@ -513,11 +513,11 @@ pure function om2qu(om) result(qu)
trace = math_trace33(om) trace = math_trace33(om)
if(trace > 0.0_pReal) then if (trace > 0.0_pReal) then
s = 0.5_pReal / sqrt(trace+1.0_pReal) s = 0.5_pReal / sqrt(trace+1.0_pReal)
qu = [0.25_pReal/s, (om(3,2)-om(2,3))*s,(om(1,3)-om(3,1))*s,(om(2,1)-om(1,2))*s] qu = [0.25_pReal/s, (om(3,2)-om(2,3))*s,(om(1,3)-om(3,1))*s,(om(2,1)-om(1,2))*s]
else else
if( om(1,1) > om(2,2) .and. om(1,1) > om(3,3) ) then if ( om(1,1) > om(2,2) .and. om(1,1) > om(3,3) ) then
s = 2.0_pReal * sqrt( 1.0_pReal + om(1,1) - om(2,2) - om(3,3)) s = 2.0_pReal * sqrt( 1.0_pReal + om(1,1) - om(2,2) - om(3,3))
qu = [ (om(3,2) - om(2,3)) /s,0.25_pReal * s,(om(1,2) + om(2,1)) / s,(om(1,3) + om(3,1)) / s] qu = [ (om(3,2) - om(2,3)) /s,0.25_pReal * s,(om(1,2) + om(2,1)) / s,(om(1,3) + om(3,1)) / s]
elseif (om(2,2) > om(3,3)) then elseif (om(2,2) > om(3,3)) then
@ -528,7 +528,7 @@ pure function om2qu(om) result(qu)
qu = [ (om(2,1) - om(1,2)) /s,(om(1,3) + om(3,1)) / s,(om(2,3) + om(3,2)) / s,0.25_pReal * s] qu = [ (om(2,1) - om(1,2)) /s,(om(1,3) + om(3,1)) / s,(om(2,3) + om(3,2)) / s,0.25_pReal * s]
end if end if
end if end if
if(sign(1.0_pReal,qu(1))<0.0_pReal) qu =-1.0_pReal * qu if (sign(1.0_pReal,qu(1))<0.0_pReal) qu =-1.0_pReal * qu
qu(2:4) = merge(qu(2:4),qu(2:4)*P,dEq0(qu(2:4))) qu(2:4) = merge(qu(2:4),qu(2:4)*P,dEq0(qu(2:4)))
qu = qu/norm2(qu) qu = qu/norm2(qu)
@ -619,7 +619,7 @@ pure function eu2qu(eu) result(qu)
-P*sPhi*cos(ee(1)-ee(3)), & -P*sPhi*cos(ee(1)-ee(3)), &
-P*sPhi*sin(ee(1)-ee(3)), & -P*sPhi*sin(ee(1)-ee(3)), &
-P*cPhi*sin(ee(1)+ee(3))] -P*cPhi*sin(ee(1)+ee(3))]
if(sign(1.0_pReal,qu(1)) < 0.0_pReal) qu = qu * (-1.0_pReal) if (sign(1.0_pReal,qu(1)) < 0.0_pReal) qu = qu * (-1.0_pReal)
end function eu2qu end function eu2qu
@ -807,15 +807,15 @@ subroutine selfTest()
do i = 1, 20 do i = 1, 20
if(i==1) then if (i==1) then
qu = [1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal] qu = [1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal]
elseif(i==2) then elseif (i==2) then
qu = [1.0_pReal,-0.0_pReal,-0.0_pReal,-0.0_pReal] qu = [1.0_pReal,-0.0_pReal,-0.0_pReal,-0.0_pReal]
elseif(i==3) then elseif (i==3) then
qu = [0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal] qu = [0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal]
elseif(i==4) then elseif (i==4) then
qu = [0.0_pReal,0.0_pReal,1.0_pReal,0.0_pReal] qu = [0.0_pReal,0.0_pReal,1.0_pReal,0.0_pReal]
elseif(i==5) then elseif (i==5) then
qu = [0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal] qu = [0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal]
else else
call random_number(x) call random_number(x)
@ -825,20 +825,20 @@ subroutine selfTest()
sin(TAU*x(2))*B,& sin(TAU*x(2))*B,&
cos(TAU*x(2))*B,& cos(TAU*x(2))*B,&
sin(TAU*x(1))*A] sin(TAU*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)
end if end if
if(.not. quaternion_equal(om2qu(qu2om(qu)),qu)) error stop 'om2qu2om' if (.not. quaternion_equal(om2qu(qu2om(qu)),qu)) error stop 'om2qu2om'
if(.not. quaternion_equal(eu2qu(qu2eu(qu)),qu)) error stop 'eu2qu2eu' if (.not. quaternion_equal(eu2qu(qu2eu(qu)),qu)) error stop 'eu2qu2eu'
if(.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) error stop 'ax2qu2ax' if (.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) error stop 'ax2qu2ax'
om = qu2om(qu) om = qu2om(qu)
if(.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) error stop 'eu2om2eu' if (.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) error stop 'eu2om2eu'
if(.not. quaternion_equal(om2qu(ax2om(om2ax(om))),qu)) error stop 'ax2om2ax' if (.not. quaternion_equal(om2qu(ax2om(om2ax(om))),qu)) error stop 'ax2om2ax'
eu = qu2eu(qu) eu = qu2eu(qu)
if(.not. quaternion_equal(eu2qu(ax2eu(eu2ax(eu))),qu)) error stop 'ax2eu2ax' if (.not. quaternion_equal(eu2qu(ax2eu(eu2ax(eu))),qu)) error stop 'ax2eu2ax'
call R%fromMatrix(om) call R%fromMatrix(om)
@ -872,7 +872,7 @@ subroutine selfTest()
logical :: ok logical :: ok
ok = all(dEq(qu1,qu2,1.0e-7_pReal)) ok = all(dEq(qu1,qu2,1.0e-7_pReal))
if(dEq0(qu1(1),1.0e-12_pReal)) & if (dEq0(qu1(1),1.0e-12_pReal)) &
ok = ok .or. all(dEq(-1.0_pReal*qu1,qu2,1.0e-7_pReal)) ok = ok .or. all(dEq(-1.0_pReal*qu1,qu2,1.0e-7_pReal))
end function quaternion_equal end function quaternion_equal

6
src/system_routines.f90
View File

@ -119,7 +119,7 @@ function getCWD()
call getCWD_C(getCWD_Cstring,stat) call getCWD_C(getCWD_Cstring,stat)
if(stat == 0) then if (stat == 0) then
getCWD = c_f_string(getCWD_Cstring) getCWD = c_f_string(getCWD_Cstring)
else else
error stop 'invalid working directory' error stop 'invalid working directory'
@ -141,7 +141,7 @@ function getHostName()
call getHostName_C(getHostName_Cstring,stat) call getHostName_C(getHostName_Cstring,stat)
if(stat == 0) then if (stat == 0) then
getHostName = c_f_string(getHostName_Cstring) getHostName = c_f_string(getHostName_Cstring)
else else
getHostName = 'n/a (Error!)' getHostName = 'n/a (Error!)'
@ -163,7 +163,7 @@ function getUserName()
call getUserName_C(getUserName_Cstring,stat) call getUserName_C(getUserName_Cstring,stat)
if(stat == 0) then if (stat == 0) then
getUserName = c_f_string(getUserName_Cstring) getUserName = c_f_string(getUserName_Cstring)
else else
getUserName = 'n/a (Error!)' getUserName = 'n/a (Error!)'