diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index a87046c5a..e048751b3 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -3,6 +3,7 @@ !> @author Yi-Chin Yang, Max-Planck-Institut für Eisenforschung GmbH !> @author Jennifer Nastola, Max-Planck-Institut für Eisenforschung GmbH !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Michigan State University !-------------------------------------------------------------------------------------------------- module HDF5_utilities use HDF5 @@ -17,6 +18,7 @@ module HDF5_utilities use prec use parallelization + use misc #if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY) implicit none(type,external) @@ -26,7 +28,7 @@ module HDF5_utilities private !-------------------------------------------------------------------------------------------------- -!> @brief reads integer or float data of defined shape from file +!> @brief Read integer or float data of defined shape from file. !> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- interface HDF5_read @@ -48,7 +50,7 @@ module HDF5_utilities end interface HDF5_read !-------------------------------------------------------------------------------------------------- -!> @brief writes integer or real data of defined shape to file +!> @brief Write integer or real data of defined shape to file. !> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- interface HDF5_write @@ -74,7 +76,7 @@ module HDF5_utilities end interface HDF5_write !-------------------------------------------------------------------------------------------------- -!> @brief attached attributes of type char, integer or real to a file/dataset/group +!> @brief Attach attribute of type char, integer, or real to a file/dataset/group. !-------------------------------------------------------------------------------------------------- interface HDF5_addAttribute module procedure HDF5_addAttribute_str @@ -110,7 +112,7 @@ contains !-------------------------------------------------------------------------------------------------- -!> @brief initialize HDF5 libary and do sanity checks +!> @brief Initialize HDF5 libary and perform sanity checks. !-------------------------------------------------------------------------------------------------- subroutine HDF5_utilities_init @@ -176,31 +178,22 @@ integer(HID_T) function HDF5_openFile(fileName,mode,parallel) integer :: hdferr - if (present(mode)) then - m = mode - else - m = 'r' - end if + m = misc_optional(mode,'r') call H5Pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) if (hdferr < 0) error stop 'HDF5 error' #ifdef PETSC - if (present(parallel)) then + if (misc_optional(parallel,.true.)) & #if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY) - if (parallel) call H5Pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL_F90, hdferr) - else call H5Pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL_F90, hdferr) #else - if (parallel) call H5Pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) - else - 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 - end if if (hdferr < 0) error stop 'HDF5 error' #endif - if (m == 'w') then + if (m == 'w') then call H5Fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) if (hdferr < 0) error stop 'HDF5 error' elseif (m == 'a') then @@ -220,7 +213,7 @@ end function HDF5_openFile !-------------------------------------------------------------------------------------------------- -!> @brief close the opened HDF5 output file +!> @brief Close an open HDF5 file. !-------------------------------------------------------------------------------------------------- subroutine HDF5_closeFile(fileHandle) @@ -235,7 +228,7 @@ end subroutine HDF5_closeFile !-------------------------------------------------------------------------------------------------- -!> @brief adds a new group to the fileHandle +!> @brief Add a new group to the file. !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_addGroup(fileHandle,groupName) @@ -268,7 +261,7 @@ end function HDF5_addGroup !-------------------------------------------------------------------------------------------------- -!> @brief open an existing group of a file +!> @brief Open an existing group in a file. !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_openGroup(fileHandle,groupName) @@ -304,7 +297,7 @@ end function HDF5_openGroup !-------------------------------------------------------------------------------------------------- -!> @brief close a group +!> @brief Close a group. !-------------------------------------------------------------------------------------------------- subroutine HDF5_closeGroup(group_id) @@ -330,11 +323,7 @@ logical function HDF5_objectExists(loc_id,path) character(len=:), allocatable :: p - if (present(path)) then - p = trim(path) - else - p = '.' - end if + p = trim(misc_optional(path,'.')) call H5Lexists_f(loc_id, p, HDF5_objectExists, hdferr) if (hdferr < 0) error stop 'HDF5 error' @@ -364,11 +353,7 @@ subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path) type(C_PTR), target, dimension(1) :: ptr - if (present(path)) then - p = trim(path) - else - p = '.' - end if + p = trim(misc_optional(path,'.')) attrValue_(1) = trim(attrValue)//C_NULL_CHAR ptr(1) = c_loc(attrValue_(1)) @@ -376,14 +361,14 @@ subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path) call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) 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,p,attrLabel,attrExists,hdferr) if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then - call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + call H5Adelete_by_name_f(loc_id,p,attrLabel,hdferr) if (hdferr < 0) error stop 'HDF5 error' 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,p,trim(attrLabel),H5T_STRING,space_id,attr_id,hdferr) 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 if (hdferr < 0) error stop 'HDF5 error' @@ -412,23 +397,19 @@ subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path) character(len=:), allocatable :: p - if (present(path)) then - p = trim(path) - else - p = '.' - end if + p = trim(misc_optional(path,'.')) call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) 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,p,attrLabel,attrExists,hdferr) if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then - call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + call H5Adelete_by_name_f(loc_id,p,attrLabel,hdferr) if (hdferr < 0) error stop 'HDF5 error' 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,p,trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) if (hdferr < 0) error stop 'HDF5 error' call H5Awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, int([1],HSIZE_T), hdferr) if (hdferr < 0) error stop 'HDF5 error' @@ -457,23 +438,19 @@ subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path) character(len=:), allocatable :: p - if (present(path)) then - p = trim(path) - else - p = '.' - end if + p = trim(misc_optional(path,'.')) call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) 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,p,attrLabel,attrExists,hdferr) if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then - call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + call H5Adelete_by_name_f(loc_id,p,attrLabel,hdferr) if (hdferr < 0) error stop 'HDF5 error' 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,p,trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) if (hdferr < 0) error stop 'HDF5 error' call H5Awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, int([1],HSIZE_T), hdferr) if (hdferr < 0) error stop 'HDF5 error' @@ -504,11 +481,7 @@ subroutine HDF5_addAttribute_str_array(loc_id,attrLabel,attrValue,path) type(C_PTR), target, dimension(size(attrValue)) :: ptr - if (present(path)) then - p = trim(path) - else - p = '.' - end if + p = trim(misc_optional(path,'.')) do i=1,size(attrValue) attrValue_(i) = attrValue(i)//C_NULL_CHAR @@ -518,14 +491,14 @@ subroutine HDF5_addAttribute_str_array(loc_id,attrLabel,attrValue,path) 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' - call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + call H5Aexists_by_name_f(loc_id,p,attrLabel,attrExists,hdferr) if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then - call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + call H5Adelete_by_name_f(loc_id,p,attrLabel,hdferr) if (hdferr < 0) error stop 'HDF5 error' 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,p,trim(attrLabel),H5T_STRING,space_id,attr_id,hdferr) 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 if (hdferr < 0) error stop 'HDF5 error' @@ -555,25 +528,21 @@ subroutine HDF5_addAttribute_int_array(loc_id,attrLabel,attrValue,path) character(len=:), allocatable :: p - if (present(path)) then - p = trim(path) - else - p = '.' - end if + p = trim(misc_optional(path,'.')) array_size = size(attrValue,kind=HSIZE_T) call H5Screate_simple_f(1, array_size, space_id, hdferr, array_size) 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,p,attrLabel,attrExists,hdferr) if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then - call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + call H5Adelete_by_name_f(loc_id,p,attrLabel,hdferr) if (hdferr < 0) error stop 'HDF5 error' 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,p,trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) if (hdferr < 0) error stop 'HDF5 error' call H5Awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, array_size, hdferr) if (hdferr < 0) error stop 'HDF5 error' @@ -603,25 +572,21 @@ subroutine HDF5_addAttribute_real_array(loc_id,attrLabel,attrValue,path) character(len=:), allocatable :: p - if (present(path)) then - p = trim(path) - else - p = '.' - end if + p = trim(misc_optional(path,'.')) array_size = size(attrValue,kind=HSIZE_T) call H5Screate_simple_f(1, array_size, space_id, hdferr, array_size) 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,p,attrLabel,attrExists,hdferr) if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then - call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + call H5Adelete_by_name_f(loc_id,p,attrLabel,hdferr) if (hdferr < 0) error stop 'HDF5 error' 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,p,trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) if (hdferr < 0) error stop 'HDF5 error' call H5Awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, array_size, hdferr) if (hdferr < 0) error stop 'HDF5 error' @@ -676,13 +641,10 @@ subroutine HDF5_read_real1(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id, aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& @@ -713,13 +675,10 @@ subroutine HDF5_read_real2(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& @@ -750,13 +709,10 @@ subroutine HDF5_read_real3(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& @@ -788,13 +744,10 @@ subroutine HDF5_read_real4(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& @@ -826,13 +779,10 @@ subroutine HDF5_read_real5(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& @@ -864,14 +814,11 @@ subroutine HDF5_read_real6(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if - if (any(totalShape == 0)) return + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + +if (any(totalShape == 0)) return 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) @@ -902,13 +849,10 @@ subroutine HDF5_read_real7(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& @@ -940,14 +884,11 @@ subroutine HDF5_read_int1(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if - if (any(totalShape == 0)) return + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + +if (any(totalShape == 0)) return 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) @@ -978,13 +919,10 @@ subroutine HDF5_read_int2(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& @@ -1015,13 +953,10 @@ subroutine HDF5_read_int3(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& @@ -1052,13 +987,10 @@ subroutine HDF5_read_int4(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& @@ -1089,13 +1021,10 @@ subroutine HDF5_read_int5(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& @@ -1127,13 +1056,10 @@ subroutine HDF5_read_int6(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& @@ -1165,13 +1091,10 @@ subroutine HDF5_read_int7(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel_default) - end if + call initialize_read(dset_id,filespace_id,memspace_id,plist_id,aplist_id, & + myStart,totalShape,loc_id,myShape,datasetName, & + misc_optional(parallel,parallel_default)) + if (any(totalShape == 0)) return call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& @@ -1207,13 +1130,9 @@ subroutine HDF5_write_real1(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1248,13 +1167,9 @@ subroutine HDF5_write_real2(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1289,13 +1204,9 @@ subroutine HDF5_write_real3(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1330,13 +1241,9 @@ subroutine HDF5_write_real4(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1372,13 +1279,9 @@ subroutine HDF5_write_real5(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1413,13 +1316,9 @@ subroutine HDF5_write_real6(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1454,13 +1353,9 @@ subroutine HDF5_write_real7(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1497,13 +1392,9 @@ subroutine HDF5_write_real(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then select rank(dataset) @@ -1624,13 +1515,9 @@ subroutine HDF5_write_int1(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_INTEGER, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1665,13 +1552,9 @@ subroutine HDF5_write_int2(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_INTEGER, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1706,13 +1589,9 @@ subroutine HDF5_write_int3(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_INTEGER, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1747,13 +1626,9 @@ subroutine HDF5_write_int4(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_INTEGER, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1788,18 +1663,14 @@ subroutine HDF5_write_int5(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_INTEGER, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then 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) - if (hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1829,13 +1700,9 @@ subroutine HDF5_write_int6(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_INTEGER, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1870,13 +1737,9 @@ subroutine HDF5_write_int7(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_INTEGER, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& @@ -1913,13 +1776,9 @@ subroutine HDF5_write_int(dataset,loc_id,datasetName,parallel) myShape = int(shape(dataset),HSIZE_T) if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel_default) - end if + call initialize_write(dset_id,filespace_id,memspace_id,plist_id, & + myStart,totalShape,loc_id,myShape,datasetName,H5T_NATIVE_INTEGER, & + misc_optional(parallel,parallel_default)) if (product(totalShape) /= 0) then select rank(dataset) diff --git a/src/Marc/DAMASK_Marc.f90 b/src/Marc/DAMASK_Marc.f90 index b987d1b83..92b89c334 100644 --- a/src/Marc/DAMASK_Marc.f90 +++ b/src/Marc/DAMASK_Marc.f90 @@ -142,6 +142,7 @@ end function solverIsSymmetric end module DAMASK_interface #include "../parallelization.f90" +#include "../misc.f90" #include "../constants.f90" #include "../IO.f90" #include "../YAML_types.f90" diff --git a/src/YAML_parse.f90 b/src/YAML_parse.f90 index 65bac4029..f344dc6bd 100644 --- a/src/YAML_parse.f90 +++ b/src/YAML_parse.f90 @@ -1,11 +1,12 @@ !---------------------------------------------------------------------------------------------------- !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @author Sharan Roongta, Max-Planck-Institut für Eisenforschung GmbH -!> @brief Parser for YAML files -!> @details module converts a YAML input file to an equivalent YAML flow style which is then parsed. +!> @brief Parser for YAML files. +!> @details Module converts a YAML input file to an equivalent YAML flow style which is then parsed. !---------------------------------------------------------------------------------------------------- module YAML_parse use prec + use misc use IO use YAML_types #ifdef FYAML @@ -54,7 +55,7 @@ end subroutine YAML_parse_init !-------------------------------------------------------------------------------------------------- -!> @brief Parse a YAML string with list as root into a a structure of nodes. +!> @brief Parse a YAML string with list at root into a structure of nodes. !> @details The string needs to end with a newline (unless using libfyaml). !-------------------------------------------------------------------------------------------------- function YAML_parse_str_asList(str) result(list) @@ -72,7 +73,7 @@ end function YAML_parse_str_asList !-------------------------------------------------------------------------------------------------- -!> @brief Parse a YAML string with dict as root into a a structure of nodes. +!> @brief Parse a YAML string with dict at root into a structure of nodes. !> @details The string needs to end with a newline (unless using libfyaml). !-------------------------------------------------------------------------------------------------- function YAML_parse_str_asDict(str) result(dict) @@ -90,8 +91,8 @@ end function YAML_parse_str_asDict !-------------------------------------------------------------------------------------------------- -!> @brief reads the flow style string and stores it in the form of dictionaries, lists and scalars. -!> @details A node type pointer can either point to a dictionary, list or scalar type entities. +!> @brief Read a string in flow style and store it in the form of dictionaries, lists, and scalars. +!> @details A node-type pointer can either point to a dictionary, list, or scalar type entities. !-------------------------------------------------------------------------------------------------- recursive function parse_flow(YAML_flow) result(node) @@ -157,7 +158,7 @@ end function parse_flow !-------------------------------------------------------------------------------------------------- -!> @brief finds location of chunk end: ',' or '}' or ']' +!> @brief Find location of chunk end: ',' '}', or ']'. !> @details leaves nested lists ( '[...]' and dicts '{...}') intact !-------------------------------------------------------------------------------------------------- integer function find_end(str,e_char) @@ -187,7 +188,7 @@ end function find_end !-------------------------------------------------------------------------------------------------- -! @brief check whether a string is enclosed with single or double quotes +! @brief Check whether a string is enclosed with single or double quotes. !-------------------------------------------------------------------------------------------------- logical function quotedString(line) @@ -208,7 +209,7 @@ end function quotedString #ifdef FYAML !-------------------------------------------------------------------------------------------------- -! @brief Convert all block style YAML parts to flow style. +! @brief Convert all block-style YAML parts to flow style. !-------------------------------------------------------------------------------------------------- function to_flow(mixed) result(flow) @@ -236,41 +237,43 @@ end function to_flow #else !-------------------------------------------------------------------------------------------------- -! @brief Determine Indentation. -! @details It determines the indentation level for a given block/line. -! In cases for nested lists, an offset is added to determine the indent of the item block (skip -! leading dashes) +! @brief Determine indentation depth. +! @details Indentation level is determined for a given block/line. +! In case of nested lists, an offset is added to determine the indent of the item block (skip +! leading dashes). !-------------------------------------------------------------------------------------------------- integer function indentDepth(line,offset) character(len=*), intent(in) :: line integer, optional,intent(in) :: offset - indentDepth = verify(line,IO_WHITESPACE) -1 - if (present(offset)) indentDepth = indentDepth + offset + + indentDepth = verify(line,IO_WHITESPACE) - 1 + misc_optional(offset,0) end function indentDepth !-------------------------------------------------------------------------------------------------- -! @brief check whether a string is in flow style, i.e. starts with '{' or '[' +! @brief Check whether a string is in flow style, i.e. starts with '{' or '['. !-------------------------------------------------------------------------------------------------- logical function isFlow(line) character(len=*), intent(in) :: line + isFlow = index(adjustl(line),'[') == 1 .or. index(adjustl(line),'{') == 1 end function isFlow !-------------------------------------------------------------------------------------------------- -! @brief check whether a string is a scalar item, i.e. starts without any special symbols +! @brief Check whether a string is a scalar item, i.e. starts without any special symbols. !-------------------------------------------------------------------------------------------------- logical function isScalar(line) character(len=*), intent(in) :: line + isScalar = (.not. isKeyValue(line) .and. & .not. isKey(line) .and. & .not. isListItem(line) .and. & @@ -280,12 +283,13 @@ end function isScalar !-------------------------------------------------------------------------------------------------- -! @brief check whether a string is a list item, i.e. starts with '-' +! @brief Check whether a string is a list item, i.e. starts with '-'. !-------------------------------------------------------------------------------------------------- logical function isListItem(line) character(len=*), intent(in) :: line + isListItem = .false. if (len_trim(adjustl(line))> 2 .and. index(trim(adjustl(line)), '-') == 1) then isListItem = scan(trim(adjustl(line)),' ') == 2 @@ -297,13 +301,14 @@ end function isListItem !-------------------------------------------------------------------------------------------------- -! @brief check whether a string contains a key value pair of the for ': ' +! @brief Check whether a string contains a key-value pair of the form ': '. !-------------------------------------------------------------------------------------------------- logical function isKeyValue(line) character(len=*), intent(in) :: line isKeyValue = .false. + if ( .not. isKey(line) .and. index(IO_rmComment(line),':') > 0 .and. .not. isFlow(line)) then if (index(IO_rmComment(line),': ') > 0) isKeyValue = .true. end if @@ -312,13 +317,14 @@ end function isKeyValue !-------------------------------------------------------------------------------------------------- -! @brief check whether a string contains a key without a value, i.e. it ends with ':' -! ToDo: check whether this is safe for trailing spaces followed by a new line character +! @brief Check whether a string contains a key without a value, i.e. it ends in ':'. +! ToDo: check whether this is safe for trailing spaces followed by a newline character !-------------------------------------------------------------------------------------------------- logical function isKey(line) character(len=*), intent(in) :: line + if (len(IO_rmComment(line)) == 0) then isKey = .false. else @@ -331,20 +337,21 @@ end function isKey !-------------------------------------------------------------------------------------------------- -! @brief check whether a string is a list in flow style +! @brief Check whether a string is a list in flow style. !-------------------------------------------------------------------------------------------------- logical function isFlowList(line) character(len=*), intent(in) :: line + isFlowList = index(adjustl(line),'[') == 1 end function isFlowList !-------------------------------------------------------------------------------------------------- -! @brief skip empty lines -! @details update start position in the block by skipping empty lines if present. +! @brief Skip empty lines. +! @details Update start position in the block by skipping empty lines if present. !-------------------------------------------------------------------------------------------------- subroutine skip_empty_lines(blck,s_blck) @@ -353,6 +360,7 @@ subroutine skip_empty_lines(blck,s_blck) logical :: empty + empty = .true. 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 @@ -363,8 +371,8 @@ end subroutine skip_empty_lines !-------------------------------------------------------------------------------------------------- -! @brief skip file header -! @details update start position in the block by skipping file header if present. +! @brief Skip file header. +! @details Update start position in the block by skipping file header if present. !-------------------------------------------------------------------------------------------------- subroutine skip_file_header(blck,s_blck) @@ -373,6 +381,7 @@ subroutine skip_file_header(blck,s_blck) character(len=:), allocatable :: line + line = IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2)) if (index(adjustl(line),'%YAML') == 1) then s_blck = s_blck + index(blck(s_blck:),IO_EOL) @@ -388,7 +397,7 @@ end subroutine skip_file_header !-------------------------------------------------------------------------------------------------- -!> @brief check if a line in flow YAML starts and ends in the same line +!> @brief Check whether a line in flow style starts and ends on the same line. !-------------------------------------------------------------------------------------------------- logical function flow_is_closed(str,e_char) @@ -399,6 +408,7 @@ logical function flow_is_closed(str,e_char) i character(len=:), allocatable:: line + flow_is_closed = .false. N_sq = 0 N_cu = 0 @@ -417,7 +427,7 @@ end function flow_is_closed !-------------------------------------------------------------------------------------------------- -!> @brief return the flow YAML line without line break +!> @brief Return a flow-style line without line break. !-------------------------------------------------------------------------------------------------- subroutine remove_line_break(blck,s_blck,e_char,flow_line) @@ -427,6 +437,7 @@ subroutine remove_line_break(blck,s_blck,e_char,flow_line) character(len=:), allocatable, intent(out) :: flow_line logical :: line_end + line_end =.false. flow_line = '' @@ -440,7 +451,7 @@ end subroutine remove_line_break !-------------------------------------------------------------------------------------------------- -!> @brief return the scalar list item without line break +!> @brief Return a scalar list item without line break. !-------------------------------------------------------------------------------------------------- subroutine list_item_inline(blck,s_blck,inline,offset) @@ -452,6 +463,7 @@ subroutine list_item_inline(blck,s_blck,inline,offset) character(len=:), allocatable :: line integer :: indent,indent_next + indent = indentDepth(blck(s_blck:),offset) line = IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2)) inline = line(indent-offset+3:) @@ -471,8 +483,8 @@ end subroutine list_item_inline !-------------------------------------------------------------------------------------------------- -! @brief reads a line of YAML block which is already in flow style -! @details A dict should be enclosed within '{}' for it to be consistent with the DAMASK YAML parser +! @brief Read a line of YAML block that is already in flow style. +! @details A dict should be enclosed within '{}' for it to be consistent with the DAMASK YAML parser. !-------------------------------------------------------------------------------------------------- recursive subroutine line_isFlow(flow,s_flow,line) @@ -485,6 +497,7 @@ recursive subroutine line_isFlow(flow,s_flow,line) list_chunk, & dict_chunk + if (index(adjustl(line),'[') == 1) then s = index(line,'[') flow(s_flow:s_flow) = '[' @@ -535,8 +548,8 @@ end subroutine line_isFlow !------------------------------------------------------------------------------------------------- -! @brief reads a line of YAML block of type : and places it in the YAML flow style structure -! @details Makes sure that the is consistent with the input required in DAMASK YAML parser +! @brief Transform a line of YAML of type : to flow style. +! @details Ensures that the is consistent with the input required in the DAMASK YAML parser. !------------------------------------------------------------------------------------------------- recursive subroutine keyValue_toFlow(flow,s_flow,line) @@ -550,6 +563,7 @@ recursive subroutine keyValue_toFlow(flow,s_flow,line) col_pos, & offset_value + col_pos = index(line,':') if (line(col_pos+1:col_pos+1) /= ' ') call IO_error(704,ext_msg=line) if (isFlow(line(col_pos+1:))) then @@ -567,7 +581,7 @@ end subroutine keyValue_toFlow !------------------------------------------------------------------------------------------------- -! @brief reads a line of YAML block and places it in the YAML flow style structure +! @brief Transform a line of YAML to flow style. !------------------------------------------------------------------------------------------------- subroutine line_toFlow(flow,s_flow,line) @@ -586,7 +600,7 @@ end subroutine line_toFlow !------------------------------------------------------------------------------------------------- -! @brief convert a yaml list in block style to a yaml list in flow style +! @brief Transform a block-style list to flow style. ! @details enters the function when encountered with the list indicator '- ' ! reads each scalar list item and separates each other with a ',' ! If list item is non scalar, it stores the offset for that list item block @@ -679,7 +693,7 @@ end subroutine lst !-------------------------------------------------------------------------------------------------- -! @brief convert a yaml dict in block style to a yaml dict in flow style +! @brief Transform a block-style dict to flow style. ! @details enters the function when encountered with the dictionary indicator ':' ! parses each line in the block and compares indentation of a line with the preceding line ! upon increase in indentation level -> 'decide' function decides if the line is a list or dict @@ -817,7 +831,7 @@ end subroutine decide !-------------------------------------------------------------------------------------------------- -!> @brief Convert all block style YAML parts to flow style. +!> @brief Convert all block-style parts to flow style. !> @details The input needs to end with a newline. !-------------------------------------------------------------------------------------------------- function to_flow(blck) diff --git a/src/lattice.f90 b/src/lattice.f90 index beded840b..4e288e96d 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -8,6 +8,7 @@ !-------------------------------------------------------------------------------------------------- module lattice use prec + use misc use IO use config use math @@ -2159,12 +2160,8 @@ pure function lattice_isotropic_nu(C,assumption,lattice) result(nu) real(pReal) :: K, mu logical :: error real(pReal), dimension(6,6) :: S - character(len=:), allocatable :: lattice_ - lattice_ = IO_WHITESPACE - if (present(lattice)) lattice_ = lattice - if (IO_lc(assumption) == 'isostrain') then K = sum(C(1:3,1:3)) / 9.0_pReal elseif (IO_lc(assumption) == 'isostress') then @@ -2175,7 +2172,7 @@ pure function lattice_isotropic_nu(C,assumption,lattice) result(nu) error stop 'invalid assumption' end if - mu = lattice_isotropic_mu(C,assumption,lattice_) + mu = lattice_isotropic_mu(C,assumption,misc_optional(lattice,'')) nu = (1.5_pReal*K-mu)/(3.0_pReal*K+mu) end function lattice_isotropic_nu @@ -2195,14 +2192,10 @@ pure function lattice_isotropic_mu(C,assumption,lattice) result(mu) logical :: error real(pReal), dimension(6,6) :: S - character(len=:), allocatable :: lattice_ - lattice_ = IO_WHITESPACE - if (present(lattice)) lattice_ = lattice - if (IO_lc(assumption) == 'isostrain') then - select case(lattice_) + select case(misc_optional(lattice,'')) case('cF','cI') mu = ( C(1,1) - C(1,2) + C(4,4)*3.0_pReal) / 5.0_pReal case default @@ -2213,7 +2206,7 @@ pure function lattice_isotropic_mu(C,assumption,lattice) result(mu) end select elseif (IO_lc(assumption) == 'isostress') then - select case(lattice_) + select case(misc_optional(lattice,'')) case('cF','cI') mu = 5.0_pReal & / (4.0_pReal/(C(1,1)-C(1,2)) + 3.0_pReal/C(4,4)) diff --git a/src/math.f90 b/src/math.f90 index ff0c604b3..032129f31 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -7,6 +7,7 @@ !-------------------------------------------------------------------------------------------------- module math use prec + use misc use IO use config use YAML_types @@ -140,23 +141,9 @@ pure recursive subroutine math_sort(a, istart, iend, sortDim) integer :: ipivot,s,e,d - if (present(istart)) then - s = istart - else - s = lbound(a,2) - end if - - if (present(iend)) then - e = iend - else - e = ubound(a,2) - end if - - if (present(sortDim)) then - d = sortDim - else - d = 1 - end if + s = misc_optional(istart,lbound(a,2)) + e = misc_optional(iend,ubound(a,2)) + d = misc_optional(sortDim,1) if (s < e) then call qsort_partition(a,ipivot, s,e, d) @@ -448,20 +435,14 @@ pure function math_exp33(A,n) real(pReal), dimension(3,3) :: B, math_exp33 real(pReal) :: invFac - integer :: n_,i + integer :: i - if (present(n)) then - n_ = n - else - n_ = 5 - end if - invFac = 1.0_pReal ! 0! B = math_I3 math_exp33 = math_I3 ! A^0 = I - do i = 1, n_ + do i = 1, misc_optional(n,5) invFac = invFac/real(i,pReal) ! invfac = 1/(i!) B = matmul(B,A) math_exp33 = math_exp33 + invFac*B ! exp = SUM (A^i)/(i!) @@ -729,12 +710,7 @@ pure function math_sym33to6(m33,weighted) real(pReal), dimension(6) :: w integer :: i - - if (present(weighted)) then - w = merge(NRMMANDEL,1.0_pReal,weighted) - else - w = NRMMANDEL - end if + w = merge(NRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) math_sym33to6 = [(w(i)*m33(MAPNYE(1,i),MAPNYE(2,i)),i=1,6)] @@ -757,11 +733,7 @@ pure function math_6toSym33(v6,weighted) integer :: i - if (present(weighted)) then - w = merge(INVNRMMANDEL,1.0_pReal,weighted) - else - w = INVNRMMANDEL - end if + w = merge(INVNRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) do i=1,6 math_6toSym33(MAPNYE(1,i),MAPNYE(2,i)) = w(i)*v6(i) @@ -831,11 +803,7 @@ pure function math_sym3333to66(m3333,weighted) integer :: i,j - if (present(weighted)) then - w = merge(NRMMANDEL,1.0_pReal,weighted) - else - w = NRMMANDEL - end if + w = merge(NRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) #ifndef __INTEL_COMPILER do concurrent(i=1:6, j=1:6) @@ -864,11 +832,7 @@ pure function math_66toSym3333(m66,weighted) integer :: i,j - if (present(weighted)) then - w = merge(INVNRMMANDEL,1.0_pReal,weighted) - else - w = INVNRMMANDEL - end if + w = merge(INVNRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) do i=1,6; do j=1,6 math_66toSym3333(MAPNYE(1,i),MAPNYE(2,i),MAPNYE(1,j),MAPNYE(2,j)) = w(i)*w(j)*m66(i,j) @@ -996,24 +960,12 @@ impure elemental subroutine math_normal(x,mu,sigma) real(pReal), intent(out) :: x real(pReal), intent(in), optional :: mu, sigma - real(pReal) :: sigma_, mu_ real(pReal), dimension(2) :: rnd - if (present(mu)) then - mu_ = mu - else - mu_ = 0.0_pReal - end if - - if (present(sigma)) then - sigma_ = sigma - else - sigma_ = 1.0_pReal - end if - call random_number(rnd) - x = mu_ + sigma_ * sqrt(-2.0_pReal*log(1.0_pReal-rnd(1)))*cos(TAU*(1.0_pReal - rnd(2))) + x = misc_optional(mu,0.0_pReal) & + + misc_optional(sigma,1.0_pReal) * sqrt(-2.0_pReal*log(1.0_pReal-rnd(1)))*cos(TAU*(1.0_pReal - rnd(2))) end subroutine math_normal diff --git a/src/misc.f90 b/src/misc.f90 new file mode 100644 index 000000000..388d78ce1 --- /dev/null +++ b/src/misc.f90 @@ -0,0 +1,100 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, KU Leuven +!> @author Philip Eisenlohr, Michigan State University +!> @brief Miscellaneous tools. +!-------------------------------------------------------------------------------------------------- +module misc + use prec + + implicit none(type,external) + private + + interface misc_optional + module procedure misc_optional_bool + module procedure misc_optional_integer + module procedure misc_optional_real + module procedure misc_optional_string + end interface misc_optional + + public :: & + misc_optional + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief Return bool value if given, otherwise default. +!-------------------------------------------------------------------------------------------------- +pure function misc_optional_bool(given,default) result(var) + + logical, intent(in), optional :: given + logical, intent(in) :: default + logical :: var + + + if (present(given)) then + var = given + else + var = default + end if + +end function misc_optional_bool + + +!-------------------------------------------------------------------------------------------------- +!> @brief Return integer value if given, otherwise default. +!-------------------------------------------------------------------------------------------------- +pure function misc_optional_integer(given,default) result(var) + + integer, intent(in), optional :: given + integer, intent(in) :: default + integer :: var + + + if (present(given)) then + var = given + else + var = default + end if + +end function misc_optional_integer + + +!-------------------------------------------------------------------------------------------------- +!> @brief Return real value if given, otherwise default. +!-------------------------------------------------------------------------------------------------- +pure function misc_optional_real(given,default) result(var) + + real(pReal), intent(in), optional :: given + real(pReal), intent(in) :: default + real(pReal) :: var + + + if (present(given)) then + var = given + else + var = default + end if + +end function misc_optional_real + + +!-------------------------------------------------------------------------------------------------- +!> @brief Return string value if given, otherwise default. +!-------------------------------------------------------------------------------------------------- +pure function misc_optional_string(given,default) result(var) + + character(len=*), intent(in), optional :: given + character(len=*), intent(in) :: default + character(len=:), allocatable :: var + + + if (present(given)) then + var = given + else + var = default + end if + +end function misc_optional_string + +end module misc diff --git a/src/result.f90 b/src/result.f90 index 02b1557b5..14f897ec2 100644 --- a/src/result.f90 +++ b/src/result.f90 @@ -6,6 +6,7 @@ !-------------------------------------------------------------------------------------------------- module result use prec + use misc use parallelization use IO use HDF5_utilities @@ -224,11 +225,7 @@ subroutine result_addAttribute_str(attrLabel,attrValue,path) character(len=*), intent(in), optional :: path - if (present(path)) then - call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) - else - call HDF5_addAttribute(resultFile,attrLabel, attrValue) - end if + call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) end subroutine result_addAttribute_str @@ -243,11 +240,7 @@ subroutine result_addAttribute_int(attrLabel,attrValue,path) character(len=*), intent(in), optional :: path - if (present(path)) then - call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) - else - call HDF5_addAttribute(resultFile,attrLabel, attrValue) - end if + call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) end subroutine result_addAttribute_int @@ -262,11 +255,7 @@ subroutine result_addAttribute_real(attrLabel,attrValue,path) character(len=*), intent(in), optional :: path - if (present(path)) then - call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) - else - call HDF5_addAttribute(resultFile,attrLabel, attrValue) - end if + call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) end subroutine result_addAttribute_real @@ -281,11 +270,7 @@ subroutine result_addAttribute_str_array(attrLabel,attrValue,path) character(len=*), intent(in), optional :: path - if (present(path)) then - call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) - else - call HDF5_addAttribute(resultFile,attrLabel, attrValue) - end if + call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) end subroutine result_addAttribute_str_array @@ -300,11 +285,7 @@ subroutine result_addAttribute_int_array(attrLabel,attrValue,path) character(len=*), intent(in), optional :: path - if (present(path)) then - call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) - else - call HDF5_addAttribute(resultFile,attrLabel, attrValue) - end if + call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) end subroutine result_addAttribute_int_array @@ -319,11 +300,7 @@ subroutine result_addAttribute_real_array(attrLabel,attrValue,path) character(len=*), intent(in), optional :: path - if (present(path)) then - call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) - else - call HDF5_addAttribute(resultFile,attrLabel, attrValue) - end if + call HDF5_addAttribute(resultFile,attrLabel, attrValue, path) end subroutine result_addAttribute_real_array @@ -416,19 +393,12 @@ subroutine result_writeTensorDataset_real(dataset,group,label,description,SIunit real(pReal), intent(in), dimension(:,:,:) :: dataset integer :: i - logical :: transposed_ integer(HID_T) :: groupHandle real(pReal), dimension(:,:,:), allocatable :: dataset_transposed - if (present(transposed)) then - transposed_ = transposed - else - transposed_ = .true. - end if - groupHandle = result_openGroup(group) - if (transposed_) then + if (misc_optional(transposed,.true.)) then if (size(dataset,1) /= size(dataset,2)) error stop 'transpose non-symmetric tensor' allocate(dataset_transposed,mold=dataset) do i=1,size(dataset_transposed,3) diff --git a/src/rotations.f90 b/src/rotations.f90 index 657480ef4..baa7a49dd 100644 --- a/src/rotations.f90 +++ b/src/rotations.f90 @@ -178,11 +178,7 @@ subroutine fromEulers(self,eu,degrees) real(pReal), dimension(3) :: Eulers - if (.not. present(degrees)) then - Eulers = eu - else - Eulers = merge(eu*INRAD,eu,degrees) - end if + Eulers = merge(eu*INRAD,eu,misc_optional(degrees,.false.)) if (any(Eulers<0.0_pReal) .or. any(Eulers>TAU) .or. Eulers(2) > PI) & call IO_error(402,ext_msg='fromEulers') @@ -202,18 +198,10 @@ subroutine fromAxisAngle(self,ax,degrees,P) real(pReal),dimension(3) :: axis - if (.not. present(degrees)) then - angle = ax(4) - else - angle = merge(ax(4)*INRAD,ax(4),degrees) - end if + angle = merge(ax(4)*INRAD,ax(4),misc_optional(degrees,.false.)) - if (.not. present(P)) then - axis = ax(1:3) - else - 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)') - end if + axis = ax(1:3) * merge(-1.0_pReal,1.0_pReal,misc_optional(P,-1) == 1) + if (abs(misc_optional(P,-1)) /= 1) call IO_error(402,ext_msg='fromAxisAngle (P)') if (dNeq(norm2(axis),1.0_pReal) .or. angle < 0.0_pReal .or. angle > PI) & call IO_error(402,ext_msg='fromAxisAngle') @@ -277,22 +265,15 @@ pure function rotVector(self,v,active) result(vRot) logical, intent(in), optional :: active real(pReal), dimension(4) :: v_normed, q - logical :: passive - if (present(active)) then - passive = .not. active - else - passive = .true. - end if - if (dEq0(norm2(v))) then vRot = v else v_normed = [0.0_pReal,v]/norm2(v) - q = merge(multiplyQuaternion(self%q, multiplyQuaternion(v_normed, conjugateQuaternion(self%q))), & - multiplyQuaternion(conjugateQuaternion(self%q), multiplyQuaternion(v_normed, self%q)), & - passive) + q = merge(multiplyQuaternion(conjugateQuaternion(self%q), multiplyQuaternion(v_normed, self%q)), & + multiplyQuaternion(self%q, multiplyQuaternion(v_normed, conjugateQuaternion(self%q))), & + misc_optional(active,.false.)) vRot = q(2:4)*norm2(v) end if @@ -311,18 +292,10 @@ pure function rotTensor2(self,T,active) result(tRot) real(pReal), intent(in), dimension(3,3) :: T logical, intent(in), optional :: active - logical :: passive - - if (present(active)) then - passive = .not. active - else - passive = .true. - end if - - tRot = merge(matmul(matmul(self%asMatrix(),T),transpose(self%asMatrix())), & - matmul(matmul(transpose(self%asMatrix()),T),self%asMatrix()), & - passive) + tRot = merge(matmul(matmul(transpose(self%asMatrix()),T),self%asMatrix()), & + matmul(matmul(self%asMatrix(),T),transpose(self%asMatrix())), & + misc_optional(active,.false.)) end function rotTensor2 @@ -342,12 +315,7 @@ pure function rotTensor4(self,T,active) result(tRot) real(pReal), dimension(3,3) :: R integer :: i,j,k,l,m,n,o,p - - if (present(active)) then - R = merge(transpose(self%asMatrix()),self%asMatrix(),active) - else - R = self%asMatrix() - end if + R = merge(transpose(self%asMatrix()),self%asMatrix(),misc_optional(active,.false.)) tRot = 0.0_pReal do i = 1,3;do j = 1,3;do k = 1,3;do l = 1,3 @@ -375,11 +343,7 @@ pure function rotStiffness(self,C,active) result(cRot) real(pReal), dimension(6,6) :: M - if (present(active)) then - R = merge(transpose(self%asMatrix()),self%asMatrix(),active) - else - R = self%asMatrix() - end if + R = merge(transpose(self%asMatrix()),self%asMatrix(),misc_optional(active,.false.)) M = reshape([R(1,1)**2, R(2,1)**2, R(3,1)**2, & R(2,1)*R(3,1), R(1,1)*R(3,1), R(1,1)*R(2,1), &