#if defined HAVE_CONFIG_H # include "config.h" #endif #define THIS_FILE "fdf.F90" !===================================================================== ! ! This file is part of the FDF package. ! ! This module implements an extended Fortran 90/95 interface ! to the Flexible Data Format library of A. Garcia and J.M. Soler, ! originally written in Fortran 77. ! ! FEATURES: ! ! a) Block pointers. ! ! Block content can be flexibly handled by means of a pointer ! to a derived type 'block_fdf'. Typical usage: ! ! use fdf ! type(block_fdf) :: bfdf ! type(parsed_line), pointer :: pline ! ! if (fdf_block('SomeBlock', bfdf)) then ! do while(fdf_bline(bfdf, pline)) ! (process line 'integers|reals|values|names ...') ! enddo ! call fdf_bclose(bfdf) ! endif ! ! The subroutine 'fdf_block' returns in 'bfdf' a structure used ! to read the contents of the block. ! ! Routine fdf_bline returns in 'pline' the next non-blank parsed ! line, non-comment line from the block, unless there are no more ! lines, in which case it returns .FALSE. and 'pline' is undefined. ! ! Routine fdf_bclose runs the remaining lines in the block and ensures ! the log may be used as input in subsequent entries. ! ! Routine 'backspace' moves the internal pointer of 'block_fdf' ! structure to the previous line returned. ! ! Routine 'rewind' moves the internal pointer of 'block_fdf' structure ! to the beginning of the block. ! ! b) Generic interface to scalar routines. ! ! The generic function 'fdf_get' can be used instead of any of the ! scalar routines. The specific names are also accepted. ! ! c) Architecture support: this FDF implementation supports the following ! architectures environments. ! ! 1) Thread-safe: The new implementation is thread-safe and will support ! calling it from several OMP-threads executing in the same node. ! ! The implementation is as follows: fdf_init and fdf_shutdown are ! SINGLE/CRITICAL sections that only one thread must execute. ! On the other hand 'get'/'test' routines in FDF library are ! thread-safe because each thread keeps its relative information ! about the search/query that the caller program requests. ! ! Alberto Garcia, 1996-2007 ! Raul de la Cruz (BSC), September 2007 ! ! !======================================================================== MODULE fdf USE fdf_io USE fdf_parse, only: parsed_line USE fdf_parse, only: nintegers, nreals USE fdf_parse, only: nvalues, nnames, ntokens USE fdf_parse, only: integers, reals USE fdf_parse, only: values, names, tokens, characters USE fdf_parse, only: match USE fdf_parse, only: digest, blocks, endblocks, labels USE fdf_parse, only: destroy, setdebug, setlog, setmorphol USE fdf_parse, only: nlists, nintegerlists, nreallists USE fdf_parse, only: integerlists, reallists, valuelists USE fdf_parse, only: search USE fdf_parse, only: fdf_bsearch => search USE fdf_parse, only: fdf_substring_search => substring_search USE fdf_parse, only: serialize_pline, recreate_pline USE fdf_parse, only: SERIALIZED_LENGTH USE fdf_utils USE fdf_prec USE fdf_legacy_units_m, only: fdf_legacy_unit_handler => inquire_unit implicit none interface subroutine inquire_unit_p(unit_str, stat, phys_dim, unit_name, unit_value) import :: dp character(len=*), intent(in) :: unit_str character(len=*), intent(out) :: phys_dim character(len=*), intent(out) :: unit_name real(dp), intent(out) :: unit_value integer, intent(out) :: stat end subroutine inquire_unit_p end interface procedure(inquire_unit_p), pointer :: inquire_unit => null() ! User callable routines in FDF library ! Start, stop FDF system public :: fdf_init, fdf_shutdown ! Reading label functions public :: fdf_get public :: fdf_integer, fdf_single, fdf_double public :: fdf_string, fdf_boolean public :: fdf_physical ! Lists public :: fdf_islist, fdf_islinteger, fdf_islreal public :: fdf_list, fdf_linteger, fdf_ldouble ! Returns the string associated with a mark line public :: fdf_getline ! Test if label is defined public :: fdf_defined, fdf_isphysical, fdf_isblock ! Allow to overwrite things in the FDF public :: fdf_overwrite, fdf_removelabel, fdf_addline ! Test if a label is used in obsolete or a deprecated state public :: fdf_deprecated, fdf_obsolete ! %block reading (processing each line) public :: fdf_block, fdf_block_linecount public :: fdf_bline, fdf_bbackspace, fdf_brewind, fdf_bclose public :: fdf_bnintegers, fdf_bnreals, fdf_bnvalues, fdf_bnnames, fdf_bntokens public :: fdf_bintegers, fdf_breals, fdf_bvalues, fdf_bnames, fdf_btokens public :: fdf_bboolean, fdf_bphysical public :: fdf_bnlists, fdf_bnilists, fdf_bnrlists, fdf_bnvlists public :: fdf_bilists, fdf_brlists, fdf_bvlists ! Match, search over blocks, and destroy block structure public :: fdf_bmatch, fdf_bsearch, fdf_substring_search public :: fdf_setoutput, fdf_setdebug ! Units handling ! The legacy name fdf_convfac is still exported, but ! it is only useful after having set the ! unit conversion function public :: fdf_convfac public :: fdf_legacy_unit_handler public :: fdf_set_unit_handler public :: fdf_get_unit_handler ! Private functions, non-callable ! Main functions to build FDF structure (called in fdf_init) private :: fdf_initdata, fdf_addtoken, fdf_readline private :: fdf_read, fdf_readlabel, fdf_searchlabel private :: fdf_open, fdf_close ! Input/Output configuration private :: fdf_input ! private :: fdf_set_output_file ! Destroy dynamic list of FDF structure (called in fdf_shutdown) private :: fdf_destroy, fdf_destroy_dl ! Debugging functions, level and prints debugging info public :: fdf_printfdf ! Finds a label in the FDF herarchy private :: fdf_locate ! Dump function (for blocks) private :: fdf_dump ! Wrappers functions for block access, search, matching, ! number and elements in the block (call to parse module) interface fdf_bnintegers module procedure nintegers end interface interface fdf_bnlists module procedure nlists end interface interface fdf_bnilists module procedure nintegerlists end interface interface fdf_bnrlists module procedure nreallists end interface interface fdf_bnvlists module procedure nlists end interface interface fdf_bnreals module procedure nreals end interface interface fdf_bnvalues module procedure nvalues end interface interface fdf_bnnames module procedure nnames end interface interface fdf_bntokens module procedure ntokens end interface interface fdf_bintegers module procedure integers end interface interface fdf_bilists module procedure integerlists end interface interface fdf_brlists module procedure reallists end interface interface fdf_bvlists module procedure valuelists end interface interface fdf_breals module procedure reals end interface interface fdf_bvalues module procedure values end interface interface fdf_bnames module procedure names end interface interface fdf_btokens module procedure tokens end interface interface fdf_bmatch module procedure match end interface ! fdf_get wrapper for label functions interface fdf_get module procedure fdf_integer module procedure fdf_single module procedure fdf_double module procedure fdf_boolean module procedure fdf_string module procedure fdf_physical end interface ! fdf_list wrapper for integer/real list functions interface fdf_list module procedure fdf_linteger module procedure fdf_ldouble end interface ! Unit numbers for input, output, error notification, and ! debugging output (the latter active if fdf_debug is true) logical, private :: fdf_debug = .FALSE., & fdf_debug2 = .FALSE., & fdf_started = .FALSE., & fdf_output = .FALSE. integer(ip), parameter, private :: maxdepth = 7 integer(ip), parameter, private :: maxFileNameLength = 300 integer(ip), private :: ndepth integer(ip), private :: fdf_in(maxdepth) integer(ip), private :: fdf_out, fdf_err, fdf_log ! Structure for searching inside fdf blocks type, public :: block_fdf character(len=MAX_LENGTH) :: label type(line_dlist), pointer :: mark => null() end type block_fdf ! Dynamic list for parsed_line structures type, public :: line_dlist character(len=MAX_LENGTH) :: str type(parsed_line), pointer :: pline => null() ! type(line_dlist), pointer :: next => null() type(line_dlist), pointer :: prev => null() end type line_dlist ! FDF data structure (first and last lines) type, private :: fdf_file integer(ip) :: nlines type(line_dlist), pointer :: first => null() type(line_dlist), pointer :: last => null() end type fdf_file ! Input FDF file type(fdf_file), private :: file_in ! Export the following to enable serialization by clients of the library public :: fdf_serialize_struct public :: fdf_recreate_struct public :: fdf_set_started ! Define by default all the others inherit module entities as privated ! avoiding redefinitions of entities in several module files with same name public :: parsed_line ! Structure for searching inside fdf blocks public :: leqi ! For legacy support (old codes) private CONTAINS ! ! Initialization for fdf. ! SUBROUTINE fdf_init( fileInput, fileOutput, unitInput ) implicit none !------------------------------------------------------------- Input Variables character(len=*),optional,intent(in):: fileInput, fileOutput integer, optional,intent(in):: unitInput #ifndef FDF_DEBUG !------------------------------------------------------------- Local Variables integer(ip) :: debug_level, output_level #endif character(len=256) :: filedebug character(len=maxFileNameLength):: filein, fileout !----------------------------------------------------------------------- BEGIN !$OMP SINGLE ! Prevent the user from opening two head files if (fdf_started) then call die('FDF module: fdf_init', 'Head file already set', & THIS_FILE, __LINE__, fdf_err) endif call fdf_initdata() call io_geterr(fdf_err) ! Set in/out file names, if fileInput and fileOutput are not present call set_file_names( filein, fileout, & fileInput, fileOutput, unitInput ) filedebug = trim(fileout) // ".debug" call fdf_input(filein) fdf_started = .TRUE. ! Set the legacy unit handler by default ! Client codes should make sure that they use an updated units table and handler call fdf_set_unit_handler(fdf_legacy_unit_handler) ! Flags within the fdf file itself. ! At this point only the final fdf data structure will be shown, ! for level >= 2 debug_level = fdf_get('fdf-debug', 0) call fdf_setdebug(debug_level,filedebug) ! The default is to have output only in the master node output_level = fdf_get('fdf-output', 1) call fdf_setoutput(output_level,fileout) if (debug_level >= 2) call fdf_printfdf() !$OMP END SINGLE RETURN !------------------------------------------------------------------------- END END SUBROUTINE fdf_init SUBROUTINE set_file_names( fileIn, fileOut, & optFileIn, optFileOut, unitIn ) ! If present, copies input arguments optFileIn/Out to fileIn/Out. ! If absent, generates In/Out file names. If unitIn is present, and it is ! a named file, returns it as fileIn. If not, it copies input to a new ! file and returns its name. If .not.present(unitIn) => unitIn=5. ! If optFileIn is present, unitIn is ignored. implicit none character(len=*),intent(out):: & fileIn, &! Name of file to be used as input fileOut ! Name of file to be used as output character(len=*),optional,intent(in):: & optFileIn, &! Optional argument with input file name optFileOut ! Optional argument with output file name integer,optional,intent(in):: & unitIn ! Optional input file unit (not used if present(optFileIn)) integer:: count, ierr, iostat, iu, iuIn logical:: named, opened character(len=MAX_LENGTH*2) line character(len=maxFileNameLength) fileName !------------------------------------------------------------------------- BEGIN ! Find a job-specific number call system_clock( count ) count = mod(count,100000) ! Set output file name if (present(optFileOut)) then if (len(trim(optFileOut)) > len(fileOut)) & call die('FDF module: set_file_names', & 'Parameter maxFileNameLength too small.' // & 'Terminating.', THIS_FILE, __LINE__, fdf_err, rc=ierr) fileOut = optFileOut else ! set a job-specific file name write(fileOut,'(a,i5.5,a)') 'fdf_',count,'.log' endif ! Set input file if (present(optFileIn)) then ! just copy the file name if (len(trim(optFileIn)) > len(fileIn)) & call die('FDF module: set_file_names', & 'Parameter maxFileNameLength too small.' // & 'Terminating.', THIS_FILE, __LINE__, fdf_err, rc=ierr) fileIn = optFileIn else ! find or set a file name ! Find input file unit if (present(unitIn)) then ! use given unit (possibly 5) iuIn = unitIn else ! assume standard input iuIn = 5 endif ! Find file name associated with given unit if (iuIn==5) then ! no valid file name fileName = ' ' else ! check if this is a named file inquire(unit=iuIn,opened=opened) if (opened) then inquire(unit=iuIn,named=named) if (named) then ! inquire file name inquire(unit=iuIn,name=fileName) else ! no valid file name fileName = ' ' endif ! (named) else call die('FDF module: set_file_names', 'Input unit not opened.' // & 'Terminating.', THIS_FILE, __LINE__, fdf_err, rc=ierr) endif ! (opened) endif ! (iuIn==5) ! Set input file name, possibly after copying input to it if (fileName==' ') then ! not a valid file write(fileIn,'(a,i5.5,a)') & 'INPUT_TMP_',count,'.fdf' ! new file's name call io_assign(iu) ! new file's unit open(iu,file=trim(fileIn),form='formatted') ! open new file do read(iuIn,iostat=iostat,fmt='(a)') line ! read line from old unit if (iostat/=0 ) exit write(iu,'(a)') trim(line) ! write line to new file enddo call io_close(iu) ! close new file else ! valid file fileIn = fileName endif ! (fileName=='stdin') endif ! (present(optFileIn)) !--------------------------------------------------------------------------- END END SUBROUTINE set_file_names ! ! Reads the input file ! SUBROUTINE fdf_input(filein) implicit none !--------------------------------------------------------------- Input Variables character(*) :: filein !------------------------------------------------------------------------- BEGIN call fdf_read(filein) if (fdf_output) write(fdf_out,'(a,a,a,i3)') '#FDF module: Opened ', filein, & ' for input. Unit:', fdf_in(1) RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_input ! Read an input file (and include files) and builds memory ! structure that will contain the data and will help in searching ! RECURSIVE SUBROUTINE fdf_read(filein, blocklabel) implicit none !--------------------------------------------------------------- Input Variables character(*) :: filein character(*), optional :: blocklabel !--------------------------------------------------------------- Local Variables logical :: dump logical, allocatable :: found(:) character(80) :: msg character(len=MAX_LENGTH) :: label, inc_file character(len=MAX_LENGTH*2):: line integer(ip) :: i, ierr, ntok, ind_less, nlstart type(parsed_line), pointer :: pline !------------------------------------------------------------------------- BEGIN ! Open reading input file call fdf_open(filein) ! Read each input data line if (PRESENT(blocklabel)) then label = blocklabel else label = ' ' endif do while (fdf_readline(line)) ! Check if valid data (tokens, non-blank) pline => digest(line) ntok = ntokens(pline) if (ntok .ne. 0) then ! Find different special cases in the input files ! (%block, %endblock, %include, Label1 Label2 ... < Filename) ! %block directive ind_less = search('<', pline) if (search('%block', pline) .eq. 1) then ! No label found in %block directive if (ntok .eq. 1) then write(msg,*) '%block label not found in ', TRIM(filein) call die('FDF module: fdf_read', msg, & THIS_FILE, __LINE__, fdf_err) endif ! %block Label < Filename [ %dump ] if (ind_less .eq. 3) then if (ntok .ge. 4) then ! Test if %dump is present if (search('%dump', pline) .eq. 5) then dump = .TRUE. else dump = .FALSE. endif ! Add begin, body and end sections of block label = tokens(pline, 2) inc_file = tokens(pline, 4) call destroy(pline) line = '%block ' // label pline => digest(line) call setmorphol(1, 'b', pline) call setmorphol(2, 'l', pline) call fdf_addtoken(line, pline) nullify(pline) ! it is stored in line nlstart = file_in%nlines call fdf_read(inc_file, label) ! Warn if block 'label' is empty if ((nlstart - file_in%nlines) .eq. 0) then write(msg,*) 'FDF module: fdf_read: block ', & TRIM(label), ' is empty...' call warn(msg) endif line = '%endblock ' // label pline => digest(line) call setmorphol(1, 'e', pline) call setmorphol(2, 'l', pline) call fdf_addtoken(line, pline) nullify(pline) ! it is stored in line ! Dump included file to fileout if (dump) call fdf_dump(label) label = ' ' ! Filename not found in %block directive else write(msg,*) '%block filename not found in ', TRIM(filein) call die('FDF module: fdf_read', msg, & THIS_FILE, __LINE__, fdf_err) endif ! %block Label elseif (ind_less .eq. -1) then label = tokens(pline, 2) call setmorphol(1, 'b', pline) call setmorphol(2, 'l', pline) call fdf_addtoken(line, pline) nullify(pline) ! it is stored in line nlstart = file_in%nlines ! Bad format in %block directive else write(msg,*) 'Bad ''<'' %block format in ', TRIM(filein) call die('FDF module: fdf_read', msg, & THIS_FILE, __LINE__, fdf_err) endif ! %endblock directive elseif (search('%endblock', pline) .eq. 1) then ! Check if %block exists before %endblock if (label .eq. ' ') then write(msg,*) 'Bad %endblock found in ', TRIM(filein) call die('FDF module: fdf_read', msg, & THIS_FILE, __LINE__, fdf_err) else ! Warn if block 'label' is empty if ((nlstart - file_in%nlines) .eq. 0) then write(msg,*) 'FDF module: fdf_read: block ', & TRIM(label), ' is empty...' call warn(msg) endif call destroy(pline) line = '%endblock ' // label pline => digest(line) call setmorphol(1, 'e', pline) call setmorphol(2, 'l', pline) call fdf_addtoken(line, pline) nullify(pline) ! it is stored in line label = ' ' endif ! %include Filename directive elseif (search('%include', pline) .eq. 1) then ! Check if include filename is specified if (ntok .eq. 1) then write(msg,*) 'Filename on %include not found in ', TRIM(filein) call die('FDF module: fdf_read', msg, & THIS_FILE, __LINE__, fdf_err) else inc_file = tokens(pline, 2) call fdf_read(inc_file) endif ! Clean pline (we simply insert the next file) call destroy(pline) ! Label1 Label2 ... < Filename directive elseif (ind_less .ne. -1) then ! Check if '<' is in a valid position if (ind_less .eq. 1) then write(msg,*) 'Bad ''<'' found in ', TRIM(filein) call die('FDF module: fdf_read', msg, & THIS_FILE, __LINE__, fdf_err) ! Check if '<' filename is specified elseif (ind_less .eq. ntok) then write(msg,*) 'Filename not found after ''<'' in ', TRIM(filein) call die('FDF module: fdf_read', msg, & THIS_FILE, __LINE__, fdf_err) else ! Search label(s) in Filename inc_file = tokens(pline, ind_less+1) ALLOCATE(found(ind_less-1), stat=ierr) if (ierr .ne. 0) then call die('FDF module: fdf_read', 'Error allocating found', & THIS_FILE, __LINE__, fdf_err, rc=ierr) endif ! If label(s) not found in such Filename throw an error found = .FALSE. if (.not. fdf_readlabel(ind_less-1, pline, & inc_file, found)) then i = 1 do while ((i .le. ind_less-1) .and. (found(i))) i = i + 1 enddo label = tokens(pline, i) write(msg,*) 'Label ', TRIM(label), & ' not found in ', TRIM(inc_file) call die('FDF module: fdf_read', msg, & THIS_FILE, __LINE__, fdf_err) endif call destroy(pline) DEALLOCATE(found) endif ! Add remaining kind of tokens to dynamic list as labels else if (label .eq. ' ') call setmorphol(1, 'l', pline) call fdf_addtoken(line, pline) nullify(pline) ! it is stored in line endif else ! Destroy parsed_line structure if no elements call destroy(pline) endif enddo ! Close one level of input file if ((.not. PRESENT(blocklabel)) .and. (label .ne. ' ')) then write(msg,*) '%endblock ', TRIM(label), & ' not found in ', TRIM(filein) call die('FDF module: fdf_read', msg, THIS_FILE, __LINE__, fdf_err) endif call fdf_close() RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_read ! ! Read an input file (and include files) searching labels to ! include them in memory structure that will contain the data ! RECURSIVE FUNCTION fdf_readlabel(nelem, plabel, filein, found) result(readlabel) implicit none !--------------------------------------------------------------- Input Variables character(*) :: filein integer(ip) :: nelem type(parsed_line), pointer :: plabel !-------------------------------------------------------------- Output Variables logical :: readlabel logical :: found(nelem) !--------------------------------------------------------------- Local Variables logical :: dump, found_elem logical, pointer :: found_loc(:) character(80) :: msg character(len=MAX_LENGTH*2):: line character(len=MAX_LENGTH) :: label, inc_file integer(ip) :: i, ierr, ntok, ind_less, nlstart integer(ip) :: elem, nelem_loc integer(ip), pointer :: found_index(:) type(parsed_line), pointer :: pline !------------------------------------------------------------------------- BEGIN ! Open input file with labels call fdf_open(filein) ! While not reach to end of file and found all labels do while (fdf_readline(line) .and. (.not. ALL(found))) ! Check if valid data (tokens, non-blank) pline => digest(line) ntok = ntokens(pline) if (ntok .ne. 0) then ! Find different special cases in the input files ! (%block, %endblock, %include, Label1 Label2 ... < Filename) ! %block directive ind_less = search('<', pline) if (search('%block', pline) .eq. 1) then ! No label found in %block directive if (ntok .eq. 1) then write(msg,*) '%block label not found in ', TRIM(filein) call die('FDF module: fdf_readlabel', msg, & THIS_FILE, __LINE__, fdf_err) endif ! %block Label < Filename [ %dump ] if (ind_less .eq. 3) then if (ntok .ge. 4) then ! Test if %dump is present if (search('%dump', pline) .eq. 5) then dump = .TRUE. else dump = .FALSE. endif label = tokens(pline, 2) elem = fdf_searchlabel(found, nelem, label, plabel) inc_file = tokens(pline, 4) call destroy(pline) ! If match with any label add [begin, body, end] of block if (elem .ne. -1) then line = '%block ' // label pline => digest(line) call setmorphol(1, 'b', pline) call setmorphol(2, 'l', pline) call fdf_addtoken(line, pline) nlstart = file_in%nlines call fdf_read(inc_file, label) ! Warn if block 'label' is empty if ((nlstart - file_in%nlines) .eq. 0) then write(msg,*) 'FDF module: fdf_readlabel: block ', & TRIM(label), ' is empty...' call warn(msg) endif line = '%endblock ' // label pline => digest(line) call setmorphol(1, 'e', pline) call setmorphol(2, 'l', pline) call fdf_addtoken(line, pline) ! Dump included file to fileout if (dump) call fdf_dump(label) found(elem) = .TRUE. label = ' ' endif ! Filename not found in %block directive else write(msg,*) 'Filename on %block not found in ', TRIM(filein) call die('FDF module: fdf_readlabel', msg, & THIS_FILE, __LINE__, fdf_err) endif ! %block Label elseif (ind_less .eq. -1) then label = tokens(pline, 2) elem = fdf_searchlabel(found, nelem, label, plabel) found_elem = .TRUE. ! If match with any label add [begin,body,end] of block if (elem .ne. -1) then call setmorphol(1, 'b', pline) call setmorphol(2, 'l', pline) call fdf_addtoken(line, pline) nlstart = file_in%nlines found_elem = .FALSE. do while (fdf_readline(line) .and. (.not. found_elem)) pline => digest(line) if (ntokens(pline) .ne. 0) then if (search('%endblock', pline) .eq. 1) then ! Warn if block 'label' is empty if ((nlstart - file_in%nlines) .eq. 0) then write(msg,*) 'FDF module: fdf_readlabel: block ', & TRIM(label), ' is empty...' call warn(msg) endif call destroy(pline) line = '%endblock ' // label pline => digest(line) call setmorphol(1, 'e', pline) call setmorphol(2, 'l', pline) label = ' ' found_elem = .TRUE. found(elem) = .TRUE. endif call fdf_addtoken(line, pline) endif enddo ! Move to the end of the block else call destroy(pline) found_elem = .FALSE. do while (fdf_readline(line) .and. (.not. found_elem)) pline => digest(line) if (search('%endblock', pline) .eq. 1) then label = ' ' found_elem = .TRUE. endif call destroy(pline) enddo endif ! Error due to %endblock not found if (.not. found_elem) then write(msg,*) '%endblock ', TRIM(label), & ' not found in ', TRIM(filein) call die('FDF module: fdf_readlabel', msg, & THIS_FILE, __LINE__, fdf_err) endif ! Bad format in %block directive else write(msg,*) 'Bad ''<'' %block format in ', TRIM(filein) call die('FDF module: fdf_readlabel', msg, & THIS_FILE, __LINE__, fdf_err) endif ! %endblock directive elseif (search('%endblock', pline) .eq. 1) then ! Bad if %endblock exists before %block write(msg,*) 'Bad %endblock found in ', TRIM(filein) call die('FDF module: fdf_readlabel', msg, & THIS_FILE, __LINE__, fdf_err) ! %include Filename directive elseif (search('%include', pline) .eq. 1) then ! Check if include filename is specified if (ntok .eq. 1) then write(msg,*) 'Filename on %include not found in ', TRIM(filein) call die('FDF module: fdf_readlabel', msg, & THIS_FILE, __LINE__, fdf_err) else inc_file = tokens(pline, 2) call destroy(pline) readlabel = fdf_readlabel(nelem, plabel, inc_file, found) endif ! Label1 Label2 ... < Filename directive elseif (ind_less .ne. -1) then ! Check if '<' is in a valid position if (ind_less .eq. 1) then write(msg,*) 'Bad ''<'' found in ', TRIM(filein) call die('FDF module: fdf_readlabel', msg, & THIS_FILE, __LINE__, fdf_err) ! Check if '<' filename is specified elseif (ind_less .eq. ntok) then write(msg,*) 'Filename not found after ''<'' in ', TRIM(filein) call die('FDF module: fdf_readlabel', msg, & THIS_FILE, __LINE__, fdf_err) else ! Search label(s) in Filename line = ' ' nelem_loc = 0 ALLOCATE(found_index(ind_less-1), stat=ierr) if (ierr .ne. 0) then call die('FDF module: fdf_readlabel', 'Error allocating found_index', & THIS_FILE, __LINE__, fdf_err, rc=ierr) endif do i= 1, ind_less-1 label = tokens(pline, i) elem = fdf_searchlabel(found, nelem, label, plabel) if (elem .ne. -1) then line = TRIM(line) // ' ' // TRIM(label) nelem_loc = nelem_loc + 1 found_index(nelem_loc) = elem endif enddo ! Process Filename if any label found if (nelem_loc .ge. 1) then inc_file = tokens(pline, ind_less+1) call destroy(pline) ALLOCATE(found_loc(nelem_loc), stat=ierr) if (ierr .ne. 0) then call die('FDF module: fdf_readlabel', 'Error allocating found_loc', & THIS_FILE, __LINE__, fdf_err, rc=ierr) endif found_loc = .FALSE. ! If label(s) not found in such Filename throw an error pline => digest(line) if (.not. fdf_readlabel(nelem_loc, pline, & inc_file, found_loc)) then i = 1 do while ((i .le. nelem_loc) .and. (found_loc(i))) i = i + 1 enddo label = tokens(pline, i) write(msg,*) 'Label ', TRIM(label), ' not found in ', TRIM(inc_file) call die('FDF module: fdf_readlabel', msg, & THIS_FILE, __LINE__, fdf_err) else ! Merge results if all labels found do i= 1, nelem_loc found(found_index(i)) = found_loc(i) enddo endif DEALLOCATE(found_index) endif DEALLOCATE(found_loc) call destroy(pline) endif ! Label [ Value ] directive else elem = fdf_searchlabel(found, nelem, tokens(pline, 1), plabel) ! If match with any label add it if (elem .ne. -1) then call setmorphol(1, 'l', pline) call fdf_addtoken(line, pline) found(elem) = .TRUE. else ! Destroy parsed_line structure if no label found call destroy(pline) endif endif else ! Destroy parsed_line structure if no label found call destroy(pline) endif enddo ! Close input file with labels call fdf_close() readlabel = ALL(found) RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_readlabel ! ! Search a label in a set of not 'found' tokens given by plabel and nelem. ! Returns the index on plabel of the token that matches with label. ! FUNCTION fdf_searchlabel(found, nelem, label, plabel) implicit none !--------------------------------------------------------------- Input Variables integer(ip) :: nelem logical :: found(nelem) character(*) :: label type(parsed_line), pointer :: plabel !-------------------------------------------------------------- Output Variables integer(ip) :: fdf_searchlabel !--------------------------------------------------------------- Local Variables logical :: found_elem integer(ip) :: i !------------------------------------------------------------------------- BEGIN i = 1 found_elem = .FALSE. fdf_searchlabel = -1 do while ((i .le. nelem) .and. (.not. found_elem)) if (.not. found(i)) then if (labeleq(label, tokens(plabel, i))) then found_elem = .TRUE. fdf_searchlabel = i endif endif i = i + 1 enddo RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_searchlabel ! ! Dumps the content of a block ! SUBROUTINE fdf_dump(label) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label !--------------------------------------------------------------- Local Variables character(80) :: msg type(block_fdf) :: bfdf type(parsed_line), pointer :: pline !------------------------------------------------------------------------- BEGIN fdf_started = .TRUE. if (.not. fdf_block(label, bfdf)) then write(msg,*) 'block ', label, 'to dump not found' call die('FDF module: fdf_dump', msg, THIS_FILE, __LINE__, fdf_err) endif ! fdf_bline prints each block line in fdf_out do while(fdf_bline(bfdf, pline)) enddo fdf_started = .FALSE. RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_dump ! ! Init FDF file structure ! SUBROUTINE fdf_initdata() implicit none !--------------------------------------------------------------- Local Variables integer(ip) :: ierr !------------------------------------------------------------------------- BEGIN ndepth = 0 file_in%nlines = 0 NULLIFY(file_in%first) NULLIFY(file_in%last) RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_initdata ! ! Add a line individually to the dynamic list of parsed lines ! This can not include block's and is restricted to key values ! SUBROUTINE fdf_addline(line) implicit none !--------------------------------------------------------------- Input Variables character(len=*) :: line !--------------------------------------------------------------- Local Variables integer(ip) :: ntok type(parsed_line), pointer :: pline !------------------------------------------------------------------------- BEGIN ! Check if valid data (tokens, non-blank) pline => digest(line) call setmorphol(1, 'l', pline) call fdf_addtoken(line, pline) if (fdf_debug2) then write(fdf_log,*) '***FDF_ADDLINE********************************' write(fdf_log,*) 'Line:', TRIM(line) write(fdf_log,*) '**********************************************' endif END SUBROUTINE fdf_addline ! ! Remove a line from the dynamic list of parsed lines ! This can not include block's and is restricted to key values ! SUBROUTINE fdf_removelabel(label) implicit none !--------------------------------------------------------------- Input Variables character(len=*) :: label !--------------------------------------------------------------- Local Variables type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN do while ( fdf_locate(label,mark) ) if (fdf_debug2) then write(fdf_log,*) '***FDF_REMOVELABEL*******************************' write(fdf_log,*) 'Line:', TRIM(mark%str) write(fdf_log,*) 'Label:', trim(label) write(fdf_log,*) '**********************************************' endif ! To circumvent the first/last line in the fdf-file ! we have to check for the existence of the ! first/last mark being the one removed. ! That special case *must* correct the first/last ! tokens. if ( associated(mark,target=file_in%first) ) then file_in%first => mark%next end if if ( associated(mark,target=file_in%last) ) then file_in%last => mark%prev end if ! Remove the label from the dynamic list call destroy(mark%pline) if ( associated(mark%prev) ) then mark%prev%next => mark%next end if if ( associated(mark%next) ) then mark%next%prev => mark%prev end if DEALLOCATE(mark) NULLIFY(mark) end do END SUBROUTINE fdf_removelabel ! ! Overwrite label line in dynamic list of parsed lines ! SUBROUTINE fdf_overwrite(line) !--------------------------------------------------------------- Input Variables character(len=*) :: line !--------------------------------------------------------------- Local Variables type(parsed_line), pointer :: pline character(len=MAX_LENGTH) :: label integer :: ierr pline => digest(line) if ( search('%block', pline) == 1 .or. & search('%endblock', pline) == 1 ) then ! We do not allow this in a single line call die('FDF module: fdf_overwrite', 'Error overwriting block (not implemented)', & THIS_FILE, __LINE__, fdf_err, rc=ierr) else if ( search('%include', pline) == 1 ) then ! We do not allow this in a single line call die('FDF module: fdf_overwrite', 'Error overwriting flags from input file (not implemented)', & THIS_FILE, __LINE__, fdf_err, rc=ierr) else if ( search('<', pline) /= -1 ) then ! We do not allow this in a single line call die('FDF module: fdf_overwrite', 'Error piping in overwriting (not implemented)', & THIS_FILE, __LINE__, fdf_err, rc=ierr) else label = tokens(pline,1) call setmorphol(1, 'l', pline) call fdf_removelabel(label) ! Add token to the list of fdf-flags ! Since we add it directly we shouldn't destroy the pline call fdf_addtoken(line, pline) if ( fdf_debug ) then write(fdf_log,'(2a)') '---> Overwriting token: ', trim(label) end if end if END SUBROUTINE fdf_overwrite ! ! Add a token to the dynamic list of parsed lines ! SUBROUTINE fdf_addtoken(line, pline) implicit none !--------------------------------------------------------------- Input Variables character(len=*) :: line type(parsed_line), pointer :: pline !--------------------------------------------------------------- Local Variables integer(ip) :: i, ierr type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ALLOCATE(mark, stat=ierr) if (ierr .ne. 0) then call die('FDF module: fdf_addtoken', 'Error allocating mark', & THIS_FILE, __LINE__, fdf_err, rc=ierr) endif mark%str = line mark%pline => pline NULLIFY(mark%next) ! Add entry at the END of structure if (ASSOCIATED(file_in%first)) then mark%prev => file_in%last file_in%last%next => mark else NULLIFY(mark%prev) file_in%first => mark endif file_in%last => mark file_in%nlines = file_in%nlines + 1 if (fdf_debug2) then write(fdf_log,*) '***FDF_ADDTOKEN*******************************' write(fdf_log,*) 'Line:', TRIM(mark%str) write(fdf_log,*) 'Ntokens:', mark%pline%ntokens do i= 1, mark%pline%ntokens write(fdf_log,*) ' Token:', trim(tokens(pline,i)), & ' (', mark%pline%id(i), ')' enddo write(fdf_log,*) '**********************************************' endif RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_addtoken ! ! Opens a file for FDF processing. ! SUBROUTINE fdf_open(filename) implicit none !-------------------------------------------------------------- Output Variables character(*) :: filename !--------------------------------------------------------------- Local Variables logical :: file_exists character(80) :: msg integer(ip) :: lun !------------------------------------------------------------------------- BEGIN ndepth = ndepth + 1 if (ndepth .gt. maxdepth) then call die('FDF module: fdf_open', 'Too many nested fdf files...', & THIS_FILE, __LINE__, fdf_err) endif if (leqi(filename, 'stdin')) then lun = INPUT_UNIT if (fdf_debug) write(fdf_log,'(a,i1,a)') & '---> Reading from standard input [DEPTH:', ndepth,'] ' else call io_assign(lun) INQUIRE(file=filename, exist=file_exists) if (file_exists) then open(unit=lun, file=filename, status='old', form='formatted') REWIND(lun) if (fdf_debug) write(fdf_log,'(a,i1,a,a)') & '---> Opened [DEPTH:', ndepth,'] ', TRIM(filename) else write(msg,'(a,a)') 'Cannot open ', TRIM(filename) call die('FDF module: fdf_open', msg, THIS_FILE, __LINE__, fdf_err) endif endif fdf_in(ndepth) = lun REWIND(fdf_in(ndepth)) RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_open ! ! Closes currently opened fdf file ! SUBROUTINE fdf_close() implicit none !------------------------------------------------------------------------- BEGIN if (ndepth .ge. 1) then call io_close(fdf_in(ndepth)) if (fdf_debug) & write(fdf_log,'(a,i1,a)') '---> Closed [DEPTH:', ndepth,']' ndepth = ndepth - 1 endif RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_close ! ! Set output file for FDF subsystem ! SUBROUTINE fdf_set_output_file(fileout) implicit none !----------------------------------------------------- Input Variables character(len=*), intent(in) :: fileout !----------------------------------------------------- Local Variables character(256) :: fileouttmp !----------------------------------------------------- BEGIN call io_assign(fdf_out) open( unit=fdf_out, file=TRIM(fileout), form='formatted', & access='sequential', status='replace' ) RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_set_output_file ! ! Frees and shutdown FDF system ! SUBROUTINE fdf_shutdown() implicit none !------------------------------------------------------------------------- BEGIN !$OMP SINGLE if (fdf_started) then call fdf_destroy(file_in) fdf_started = .FALSE. call io_close(fdf_out) inquire_unit => null() endif !$OMP END SINGLE RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_shutdown ! ! Destroy the fdf_file structure for the input file ! SUBROUTINE fdf_destroy(fdfp) implicit none !-------------------------------------------------------------- Output Variables type(fdf_file) :: fdfp !------------------------------------------------------------------------- BEGIN if (ASSOCIATED(fdfp%first)) call fdf_destroy_dl(fdfp%first) RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_destroy ! ! Destroy recursively the dynamic list of parsed lines ! RECURSIVE SUBROUTINE fdf_destroy_dl(dlp) implicit none !-------------------------------------------------------------- Output Variables type(line_dlist), pointer :: dlp !! Use for tail recursion later: type(line_dlist), pointer :: pnext !------------------------------------------------------------------------- BEGIN ! This is NOT tail-recursive!! if (ASSOCIATED(dlp%next)) call fdf_destroy_dl(dlp%next) call destroy(dlp%pline) DEALLOCATE(dlp) RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_destroy_dl ! ! Read a line of the 'ndepth' input file, returning .TRUE. if ! there are more lines to read from input file, .FALSE. otherwise. ! FUNCTION fdf_readline(line) implicit none !-------------------------------------------------------------- Output Variables logical :: fdf_readline character(*) :: line !--------------------------------------------------------------- Local Variables integer(ip) :: stat !------------------------------------------------------------------------- BEGIN read(fdf_in(ndepth), '(a)', iostat=stat) line if (stat .eq. 0) then fdf_readline = .TRUE. if (fdf_debug2) write(fdf_log, '(a,a76)') 'fdf_readline > ', line else fdf_readline = .FALSE. endif RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_readline ! ! Returns the string line associated with the mark pointer ! in the FDF herarchy. If mark is not associated returns ''. ! FUNCTION fdf_getline(mark) implicit none !--------------------------------------------------------------- Input Variables type(line_dlist), pointer :: mark !-------------------------------------------------------------- Output Variables character(len=MAX_LENGTH) :: fdf_getline !------------------------------------------------------------------------- BEGIN if (ASSOCIATED(mark)) then fdf_getline = mark%str else fdf_getline = ' ' endif RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_getline ! ! Prints all the fdf_file structure of the input file(s) ! SUBROUTINE fdf_printfdf() implicit none !--------------------------------------------------------------- Local Variables integer(ip) :: i, ntokens character*1 :: id type(line_dlist), pointer :: dlp character(len=MAX_LENGTH) :: tok !------------------------------------------------------------------------- BEGIN dlp => file_in%first write(fdf_log,*) '*** FDF Memory Structure Summary: ************' do while (ASSOCIATED(dlp)) ntokens = dlp%pline%ntokens write(fdf_log,*) 'Line:', TRIM(dlp%str) write(fdf_log,*) 'Ntokens:', ntokens do i= 1, ntokens tok = tokens(dlp%pline,i) id = dlp%pline%id(i) write(fdf_log,*) ' Token:', trim(tok), '(', dlp%pline%id(i), ')' enddo dlp => dlp%next enddo write(fdf_log,*) '**********************************************' RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_printfdf ! ! Returns an integer associated with label 'label', or the default ! value if label is not found in the fdf file. ! Optionally can return a pointer to the line found. ! FUNCTION fdf_integer(label, default, line) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label integer(ip) :: default !-------------------------------------------------------------- Output Variables integer(ip) :: fdf_integer type(line_dlist), pointer, optional :: line !--------------------------------------------------------------- Local Variables character(80) :: msg type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_integer', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then if (.not. match(mark%pline, 'li')) then write(msg,*) 'no integer value for ', label call die('FDF module: fdf_integer', msg, THIS_FILE, __LINE__, fdf_err) endif fdf_integer = integers(mark%pline, 1, 1) if (fdf_output) write(fdf_out,'(a,5x,i10)') label, fdf_integer else fdf_integer = default if (fdf_output) write(fdf_out,'(a,i10,5x,a)') label, default, '# default value' endif if (PRESENT(line)) line = mark RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_integer ! ! Returns true or false whether or not the label 'label' is ! a value with units or not. ! I.e. it returns true if the line has the form lvn, if not found, or not lvn, ! it returns false. ! FUNCTION fdf_isphysical(label) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label !-------------------------------------------------------------- Output Variables logical :: fdf_isphysical !--------------------------------------------------------------- Local Variables type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_isphysical', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then fdf_isphysical = match(mark%pline, 'lvn') else fdf_isphysical = .false. endif if (fdf_output) write(fdf_out,'(a,5x,l10)') "#:physical? " // label, fdf_isphysical RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_isphysical ! ! Returns true or false whether or not the label 'label' is ! a list or not, you cannot get the line out from this routine ! FUNCTION fdf_islist(label) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label !-------------------------------------------------------------- Output Variables logical :: fdf_islist !--------------------------------------------------------------- Local Variables type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_islist', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then ! if it is a list: fdf_islist = match(mark%pline, 'le') else fdf_islist = .false. endif if (fdf_output) write(fdf_out,'(a,5x,l10)') "#:list? " // label, fdf_islist RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_islist FUNCTION fdf_islinteger(label) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label !-------------------------------------------------------------- Output Variables logical :: fdf_islinteger !--------------------------------------------------------------- Local Variables type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_islinteger', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then ! if it is an integer list: fdf_islinteger = match(mark%pline, 'la') else fdf_islinteger = .false. endif if (fdf_output) write(fdf_out,'(a,5x,l10)') "#:linteger? " // label, & fdf_islinteger RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_islinteger FUNCTION fdf_islreal(label) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label !-------------------------------------------------------------- Output Variables logical :: fdf_islreal !--------------------------------------------------------------- Local Variables type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_islreal', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then ! if it is a reallist: fdf_islreal = match(mark%pline, 'lc') else fdf_islreal = .false. endif if (fdf_output) write(fdf_out,'(a,5x,l10)') "#:lreal? " // label, & fdf_islreal RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_islreal ! ! Returns a list with label 'label', or the default ! value if label is not found in the fdf file. ! SUBROUTINE fdf_linteger(label,ni,list,line) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label integer(ip) :: ni !-------------------------------------------------------------- Output Variables integer(ip) :: list(ni) type(line_dlist), pointer, optional :: line !--------------------------------------------------------------- Local Variables character(80) :: msg type(line_dlist), pointer :: mark integer(ip) :: lni, llist(1) !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_linteger', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then if (.not. match(mark%pline, 'la')) then write(msg,*) 'no list value for ', label call die('FDF module: fdf_linteger', msg, THIS_FILE, __LINE__, fdf_err) endif ! Retrieve length of list lni = -1 call integerlists(mark%pline,1,lni,llist) if ( ni <= 0 ) then ! the user has requested size... ni = lni else ! the list is not long enough if ( ni < lni ) then write(msg, '(2a,2(a,i0))')'List ', trim(label), & ' container too small: ', ni, ' versus ', lni call die('FDF module: fdf_linteger', trim(msg), & THIS_FILE, __LINE__, fdf_err) end if call integerlists(mark%pline,1,ni,list) end if ! find a way to write out the list anyway if (fdf_output) write(fdf_out,'(a,5x,i10)') label, lni else write(msg,*) 'no list value for ', label call die('FDF module: fdf_linteger', msg, THIS_FILE, __LINE__, fdf_err) endif if (PRESENT(line)) line = mark RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_linteger ! ! Returns a list with label 'label', or the default ! value if label is not found in the fdf file. ! SUBROUTINE fdf_ldouble(label,nv,list,line) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label integer(ip) :: nv !-------------------------------------------------------------- Output Variables real(dp) :: list(nv) type(line_dlist), pointer, optional :: line !--------------------------------------------------------------- Local Variables character(80) :: msg type(line_dlist), pointer :: mark integer(ip) :: lnv real(dp) :: llist(1) !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_ldouble', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then if (.not. match(mark%pline, 'le')) then write(msg,*) 'no list value for ', label call die('FDF module: fdf_ldouble', msg, THIS_FILE, __LINE__, fdf_err) endif ! Retrieve length of list lnv = -1 call valuelists(mark%pline,1,lnv,llist) if ( nv <= 0 ) then ! the user has requested size... nv = lnv else ! the list is not long enough if ( nv < lnv ) then write(msg, '(2a,2(a,i0))')'List ', trim(label), & ' container too small: ', nv, ' versus ', lnv call die('FDF module: fdf_ldouble', trim(msg), & THIS_FILE, __LINE__, fdf_err) end if call valuelists(mark%pline,1,nv,list) end if if (fdf_output) write(fdf_out,'(a,5x,i10)') label, lnv else write(msg,*) 'no list value for ', label call die('FDF module: fdf_ldouble', msg, THIS_FILE, __LINE__, fdf_err) endif if (PRESENT(line)) line = mark RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_ldouble ! ! Returns a string associated with label 'label', or the default ! string if label is not found in the fdf file. ! Optionally can return a pointer to the line found. ! FUNCTION fdf_string(label, default, line) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label character(*) :: default !-------------------------------------------------------------- Output Variables character(80) :: fdf_string type(line_dlist), pointer, optional :: line !--------------------------------------------------------------- Local Variables type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_string', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then if (ntokens(mark%pline) < 2) then fdf_string = "" if (fdf_output) write(fdf_out,'(a,5x,a)') label, & "# *** Set to empty string *** " else ! Get all the characters spanning the space from the second to ! the last token fdf_string = characters(mark%pline, ind_init=2, ind_final=-1) if (fdf_output) write(fdf_out,'(a,5x,a)') label, fdf_string endif else fdf_string = default if (fdf_output) write(fdf_out,'(a,5x,a,5x,a)') label, default, '# default value' endif if (PRESENT(line)) line = mark RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_string ! ! Returns true if label 'label' appears by itself or in the form ! label {yes,true,.true.,t,y} (case insensitive). ! ! Returns false if label 'label' appears in the form ! label {no,false,.false.,f,n} (case insensitive). ! ! If label is not found in the fdf file, fdf_boolean returns the ! LOGICAL variable default. ! ! Optionally can return a pointer to the line found. ! FUNCTION fdf_boolean(label, default, line) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label logical :: default !-------------------------------------------------------------- Output Variables logical :: fdf_boolean type(line_dlist), pointer, optional :: line !--------------------------------------------------------------- Local Variables character(80) :: msg, valstr type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_boolean', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then ! If the label appears by itself, we interpret it as .true. if (ntokens(mark%pline) .ne. 1) then ! Look for second word valstr = names(mark%pline, 1, 1) if (is_true(valstr)) then fdf_boolean = .TRUE. if (fdf_output) write(fdf_out,'(a,5x,l10)') label, fdf_boolean elseif (is_false(valstr)) then fdf_boolean = .FALSE. if (fdf_output) write(fdf_out,'(a,5x,l10)') label, fdf_boolean else write(msg,*) 'unexpected logical value ', label, ' = ', valstr call die('FDF module: fdf_boolean', msg, & THIS_FILE, __LINE__, fdf_err) endif else fdf_boolean = .TRUE. if (fdf_output) write(fdf_out,'(a,5x,l10,5x,a)') label, fdf_boolean, & '# label by itself' endif else fdf_boolean = default if (fdf_output) write(fdf_out,'(a,5x,l10,5x,a)') label, default, '# default value' endif if (PRESENT(line)) line = mark RETURN CONTAINS logical function is_true(valstr) result(a) character(len=*), intent(in) :: valstr a = leqi(valstr, 'yes') .or. leqi(valstr, 'true') .or. & leqi(valstr, '.true.') .or. leqi(valstr, 't') .or. & leqi(valstr, 'y') end function is_true logical function is_false(valstr) result(a) character(len=*), intent(in) :: valstr a = leqi(valstr, 'no') .or. leqi(valstr, 'false') .or. & leqi(valstr, '.false.') .or. leqi(valstr, 'f') .or. & leqi(valstr, 'n') end function is_false !--------------------------------------------------------------------------- END END FUNCTION fdf_boolean ! Block version of fdf_boolean ! Returns true if the token in position (ind+after) has the form ! {yes,true,.true.,t,y} (case insensitive). ! ! Returns false if the token has the form ! {no,false,.false.,f,n} (case insensitive). ! FUNCTION fdf_bboolean(pline,ind,after) implicit none !--------------------------------------------------------------- Input Variables integer(ip), intent(in) :: ind integer(ip), intent(in), optional :: after type(parsed_line), pointer :: pline !-------------------------------------------------------------- Output Variables logical :: fdf_bboolean !--------------------------------------------------------------- Local Variables character(80) :: msg, valstr !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_bboolean', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (ind <= nnames(pline,after=after)) then valstr = names(pline,ind,after=after) if (is_true(valstr)) then fdf_bboolean = .TRUE. elseif (is_false(valstr)) then fdf_bboolean = .FALSE. else write(msg,*) 'unexpected logical value ', valstr call die('FDF module: fdf_bboolean', msg, & THIS_FILE, __LINE__, fdf_err) endif else write(msg,*) ' index value beyond number of name tokens. ' call die('FDF module: fdf_bboolean:', msg, & THIS_FILE, __LINE__, fdf_err) endif RETURN CONTAINS logical function is_true(valstr) result(a) character(len=*), intent(in) :: valstr a = leqi(valstr, 'yes') .or. leqi(valstr, 'true') .or. & leqi(valstr, '.true.') .or. leqi(valstr, 't') .or. & leqi(valstr, 'y') end function is_true logical function is_false(valstr) result(a) character(len=*), intent(in) :: valstr a = leqi(valstr, 'no') .or. leqi(valstr, 'false') .or. & leqi(valstr, '.false.') .or. leqi(valstr, 'f') .or. & leqi(valstr, 'n') end function is_false !--------------------------------------------------------------------------- END END FUNCTION fdf_bboolean ! ! Returns a single precision value associated with label 'label', ! or the default value if label is not found in the fdf file. ! Optionally can return a pointer to the line found. ! Note that integers on the line are also accepted ! FUNCTION fdf_single(label, default, line) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label real(sp) :: default !-------------------------------------------------------------- Output Variables real(sp) :: fdf_single type(line_dlist), pointer, optional :: line !--------------------------------------------------------------- Local Variables character(80) :: msg type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_single', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then if (.not. match(mark%pline, 'lv')) then write(msg,*) 'no real value for ', label call die('FDF module: fdf_single', msg, THIS_FILE, __LINE__, fdf_err) endif fdf_single = values(mark%pline, 1, 1) if (fdf_output) write(fdf_out,'(a,5x,g20.10)') label, fdf_single else fdf_single = default if (fdf_output) write(fdf_out,'(a,5x,g20.10,5x,a)') label, default, '# default value' endif if (PRESENT(line)) line = mark RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_single ! ! Returns a double precision value associated with label 'label', ! or the default value if label is not found in the fdf file. ! Optionally can return a pointer to the line found. ! Note that integers on the line are also accepted ! FUNCTION fdf_double(label, default, line) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label real(dp) :: default !-------------------------------------------------------------- Output Variables real(dp) :: fdf_double type(line_dlist), pointer, optional :: line !--------------------------------------------------------------- Local Variables character(80) :: msg type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_double', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (fdf_locate(label, mark)) then if (.not. match(mark%pline, 'lv')) then write(msg,*) 'no real value for ', label call die('FDF module: fdf_double', msg, THIS_FILE, __LINE__, fdf_err) endif fdf_double = values(mark%pline, 1, 1) if (fdf_output) write(fdf_out,'(a,5x,g20.10)') label, fdf_double else fdf_double = default if (fdf_output) write(fdf_out,'(a,5x,g20.10,5x,a)') label, default, '# default value' endif if (PRESENT(line)) line = mark RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_double ! ! Returns a double precision value associated with label 'label', ! or the default value if label is not found in the fdf file. ! Converts the units to defunit. ! Optionally can return a pointer to the line found. ! FUNCTION fdf_physical(label, default, defunit, line) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label, defunit real(dp) :: default !-------------------------------------------------------------- Output Variables real(dp) :: fdf_physical type(line_dlist), pointer, optional :: line !--------------------------------------------------------------- Local Variables character(50) :: unitstr character(80) :: msg real(dp) :: value type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_physical', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif ! Label found if (fdf_locate(label, mark)) then if (.not. match(mark%pline, 'lv')) then write(msg,*) 'no real value for ', label call die('FDF module: fdf_physical', msg, THIS_FILE, __LINE__, fdf_err) endif ! Label with value value = values(mark%pline, 1, 1) fdf_physical = value ! Look for unit if (.not. match(mark%pline, 'lvn')) then write(msg,*) 'no unit specified for ', label call die('FDF module: fdf_physical', msg, THIS_FILE, __LINE__, fdf_err) endif unitstr = names(mark%pline, 1, 2) !! if (.not. leqi(unitstr, defunit)) then ! The enclosing 'if' might not be adequate if ! at some point we want to demand case-sensitivity ! or physical dimension qualifiers fdf_physical = value * fdf_convfac(unitstr, defunit) !! endif if (fdf_output) write(fdf_out,'(a,5x,g20.10,1x,a10)') label, fdf_physical, defunit if (fdf_output) write(fdf_out,'(a,a,5x,g20.10,1x,a10)') & '# above item originally: ', label, value, unitstr else fdf_physical = default if (fdf_output) write(fdf_out,'(a,5x,g20.10,1x,a,5x,a)') & label, default, defunit, '# default value' endif if (PRESENT(line)) line = mark RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_physical ! Block version ! Returns a double precision value from a block-line ! (possibly after a certain token index) ! Converts the units to defunit. ! FUNCTION fdf_bphysical(pline, defunit, after) implicit none !--------------------------------------------------------------- Input Variables type(parsed_line), pointer :: pline character(*) :: defunit integer(ip), intent(in), optional :: after !-------------------------------------------------------------- Output Variables real(dp) :: fdf_bphysical !--------------------------------------------------------------- Local Variables character(10) :: unitstr character(80) :: msg real(dp) :: value type(line_dlist), pointer :: mark !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_bphysical', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (.not. match(pline, 'vn', after)) then write(msg,*) 'no vn spec in line: '// trim(pline%line) call die('FDF module: fdf_bphysical', msg, THIS_FILE, & __LINE__, fdf_err) endif ! get value in block-line value = values(pline, 1, after) ! get unit in block-line unitstr = names(pline, 1, after) if ( leqi(unitstr, defunit) ) then fdf_bphysical = value else ! The enclosing 'if' might not be adequate if ! at some point we want to demand case-sensitivity fdf_bphysical = value * fdf_convfac(unitstr, defunit) end if !--------------------------------------------------------------------------- END END FUNCTION fdf_bphysical function fdf_convfac(from, to) result(factor) character(len=*), intent(in) :: from, to real(dp) :: factor integer :: stat character(len=256) :: msg factor = wrapper_convfac(from, to, stat, msg) if (stat /= 0) then call die('FDF module: fdf_convfac', trim(msg), THIS_FILE, __LINE__, fdf_err) endif end function fdf_convfac function wrapper_convfac(from,to,stat,msg) result (factor) use fdf_utils, only: leqi use fdf_prec, only: dp implicit none character(len=*), intent(in) :: from, to integer, intent(out) :: stat character(len=*), intent(out) :: msg real(dp) :: factor character(len=20) :: phys_dim_to, phys_dim_from character(len=20) :: unit_name_to, unit_name_from character(len=40) :: new_from real(dp) :: value_to, value_from if (.not. associated(inquire_unit)) then msg = 'no unit conversion table specified' call die('FDF module: fdf_convfac', msg, THIS_FILE, __LINE__, fdf_err) endif call inquire_unit(to, stat, phys_dim_to, unit_name_to, value_to) if (stat == -1) then msg = 'Unknown unit = ' // trim(to) RETURN else if (stat == 1) then msg = 'Ambiguous unit (please fix the code to specify physical dimension) = ' // trim(to) RETURN endif call inquire_unit(from, stat, phys_dim_from, unit_name_from, value_from) if (stat == -1) then msg = 'Unknown unit = ' // trim(from) RETURN else if (stat == 1) then ! "from" unit is ambiguous. if (len_trim(phys_dim_from) > 0) then msg = 'Unit name ' // trim(from) // & ' is ambiguous, even with qualification.' RETURN else ! Try casting the physical dimension to that of 'to' new_from = trim(phys_dim_to) // ":" // trim(from) call inquire_unit(new_from, stat, phys_dim_from, unit_name_from, value_from) if (stat == -1) then msg = 'Unit name ' // trim(from) // & ' is ambiguous and cast to target (' // trim(new_from) // ') does not exist' RETURN else if (stat == 1) then msg = 'Ambiguous unit even after casting! (case sensitivity needed?) = ' & // trim(new_from) RETURN else ! Do nothing. endif endif else ! Do nothing. endif ! Final checks if (.not. leqi(phys_dim_to, phys_dim_from)) then msg = "Incompatible dimensions: " & // trim(phys_dim_to) // ":" // trim(unit_name_to) // " , " & // trim(phys_dim_from) // ":" // trim(unit_name_from) stat = -1 RETURN endif factor = value_from / value_to END FUNCTION wrapper_convfac ! ! Searches for label in the fdf hierarchy. If it appears the function ! returns .TRUE. and leaves mark pointer positioned at the line. ! Otherwise, it returns .FALSE. and mark points to NULL. ! FUNCTION fdf_locate(label, mark) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label !-------------------------------------------------------------- Output Variables logical :: fdf_locate type(line_dlist), pointer :: mark !--------------------------------------------------------------- Local Variables character(80) :: strlabel !------------------------------------------------------------------------- BEGIN fdf_locate = .FALSE. ! if (fdf_donothing) return mark => file_in%first do while ((.not. fdf_locate) .and. (ASSOCIATED(mark))) if (match(mark%pline, 'l')) then strlabel = labels(mark%pline) if (labeleq(strlabel, label, fdf_log)) then fdf_locate = .TRUE. else mark => mark%next endif else mark => mark%next endif enddo if (.not. fdf_locate) NULLIFY(mark) RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_locate ! ! Returns true or false whether or not the label 'label' is ! a block. ! I.e. it returns true if the line has the form bl, if not found, or not bl ! it returns false. ! FUNCTION fdf_isblock(label) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label !-------------------------------------------------------------- Output Variables logical :: fdf_isblock !--------------------------------------------------------------- Local Variables type(line_dlist), pointer :: mark character(80) :: strlabel !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_isblock', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif fdf_isblock = .false. mark => file_in%first do while ( associated(mark) ) !!$ if ( match(mark%pline, 'l') ) then !!$ strlabel = labels(mark%pline) !!$ !!$ if ( labeleq(strlabel, label, fdf_log) ) then !!$ ! fdf has first-encounter acceptance. !!$ ! I.e. for an input !!$ ! Label_Name 1 !!$ ! %block Label_Name !!$ ! 1 !!$ ! %endblock Label_Name !!$ ! the former will be accepted first. !!$ exit !!$ end if if ( match(mark%pline, 'bl') ) then strlabel = blocks(mark%pline) if ( labeleq(strlabel, label, fdf_log) ) then fdf_isblock = .true. exit end if end if mark => mark%next end do if (fdf_output) write(fdf_out,'(a,5x,l10)') "#:block? " // label, fdf_isblock RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_isblock ! ! Searches for block label in the fdf hierarchy. If it appears returns ! .TRUE. and leaves block mark pointer positioned at the first line. ! Otherwise, it returns .FALSE. and block mark points to NULL. ! FUNCTION fdf_block(label, bfdf) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label !-------------------------------------------------------------- Output Variables logical :: fdf_block type(block_fdf) :: bfdf !--------------------------------------------------------------- Local Variables character(80) :: strlabel !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_block', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif fdf_block = .FALSE. bfdf%mark => file_in%first do while ((.not. fdf_block) .and. (ASSOCIATED(bfdf%mark))) if (match(bfdf%mark%pline, 'bl')) then strlabel = blocks(bfdf%mark%pline) if (labeleq(strlabel, label, fdf_log)) then fdf_block = .TRUE. bfdf%label = label if (fdf_output) write(fdf_out,'(a,a)') '%block ', TRIM(label) endif endif bfdf%mark => bfdf%mark%next enddo if (.not. fdf_block) NULLIFY(bfdf%mark) RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_block ! ! Get successive parsed lines from block returning ! .TRUE. while more lines exist in the block bfdf. ! FUNCTION fdf_bline(bfdf, pline) implicit none !--------------------------------------------------------------- Input Variables type(block_fdf) :: bfdf !-------------------------------------------------------------- Output Variables logical :: fdf_bline type(parsed_line), pointer :: pline !--------------------------------------------------------------- Local Variables character(80) :: strlabel !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_bline', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (.not. ASSOCIATED(bfdf%mark)) then call die('FDF module: fdf_bline', 'block_fdf structure not initialized', & THIS_FILE, __LINE__, fdf_err) endif fdf_bline = .TRUE. ! If we are in the head of the block move to the content if (match(bfdf%mark%pline, 'bl')) then strlabel = blocks(bfdf%mark%pline) if (labeleq(strlabel, bfdf%label, fdf_log)) then bfdf%mark => bfdf%mark%next if (fdf_output) write(fdf_out,'(a,a)') '%block ', TRIM(bfdf%label) endif endif if (match(bfdf%mark%pline, 'el')) then strlabel = endblocks(bfdf%mark%pline) if (labeleq(strlabel, bfdf%label, fdf_log)) then fdf_bline = .FALSE. NULLIFY(pline) if (fdf_output) write(fdf_out,'(a,a)') '%endblock ', TRIM(bfdf%label) endif endif if (fdf_bline) then if (fdf_output) write(fdf_out,'(1x,a)') TRIM(bfdf%mark%str) pline => bfdf%mark%pline bfdf%mark => bfdf%mark%next endif RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_bline ! ! Backspace to the previous physical line in the block ! returning .TRUE. while more lines exist in the block bfdf. ! FUNCTION fdf_bbackspace(bfdf,pline) implicit none !--------------------------------------------------------------- Input Variables type(block_fdf) :: bfdf !-------------------------------------------------------------- Output Variables logical :: fdf_bbackspace type(parsed_line), pointer, optional :: pline !--------------------------------------------------------------- Local Variables character(80) :: strlabel !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_bbackspace', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (.not. ASSOCIATED(bfdf%mark)) then call die('FDF module: fdf_bbackspace', 'block_fdf structure not initialized', & THIS_FILE, __LINE__, fdf_err) endif fdf_bbackspace = .TRUE. ! If we are in the bottom of the block move to the content if (match(bfdf%mark%pline, 'el')) then strlabel = endblocks(bfdf%mark%pline) if (labeleq(strlabel, bfdf%label, fdf_log)) then bfdf%mark => bfdf%mark%prev if (fdf_output) write(fdf_out,'(1x,a)') "#:(Backspace to) " // "|" // & TRIM(bfdf%mark%str) // "|" endif ! If we are at the head we cannot backspace else if (match(bfdf%mark%pline, 'bl')) then strlabel = blocks(bfdf%mark%pline) if (labeleq(strlabel, bfdf%label, fdf_log)) then fdf_bbackspace = .FALSE. if (fdf_output) write(fdf_out,'(1x,a)') "#:(Cannot backspace) " // "|" // & TRIM(bfdf%mark%str) // "|" endif else bfdf%mark => bfdf%mark%prev if (fdf_output) write(fdf_out,'(1x,a)') "#:(Backspace to) " // "|" // & TRIM(bfdf%mark%str) // "|" endif if ( present(pline) ) pline => bfdf%mark%pline RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_bbackspace ! ! Moves the pointer of the working line (bfdf%mark) ! to the beginning of the block 'label' structure. ! SUBROUTINE fdf_brewind(bfdf) implicit none !-------------------------------------------------------------- Output Variables type(block_fdf) :: bfdf !--------------------------------------------------------------- Local Variables character(80) :: msg !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_brewind', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (.not. ASSOCIATED(bfdf%mark)) then call die('FDF module: fdf_brewind', 'block_fdf structure not initialized', & THIS_FILE, __LINE__, fdf_err) endif if (.not. fdf_block(bfdf%label, bfdf)) then write(msg,*) 'Block ', bfdf%label, ' not found in FDF structure' call die('FDF module: fdf_brewind', msg, & THIS_FILE, __LINE__, fdf_err) endif RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_brewind ! ! Closes the opened block by looping the remaining lines of the working line. ! This is only needed to complete the fdf-*.log files output for direct ! usage later. It does nothing internally. ! SUBROUTINE fdf_bclose(bfdf) implicit none !-------------------------------------------------------------- Output Variables type(block_fdf) :: bfdf !--------------------------------------------------------------- Local Variables type(parsed_line), pointer :: pline integer(ip) :: i character(80) :: msg !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_bclose', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif ! Quick return (no need for errors) if ( .not. associated(bfdf%mark) ) return ! This should hopefully discourage compilers to optimize the loop away... i = 0 do while ( fdf_bline(bfdf, pline) ) i = i + fdf_bnvalues(pline) end do write(msg,'(a,i10)') 'Block ', i RETURN !--------------------------------------------------------------------------- END END SUBROUTINE fdf_bclose ! ! Count number of lines with an optional specification. ! I.e. this will read through the block and return the number of lines in the ! block which matches the morphology (morph) ! This may be used to easily digest number of non-empty lines in the block. ! Note that a match on the morphology only compares the number of ID's in ! morph. I.e. a line with 'vvvil' will match 'vvvi'. ! FUNCTION fdf_block_linecount(label, morph) implicit none !--------------------------------------------------------------- Input Variables character(len=*) :: label character(len=*), optional :: morph !-------------------------------------------------------------- Output Variables integer(ip) :: fdf_block_linecount !--------------------------------------------------------------- Local Variables type(block_fdf) :: bfdf type(parsed_line), pointer :: pline logical :: orig_fdf_output !------------------------------------------------------------------------- BEGIN ! Prevents using FDF routines without initialize if (.not. fdf_started) then call die('FDF module: fdf_block_linecount', 'FDF subsystem not initialized', & THIS_FILE, __LINE__, fdf_err) endif ! Store the fdf_output variable (suppress writing to log) orig_fdf_output = fdf_output fdf_output = .false. ! Find the block and search for morhp fdf_block_linecount = 0 if ( fdf_block(label, bfdf) ) then do while ( fdf_bline(bfdf, pline) ) if ( present(morph) ) then if ( fdf_bmatch(pline, morph) ) then fdf_block_linecount = fdf_block_linecount + 1 end if else fdf_block_linecount = fdf_block_linecount + 1 end if end do call fdf_bclose(bfdf) end if ! Restore output fdf_output = orig_fdf_output if ( fdf_output ) then if ( present(morph) ) then write(fdf_out,'(3a,3x,i0)') "#:block-line-count? ", & trim(label), ' ('//trim(morph)//')', fdf_block_linecount else write(fdf_out,'(2a,3x,i0)') "#:block-line-count? ", & trim(label), fdf_block_linecount end if end if RETURN !--------------------------------------------------------------------------- END END FUNCTION fdf_block_linecount ! ! Check if label is defined ! logical FUNCTION fdf_defined(label) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label !--------------------------------------------------------------- Local Variables type(line_dlist), pointer :: mark !--------------------------------------------------------------------- BEGIN ! First, check whether a single label exists: fdf_defined = fdf_locate(label, mark) if (.not. fdf_defined) then ! Check whether there is a block with that label fdf_defined = fdf_isblock(label) endif if ( fdf_output ) then write(fdf_out,'(a,5x,l10)') '#:defined? ' // label, fdf_defined endif RETURN !----------------------------------------------------------------------- END END FUNCTION fdf_defined ! ! Output levels: ! level <= 0: nothing ! level = 1: standard ! SUBROUTINE fdf_setoutput(level,fileout_in) implicit none !------------------------------------------------------------- Input Variables integer(ip) :: level character(len=*), intent(in) :: fileout_in character(len=256) :: fileout fileout = fileout_in if (level .le. 0) then if (fdf_output) then call io_close(fdf_out) fdf_output = .FALSE. endif else if (.not. fdf_output) then call io_assign(fdf_out) open(fdf_out, file=fileout, form='formatted', & status='unknown') REWIND(fdf_out) fdf_output = .TRUE. endif endif !----------------------------------------------------------------------- END END SUBROUTINE fdf_setoutput ! ! Debugging levels: ! level <= 0: nothing ! level = 1: standard ! level >= 2: exhaustive SUBROUTINE fdf_setdebug(level,filedebug) implicit none !------------------------------------------------------------- Input Variables integer(ip) :: level character(len=*) :: filedebug !----------------------------------------------------------------------- BEGIN if (level .le. 0) then if (fdf_debug) then call io_close(fdf_log) fdf_debug = .FALSE. endif else if (.not. fdf_debug) then call io_assign(fdf_log) open(fdf_log, file=filedebug, form='formatted', & status='unknown') REWIND(fdf_log) fdf_debug = .TRUE. ! Set logging/debugging info for PARSE module also call setlog(fdf_log) call setdebug(1) endif endif fdf_debug2 = (level .ge. 2) RETURN !----------------------------------------------------------------------- END END SUBROUTINE fdf_setdebug ! ! For handling deprecated labels. ! Also there is an optional "newlabel" if it has been changed into ! a new label. ! subroutine fdf_deprecated(label,newlabel) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label character(*) :: newlabel !------------------------------------------------------------------------- BEGIN if ( fdf_defined(label) ) then if (fdf_output) write(fdf_out,'(a)') "#**Warning: FDF symbol '"//trim(label)// & "' is deprecated." if ( fdf_defined(newlabel) ) then if (fdf_output) write(fdf_out,'(a)') "# FDF symbol '"//trim(newlabel)// & "' will be used instead." else if (fdf_output) write(fdf_out,'(a)') "# FDF symbol '"//trim(newlabel)// & "' replaces '"//trim(label)//"'." end if end if !--------------------------------------------------------------------------- END end subroutine fdf_deprecated ! ! For handling obsoleted labels. ! subroutine fdf_obsolete(label) implicit none !--------------------------------------------------------------- Input Variables character(*) :: label !------------------------------------------------------------------------- BEGIN if ( fdf_defined(label) ) then if (fdf_output) write(fdf_out,'(a)') "#**Warning: FDF symbol '"//trim(label)// & "' is obsolete." end if !--------------------------------------------------------------------------- END end subroutine fdf_obsolete !===================== Serialization utilities for clients subroutine fdf_serialize_struct(buffer) character(len=1), intent(inout), allocatable :: buffer(:) character(len=SERIALIZED_LENGTH) bufline type(line_dlist), pointer :: mark integer(ip) :: i, length, init, final integer :: nchars ! total size of serialized content if (allocated(buffer)) deallocate(buffer) nchars = file_in%nlines * SERIALIZED_LENGTH allocate(buffer(nchars)) mark => file_in%first do i= 1, file_in%nlines call serialize_pline(mark%pline,bufline,length) init = (i-1)*SERIALIZED_LENGTH+1 final = (i)*SERIALIZED_LENGTH call convert_string_to_array_of_chars(bufline,buffer(init:final)) mark => mark%next enddo end subroutine fdf_serialize_struct subroutine fdf_recreate_struct(bufferFDF) character(len=1), intent(in) :: bufferFDF(:) character(len=SERIALIZED_LENGTH) bufline type(parsed_line), pointer :: pline integer(ip) :: nlines, i, init, final nlines = size(bufferFDF) / SERIALIZED_LENGTH do i= 1, nlines init = (i-1)*SERIALIZED_LENGTH+1 final = (i)*SERIALIZED_LENGTH call convert_array_of_chars_to_string(bufferFDF(init:final),bufline) allocate(pline) call recreate_pline(pline,bufline) call fdf_addtoken(pline%line,pline) enddo end subroutine fdf_recreate_struct ! To enable client-side setting, ! notably in the case of MPI, where non-root ranks ! will not call fdf_init. ! In this case, the unit handler is nullified for ! safety. The client code is responsible for setting ! the right one. ! SUBROUTINE fdf_set_started(status) logical, intent(in) :: status fdf_started = status inquire_unit => null() end SUBROUTINE fdf_set_started ! ! Units processing ! subroutine fdf_set_unit_handler(func) procedure(inquire_unit_p) :: func inquire_unit => func end subroutine fdf_set_unit_handler subroutine fdf_get_unit_handler(func) procedure(inquire_unit_p), pointer :: func func => inquire_unit end subroutine fdf_get_unit_handler END MODULE fdf