Übergeben Sie ein XML-Dateiname-Argument ReadXml ohne Code-Dateien zu ändern

Question

ich diese Zeilen Code in Intel haben Fortran-90 und eine XML-Datei:

Principal.f90:

!--------------------------------------------------------------------------- 
!            `     
! GOAL : Solve, by means of finite elements, the electrostatics 3D 
!   PDE with different boundary conditions and charges 
!                 
!    | -div(permi grad(V))=f       
!   (1) | V = V+ on Dirichlet boundary 
!    | permi d(V)/dn=g 
!                 
!     Dolores Gomez         
!     MC Mu�iz          
!     Jose Luis Ferrin Gonzalez      
!                 
!--------------------------------------------------------------------------- 

program ppalelectros3D 


    use fich_electros3D 
    use electros3D 
    use cargavol 
    use cargacur 
    use cargapun 
    use permitividad 
    use bloqueo 
    use derivados3D   
    use malla_3DP1 
    use external_electros3D 
    use module_writeVTU 
    use comprobaciones 
    use module_convers 
    use module_fem_extract 
    use module_conver3d, only: conver3d 
    use LIB_VTK_IO_READ 
    use module_readUNV 
    use module_compiler_dependant 

    implicit none 
    integer :: i,istat, p, nnod,DIMS,LNN,LNV,LNE,LNF,nnd,nco,npieces,nverteta,iformat 
    integer, allocatable :: nn(:,:) 
    real(real64), allocatable :: evtun(:) 

!--------------------------------------------------------------------------- 
!       INPUT DATA          
!--------------------------------------------------------------------------- 

    if (command_argument_count() == 0) then 
     call endat3D() 
    else 
     call readxml() 
    end if 

! INPUT DATA VERIFICATION, FOR ENDAT & READXML 
    if (.not. comprueba()) then 
     write(error_unit,*) 'Input data check failed' 
     stop 1 
    else 
     write(output_unit,*) 'Input data check passed' 
    endif 

    call calculate_funs() 

! 0.0 IS ASSIGNED TO THE LAST VERTEX IN CASE OF NOT HAVING DIRICHLET CONDITIONS 
    if (blocking_node() < 0) then 
     write(error_unit,*) 'Error assigning blocking node' 
     stop 1 
    endif 

!--------------------------------------------------------------------------- 
!      ELECTROMAGNETIC MESH READING      
!--------------------------------------------------------------------------- 
    call calindc(indc,inda) 

    p = index(fichma, '.', back=.true.) 
    if (p == 0) stop 'Mesh file has not extension: unable to identify mesh format' 
    select case (lcase(fichma(p+1:len_trim(fichma)))) 
    case('mfm') 
    iformat=1 
    call leema3D(iformat) 
    case('mum') 
    iformat=2 
    call leema3D(iformat) 
    case('unv') 
    call readUNV(fichma,nel,nnod,nver,dims,LNN,LNV,LNE,LNF,nn,mm,nrc,nra,nrv,z,nsd) 
    call conver3d(nel, nver, mm, z, nemm, det, binv, ib, jb) 
    case default 
    stop 'Unrecognized mesh file extension' 
    end select 
    call alloc_after_mesh() 

!--------------------------------------------------------------------------- 
!      TEMPERATURE READING      
!--------------------------------------------------------------------------- 
    if (iopteta == 1) call leetmp() 

!--------------------------------------------------------------------------- 
!       COMPUTATIONS         
!--------------------------------------------------------------------------- 
    if (iopblo.eq.1.and.iopblo1.eq.1) then 
     call calprebloqueof(nrd,irefd) 
    endif 
    if (iopblo.eq.1.and.iopblo2.eq.1) then 
     call calprebloqueoc(blofron%numero,blofron%referencias) 
    endif 

    call electrostatica3D() 

    if(allocated(vexac))deallocate(vexac) 
    allocate(vexac(nver),stat=ierror) 
    if (ierror.ne.0) then 
     print*,'Error while allocating array vexac',nver 
     stop 1 
    endif 

    if(allocated(err))deallocate(err) 
    allocate(err(nver),stat=ierror) 
    if (ierror.ne.0) then 
     print*,'Error while allocating array err',nver 
     stop 1 
    endif 

!  call wrtcmp(nver,sol,10,fichsol) 
!  call writeVTU(nel,nver,mm,z,'tetra',sol,'solucion','scalar', & 
!    'node',trim(fichsol)//'.vtu') 

! -1: mixed functions 
! 0: no data 
! 1: User defined/Function defined by user 
! ... 
    if (dir%funs > 1.or.& 
     neu%funs > 1.or.& 
     vol%funs > 1.or.& 
     sup%funs > 1.or.& 
     cur%funs > 1) then 

     do i=1,nver 
     vexac(i) = fexac(z(1,i),z(2,i),z(3,i)) 
     err(i) = dabs(vexac(i)-sol(i)) 
     enddo 

     if (dir%funs == 7) then ! 'Example 6' 
     vexac(376) = sol(376) 
     vexac(193) = sol(193) 
     err(193) = dabs(vexac(193)-sol(193)) 
     err(376) = dabs(vexac(376)-sol(376)) 
     elseif (dir%funs == 6) then ! 'Example 5' 
     vexac(1292) = sol(1292) 
     err(1292) = dabs(vexac(1292)-sol(1292)) 
     endif 

     call norl2_3D(sol,xnorexac) 
     call norl2_3D(vexac,xnorexac) 
     call norl2_3D(err,xnorerr) 
     rel = xnorerr/xnorexac 
     print*,'Relative error (%)',100*rel 

    endif 

! COMPUTATION OF THE ELECTRIC FIELD 
    call ef()  

!--------------------------------------------------------------------------- 
!       RESULTS OUTPUT        
!--------------------------------------------------------------------------- 
    call wrtcmp(nver,sol,10,fichsol) 

    call writeVTU(nel,nver,mm,z,'tetra',sol,'Potential (V)','scalar', & 
            'node',trim(fichsol)//'.vtu') 

    call wrtcmpv(nel,e,10,fichgradsol) 

    if(allocated(evtu))deallocate(evtu) 
    allocate(evtu(3*nel),STAT=istat) 
    if (istat.ne.0) stop 'Error while allocating evtu in principal' 

    evtu(1:nel*3:3)=e(1,1:nel) 
    evtu(2:nel*3:3)=e(2,1:nel) 
    evtu(3:nel*3:3)=e(3,1:nel) 
    call cell2node(nver, mm, evtu, evtun) 
    call writeVTU(nel,nver,mm,z,'tetra',evtun,'Electric field (V/m)',& 
        'vector','node',trim(fichgradsol)//'.vtu') 

    deallocate(evtu,STAT=istat) 
    if (istat.ne.0) stop 'Error while deallocating in principal' 
    deallocate(sol,STAT=istat) 
    if (istat.ne.0) stop 'Error while deallocating in principal' 
    deallocate(e,STAT=istat) 
    if (istat.ne.0) stop 'Error while deallocating in principal' 

    stop 'End of the execution' 

end 

Und ReadXml .f90

!----------------------------------------------------------------------- 
! procedure for reading the solver variables 
!----------------------------------------------------------------------- 

    subroutine readxml() 

    use module_SO_DEPENDANT 
    use module_REPORT 
    use module_xml_parser 
!Solver modules 
    use fich_electros3D 
    use electros3D, DOUBLElocal1 => DOUBLE 
    use cargavol, DOUBLElocal2 => DOUBLE 
    use cargacur, DOUBLElocal3 => DOUBLE 
    use cargapun, DOUBLElocal4 => DOUBLE 
    use permitividad, DOUBLElocal5 => DOUBLE 
    use bloqueo, DOUBLElocal6 => DOUBLE 
    use derivados3D, DOUBLElocal7 => DOUBLE 
    use auxiliar_cargas 

    implicit none 

    integer :: i, j, pos, ide, im, fnum 
    real(DOUBLE) :: cval 
    real(DOUBLE), dimension(:), allocatable :: xcp, aux 
    character(len=MAXPATH) :: matxml, sval, tval 
    character(len=MAXPATH), dimension(:), allocatable :: list, list2, list3, refs 
    call set_SO() 
    call set_report_level(REPORT_STDOUT) 

! inicializacion de variables (array) 
! fun_0 == User defined/Function defined by user 
    dir%fun = 1 
    neu%fun = 1 
    vol%fun = 1 
    sup%fun = 1 
    cur%fun = 1 

    ide = fopen() 

!Mesh 
    call fread(ide, '/Mesh/Open/Mesh file', fichma) 

!Boundary Condicions 
    print*,'Neumann' 
!Neumann conditions 
    iopneu = 0; iopneu1 = 0; iopneu2 = 0 
    nrn = 0 
    neuman%numero = 0 
    call flist(ide, '/Boundary conditions/Neumann/Conditions/', list) 
    do i = 1, size(list,1) !loop for defined Neumann BC's 
    call flist(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i)), list2) 
    do j = 1, size(list2,1) !loop for data type for each BC 
     select case(trim(list2(j))) 
     case('A function') 
     !References 
      call fread_alloc(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//& 
           &'/A function/Surface references', refs, realloc=.true.) 
      if (size(refs,1)>0) then 
       iopneu = 1 
       iopneu1 = 1 ! ok 
       !Function 
       call fread(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//& 
           &'/A function/Function name', sval) 
       pos = nrn + 1 
       irefn(pos:pos+size(refs,1)-1) = int(refs) 
       fnum = function_number(sval,functions) 
       if (fnum == 0) call error('readxml: unknown function: '//sval) 
       neu%fun(pos:pos+size(refs,1)-1) = fnum 
       nrn = nrn + size(refs,1) 
      else 
       print * , 'Function Neumann B.C. with 0 references: skipping' 
      endif 
     case('A constant') 
     !References 
      call fread_alloc(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//& 
           &'/A constant/Surface references', refs, realloc=.true.) 
      if (size(refs,1)>0) then 
       iopneu = 1 
       iopneu2 = 1 ! ok 
      !Constant value 
       call fread(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//& 
          &'/A constant/Constant value', cval) 
       pos = neuman%numero + 1 
       neuman%referencias(pos:pos+size(refs,1)-1) = int(refs) 
       neuman%numero = neuman%numero + size(refs,1) 
       neuman%valor(pos:pos+size(refs,1)-1) = cval 
      else 
       print * , 'Constant Neumann B.C. with 0 references: skipping' 
      endif 
     case default; call error('readxml: Case not implemented.') 
     end select 
    enddo 
    enddo 

    print*,'Dirichlet' 
    !Potential (Dirichlet) conditions 
    iopblo = 0; iopblo1 = 0; iopblo2 = 0; iopblo3 = 0 
    nrd = 0 
    blofron%numero = 0 
    blopun%numero = 0 
    call flist(ide, '/Boundary conditions/Dirichlet/Conditions', list) 
    do i = 1, size(list,1) !loop for defined potential BC's 
    call flist(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i)), list2) 
    do j = 1, size(list2,1) !loop for data type for each BC 
     select case(trim(list2(j))) 
     case('A function') 
      !References 
      call fread_alloc(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//& 
           &'/A function/Surface references', refs, realloc=.true.) 
      if (size(refs,1)>0) then 
      iopblo = 1 
      iopblo1 = 1 ! ok 
      !Function 
      call fread(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//& 
          &'/A function/Function name', sval) 
      pos = nrd + 1 
      irefd(pos:pos+size(refs,1)-1) = int(refs) 
      fnum = function_number(sval,functions) 
      if (fnum == 0) call error('readxml: unknown function: '//sval) 
      dir%fun(pos:pos+size(refs,1)-1) = fnum 
      nrd = nrd + size(refs,1) 
      else 
      print * , 'Function Dirichlet B.C. with 0 references: skipping' 
      endif 
     case('A constant') 
      !References 
      call fread_alloc(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//& 
           &'/A constant/Surface references', refs, realloc=.true.) 
      if (size(refs,1)>0) then 
       iopblo = 1 
       iopblo2 = 1 ! ok 
       !Constant value 
       call fread(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//& 
          &'/A constant/Constant value', cval) 
       pos = blofron%numero + 1 
       blofron%referencias(pos:pos+size(refs,1)-1) = int(refs) 
       blofron%numero = blofron%numero + size(refs,1) 
       blofron%valor(pos:pos+size(refs,1)-1) = cval 
      else 
       print * , 'Constant Dirichlet B.C. with 0 references: skipping' 
      endif 
!  case('Point') 
!   iopblo3 = 1 ! ok 
!   !References 
!   call fread_alloc('/B.C./Define.../B.C. type/Potential/'//trim(list(i))//& 
!       &'/Point/Reference number(s)', refs, realloc=.true.) 
!   !Constant value 
!   call fread('/B.C./Define.../B.C. type/Potential/'//trim(list(i))//& 
!      &'/Point/Constant value', cval) 
!   if (size(refs,1)>0) 
!    iopblo3 = 1 ! ok 
!    pos = blopun%numero + 1 
!    blopun%referencias(pos:pos+size(refs,1)-1) = int(refs) 
!    blopun%numero = blopun%numero + size(refs,1) 
!    blopun%valor(pos:pos+size(refs,1)-1) = cval 
!   else 
!    print * , 'Dirichlet B.C. with 0 references: skipping' 
!   endif 
     case default; call error('readxml: Case not implemented.') 
     end select 
    enddo 
    enddo 

! 2010-02-08,11: Blocking node and Blocking value 
! 2010-09-21: comentado 
!print*,'Blocking node and blocking value' 
!  call fread_alloc(ide, '/Data/Blocking for Neumann problem/'//& 
!  &'Blocking for Neumann problem/Blocking node', xcp, realloc=.true.) 
!  call fread_alloc(ide, '/Data/Blocking for Neumann problem/'//& 
!  &'Blocking for Neumann problem/Blocking value', aux, realloc=.true.) 

!  if (size(xcp,1) > 1) call error('readxml: Only 0 or 1 blocking node allowed') 
!  if (size(aux,1) > 1) call error('readxml: Only 0 or 1 blocking value allowed') 
!  if ((size(xcp,1) == 1) .and. (size(aux,1) /= 1))& 
!  &call error('readxml: Found blocking node but no blocking value') 
!  if ((size(aux,1) == 1) .and. (size(xcp,1) /= 1))& 
!  &call error('readxml: Found blocking value but no blocking node') 

!  if ((size(xcp,1) == 1) .and. (size(aux,1) == 1)) then 
!  iopblo = 1 
!  iopblo3 = 1 
!  blopun%numero = blopun%numero + 1 
!  blopun%referencias(blopun%numero) = int(xcp(1)) 
!  blopun%valor(blopun%numero) = aux(1) 
!  end if 

!Sources 

    print*,'Volume sources' 
    !Volumic sources 
    iopvol = 0 ! 1 => hai volumic sources 
    carvol%numero = 0 
    call flist(ide, '/Sources/Volumetric/Volumetric sources', list) 
    do i = 1, size(list,1) !loop for defined volumic sources 
    call flist(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i)), list2) 
    if (size(list2,1)/=1) call error('readxml: Incorrect number of childs in volume source.') 
    if (trim(list2(1)) == 'A function') then 
    !References 
     call fread_alloc(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//& 
          &'/A function/Domain references', refs, realloc=.true.) 
     if (size(refs,1)>0) then 
      iopvol = 1 
     !Function 
      call fread(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//& 
          &'/A function/Function name', sval) 
      pos = carvol%numero + 1 
      carvol%referencias(pos:pos+size(refs,1)-1) = int(refs) 
      carvol%numero = carvol%numero + size(refs,1) 
      carvol%valor(pos:pos+size(refs,1)-1) = 0.d0 
      fnum = function_number(sval,functions) 
      if (fnum == 0) call error('readxml: unknown function: '//sval) 
      vol%fun(pos:pos+size(refs,1)-1) = fnum 
      carvol%constante(pos:pos+size(refs,1)-1) = .FALSE. 
     else 
      print * , 'Function volume source with 0 references: skipping' 
     endif 
    elseif (trim(list2(1)) == 'A constant') then 
     !References 
     call fread_alloc(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//& 
          &'/A constant/Domain references', refs, realloc=.true.) 
     if (size(refs,1)>0) then 
      iopvol = 1 
      !Constant value 
      call fread(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//& 
          &'/A constant/Constant value', cval) 
      pos = carvol%numero + 1 
      carvol%referencias(pos:pos+size(refs,1)-1) = int(refs) 
      carvol%numero = carvol%numero + size(refs,1) 
      carvol%valor(pos:pos+size(refs,1)-1) = cval 
      carvol%constante(pos:pos+size(refs,1)-1) = .TRUE. 
     else 
      print * , 'Constant volume source with 0 references: skipping' 
     endif 
    else 
     call error('readxml: Incorrect volume source child: '//trim(list2(1))//'.') 
    endif 
    enddo 

    print*,'Surface sources' 
!Surface sources 
    iopsup = 0 ! 1 => hai surface sources 
    carsup%numero = 0 
    call flist(ide, '/Sources/Surface/Surface sources', list) 
    do i = 1, size(list,1) !loop for defined surface sources 
    call flist(ide, '/Sources/Surface/Surface sources/'//trim(list(i)), list2) 
    if (size(list2,1)/=1) call error('readxml: Incorrect number of childs in surface source.') 
    if (trim(list2(1)) == 'A function') then 
    !References 
     call fread_alloc(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//& 
          &'/A function/Surface references', refs, realloc=.true.) 
     if (size(refs,1)>0) then 
      iopsup = 1 
      !Function 
      call fread(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//& 
          &'/A function/Function name', sval) 
      pos = carsup%numero + 1 
      carsup%referencias(pos:pos+size(refs,1)-1) = int(refs) 
      carsup%numero = carsup%numero + size(refs,1) 
      carsup%valor(pos:pos+size(refs,1)-1) = 0.d0 
      fnum = function_number(sval,functions) 
      if (fnum == 0) call error('readxml: unknown function: '//sval) 
      sup%fun(pos:pos+size(refs,1)-1) = fnum 
      carsup%constante(pos:pos+size(refs,1)-1) = .FALSE. 
     else 
      print * , 'Function surface source with 0 references: skipping' 
     endif 
    elseif (trim(list2(1)) == 'A constant') then 
     !References 
     call fread_alloc(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//& 
          &'/A constant/Surface references', refs, realloc=.true.) 
     if (size(refs,1)>0) then 
      iopsup = 1 
      !Constant value 
      call fread(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//& 
          &'/A constant/Constant value', cval) 
      pos = carsup%numero + 1 
      carsup%referencias(pos:pos+size(refs,1)-1) = int(refs) 
      carsup%numero = carsup%numero + size(refs,1) 
      carsup%valor(pos:pos+size(refs,1)-1) = cval 
      carsup%constante(pos:pos+size(refs,1)-1) = .TRUE. 
     else 
      print * , 'Constant surface source with 0 references: skipping' 
     endif 
    else 
     call error('readxml: Incorrect surface source child: '//trim(list2(1))//'.') 
    endif 
    enddo 

    print*,'Line sources' 
!Curvilinear sources 
    iopcur = 0 ! 1 => hai line sources 
    carcur%numero = 0 



... 

end subroutine 

und XML-Datei local.dat.xml:

<?xml version="1.0" encoding="ISO-8859-15"?> 

-<data> 


-<menu name="Materials file"> 


-<submenu name="Open"> 


-<leaf name="materialsDB" type="file" totalnum="1"> 

<elements> materials.dat.xml </elements> 

</leaf> 

</submenu> 

</menu> 


-<menu name="Mesh"> 


-<submenu name="Open"> 


-<leaf name="Mesh file" type="file" totalnum="1" subtype="mesh"> 

<elements> malla3Dcs_tet.mfm </elements> 

</leaf> 

</submenu> 

</menu> 


-<menu name="Properties"> 


-<submenu name="Materials"> 


-<struct name="Materials"> 


-<leaf name="1" type="charlist" totalnum="1"> 

<elements> Test Material 2 </elements> 

</leaf> 


-<leaf name="2" type="charlist" totalnum="1"> 

<elements> Test Material 3 </elements> 

</leaf> 

</struct> 

</submenu> 

</menu> 


-<menu name="Boundary conditions"> 


-<submenu name="Dirichlet"> 


-<struct name="Conditions"> 


-<struct name="Condition 1"> 


-<struct name="A constant"> 


-<leaf name="Surface references" type="charlist" totalnum="8"> 

<elements> 1 2 3 4 9 10 13 16 </elements> 

</leaf> 


-<leaf name="Constant value" type="float" totalnum="1"> 

<elements> 5.64716513 </elements> 

</leaf> 

</struct> 

</struct> 

</struct> 

</submenu> 


-<submenu name="Neumann"> 

<struct name="Conditions"> </struct> 

</submenu> 

</menu> 


-<menu name="Sources"> 


-<submenu name="Volumetric"> 


-<struct name="Volumetric sources"> 


-<struct name="Source 1"> 


-<struct name="A constant"> 


-<leaf name="Domain references" type="charlist" totalnum="1"> 

<elements> 2 </elements> 

</leaf> 


-<leaf name="Constant value" type="float" totalnum="1"> 

<elements> 3d-10 </elements> 

</leaf> 

</struct> 

</struct> 

</struct> 

</submenu> 


-<submenu name="Surface"> 

<struct name="Surface sources"> </struct> 

</submenu> 


-<submenu name="Line"> 

<struct name="Line sources"> </struct> 

</submenu> 


-<submenu name="Point"> 

<struct name="Point sources"> </struct> 

</submenu> 

</menu> 


-<menu name="Data"> 


-<submenu name="Temperature"> 


-<leaf name="Field" type="file" totalnum="0" subtype="field"> 

<elements> </elements> 

</leaf> 

</submenu> 

</menu> 


-<menu name="Solver"> 

<submenu name="Run"> </submenu> 

<submenu name="Run remote"> </submenu> 

<submenu name="Stop"> </submenu> 

</menu> 


-<menu name="Visualization"> 


-<submenu name="Mesh"> 


-<struct name="Mesh"> 

<struct name="Triangulation"> </struct> 


-<leaf name="Domain references" type="charlist" totalnum="0"> 

<elements> </elements> 

</leaf> 


-<leaf name="Surface references" type="charlist" totalnum="0"> 

<elements> </elements> 

</leaf> 


-<leaf name="Line references" type="charlist" totalnum="0"> 

<elements> </elements> 

</leaf> 


-<leaf name="Point references" type="charlist" totalnum="0"> 

<elements> </elements> 

</leaf> 


-<leaf name="Element numbering" type="float" totalnum="0"> 

<elements> </elements> 

</leaf> 


-<leaf name="Vertex numbering" type="float" totalnum="0"> 

<elements> </elements> 

</leaf> 

<struct name="Materials"> </struct> 

<struct name="Slice"> </struct> 

<struct name="Cut"> </struct> 

<struct name="Rough cut"> </struct> 

</struct> 

</submenu> 


-<submenu name="Temperature field, T (°C, scalar)"> 


-<struct name="Temperature"> 

<struct name="Filled"> </struct> 

<struct name="Threshold"> </struct> 

<struct name="Isosurfaces"> </struct> 

<struct name="Plot over line"> </struct> 

<struct name="Slice"> </struct> 

<struct name="Cut"> </struct> 

<struct name="Rough cut"> </struct> 

</struct> 

</submenu> 


-<submenu name="Potential, V (V, scalar)"> 


-<struct name="Potential"> 

<struct name="Filled"> </struct> 

<struct name="Threshold"> </struct> 

<struct name="Isosurfaces"> </struct> 

<struct name="Plot over line"> </struct> 

<struct name="Slice"> </struct> 

<struct name="Cut"> </struct> 

<struct name="Rough cut"> </struct> 

</struct> 

</submenu> 


-<submenu name="Electric field, E (V⁄m, vector)"> 


-<struct name="Electric field"> 

<struct name="Vectors"> </struct> 


-<struct name="Vector components"> 


-<struct name="X component"> 

<struct name="Filled"> </struct> 

<struct name="Threshold"> </struct> 

<struct name="Isosurfaces"> </struct> 

<struct name="Plot over line"> </struct> 

<struct name="Slice"> </struct> 

<struct name="Cut"> </struct> 

<struct name="Rough cut"> </struct> 

</struct> 


-<struct name="Y component"> 

<struct name="Filled"> </struct> 

<struct name="Threshold"> </struct> 

<struct name="Isosurfaces"> </struct> 

<struct name="Plot over line"> </struct> 

<struct name="Slice"> </struct> 

<struct name="Cut"> </struct> 

<struct name="Rough cut"> </struct> 

</struct> 


-<struct name="Z component"> 

<struct name="Filled"> </struct> 

<struct name="Threshold"> </struct> 

<struct name="Isosurfaces"> </struct> 

<struct name="Plot over line"> </struct> 

<struct name="Slice"> </struct> 

<struct name="Cut"> </struct> 

<struct name="Rough cut"> </struct> 

</struct> 


-<struct name="Modulus"> 

<struct name="Filled"> </struct> 

<struct name="Threshold"> </struct> 

<struct name="Isosurfaces"> </struct> 

<struct name="Plot over line"> </struct> 

<struct name="Slice"> </struct> 

<struct name="Cut"> </struct> 

<struct name="Rough cut"> </struct> 

</struct> 

</struct> 

</struct> 

</submenu> 

<submenu name="Close all"> </submenu> 

</menu> 

</data> 

ich wissen will, wie kann ich ein XML-Dateinamen als Argument übergeben, ohne zu ändern Code-Dateien ReadXml? Als eine Beschreibung möchte ich den Mechanismus von Fortran kennen.

Jede Hilfe wird geschätzt. Grüße.

Answer 1

Ich fand, wie übergeben ein XML-Dateiname Argument an readxml, ohne Code-Dateien zu ändern. Im Folgenden finden Sie über fopen und flist und so weiter Funktion in module_xml_parser.f90:

module module_xml_parser 
!----------------------------------------------------------------------- 
! Module for reading xml files 
! Last update: 26/04/2009 
!----------------------------------------------------------------------- 
use module_ALLOC 
use module_CONVERS 
use module_REPORT 
use module_FILES 
implicit none 

!Constants 
character(len=*), dimension(4), parameter, private :: OPEN_MARK_MEMBERS = & 
(/ '<menu ', '<submenu','<struct ', '<leaf ' /) 
character(len=*), dimension(4), parameter, private :: CLOSE_MARK_MEMBERS = & 
(/ '</menu ', '</submenu','</struct ', '</leaf ' /) 
character(len=*), dimension(1), parameter, private :: OPEN_MARK_LEAF = (/ '<leaf' /) 
character(len=*), dimension(1), parameter, private :: CLOSE_MARK_LEAF = (/ '</leaf' /) 
character(len=*), dimension(1), parameter, private :: OPEN_MARK_ELEMENT = (/ '<element' /) 
character(len=*), dimension(1), parameter, private :: CLOSE_MARK_ELEMENT = (/ '</element' /) 

!Class attributes 

!Private methods 
private :: search_mark_once, search_mark, search_close_mark, follow_path, & 
      last_part, cut_end_delimiter 
private :: fread_real, fread_vreal, fread_vreal_alloc, & 
      fread_complex, fread_vcomplex, fread_vcomplex_alloc, & 
      fread_char, fread_vchar, fread_vchar_alloc 

!Interfaces 
interface fread; module procedure fread_real; end interface 
interface fread; module procedure fread_vreal; end interface 
interface fread; module procedure fread_complex; end interface 
interface fread; module procedure fread_vcomplex; end interface 
interface fread; module procedure fread_char; end interface 
interface fread; module procedure fread_vchar; end interface 
interface fread_alloc; module procedure fread_vreal_alloc; end interface 
interface fread_alloc; module procedure fread_vcomplex_alloc; end interface 
interface fread_alloc; module procedure fread_vchar_alloc; end interface 

contains 

!----------------------------------------------------------------------- 
! fopen: open a xml file 
!----------------------------------------------------------------------- 
function fopen(datxml) result(un) 

character(len=*), intent(in), optional :: datxml !file name 
character(len=MAXPATH) :: xmlfile, arg1 
integer :: un !associated unit number 
integer :: ios, length, status 

!find a valid xmlfile 
xmlfile = ' ' 
if (present(datxml)) then 
    xmlfile = datxml 
else 
    if (command_argument_count() == 2) then 
    call get_command_argument(1, arg1, length, status) 
    if (status /= 0) call error('fopen/get_command_argument, '& 
    &//'the first command argument cannot be read') 
    if (trim(adjustl(arg1)) == '-xml') then 
     call get_command_argument(2, xmlfile, length, status) 
     if (status /= 0) call error('fopen/get_command_argument, '& 
     &//'the second command argument cannot be read') 
    else 
     call error('fopen/get_command_argument, '& 
     &//'the first command argument is not recognized (must be -xml)') 
    endif 
    elseif (command_argument_count() == 1) then 
    call get_command_argument(1, arg1, length, status) 
    if (status /= 0) call error('fopen/get_command_argument, '& 
    &//'the first command argument cannot be read') 
    if (trim(adjustl(arg1)) == '-xml') then 
     xmlfile = 'local.dat.xml' 
    else 
     call error('fopen/get_command_argument, '& 
     &//'the first command argument is not recognized (must be -xml)') 
    endif 
    elseif (command_argument_count() == 0) then 
    xmlfile = 'local.dat.xml' 
    else 
    call error('fopen/get_command_argument, '& 
    &//'too many arguments') 
    end if 
end if 
if (len_trim(xmlfile)==0) call error('fopen, filename is empty') 
call info('fopen (xmlfile), '//trim(xmlfile)) 
! open xmlfile 
un = get_unit() 
open (unit=un, file=xmlfile, form='formatted', iostat=ios, & 
status='old', position='rewind') 
if (ios /= 0) call error('fopen, #'//trim(string(ios))) 

end function 

!----------------------------------------------------------------------- 
! fread: read data from xml file 
!----------------------------------------------------------------------- 
subroutine fread_real(un, path, var) 

integer,   intent(in) :: un 
character(len=*), intent(in) :: path 
real(DOUBLE),  intent(out) :: var 
integer :: res, tn = 1 

call follow_path(un, path, back = .true.) 
if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), & 
typ='float', tnum=tn)) call error(trim(path)//'), not found') 
!get_elements 
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found') 
read (un, *, iostat=res) var 
if (res /= 0) call error('fread_real/read ('//trim(path)//'), #'//trim(string(res))) 
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found') 
call info('fread_real ('//trim(path)//'), '//trim(string(var))) 

end subroutine 

!----------------------------------------------------------------------- 
! fread: read data from xml file 
!----------------------------------------------------------------------- 
subroutine fread_vreal(un, path, var) 

integer,   intent(in) :: un 
character(len=*),   intent(in) :: path 
real(DOUBLE), dimension(:), intent(out) :: var 
integer :: res, tn, i 

call follow_path(un, path, back = .true.) 
!get the total number 
tn = -1; if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), & 
typ='float', tnum=tn)) call error(trim(path)//'), not found') 
if (tn > size(var,1)) call error('fread_vreal ('//trim(path)//'), found totalnum '//& 
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1)))) 
!get elements 
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found') 
if (tn>0) then 
    read (un, *, iostat=res) var(1:tn) 
    if (res /= 0) call error('fread_vreal/read ('//trim(path)//'), #'//trim(string(res))) 
endif 
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found') 
do i = 1, tn 
    call info('fread_vreal ('//trim(path)//'), '//trim(string(var(i)))) 
enddo 

end subroutine 

!----------------------------------------------------------------------- 
! fread: read data from xml file 
!----------------------------------------------------------------------- 
subroutine fread_vreal_alloc(un, path, var, realloc) 

integer,     intent(in) :: un 
character(len=*),   intent(in) :: path 
real(DOUBLE), dimension(:), intent(inout), allocatable :: var 
logical,     intent(in), optional :: realloc 
integer :: res, tn, i 

call follow_path(un, path, back = .true.) 
!get the total number 
tn = -1; if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), & 
typ='float', tnum=tn)) call error(trim(path)//'), not found') 
if (present(realloc)) then; if (realloc) then 
    if (allocated(var)) call dealloc(var) 
endif; endif 
if (.not. allocated(var)) call alloc(var, tn) 
if (tn > size(var,1)) call error('fread_vreal_alloc ('//trim(path)//'), found totalnum '//& 
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1)))) 
!get elements 
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found') 
if (tn>0) then 
    read (un, *, iostat=res) var(1:tn) 
    if (res /= 0) call error('fread_vreal/read ('//trim(path)//'), #'//trim(string(res))) 
endif 
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found') 
do i = 1, tn 
    call info('fread_vreal_alloc ('//trim(path)//'), '//trim(string(var(i)))) 
enddo 

end subroutine 

!----------------------------------------------------------------------- 
! fread: read data from xml file 
!----------------------------------------------------------------------- 
subroutine fread_complex(un, path, var) 

integer,   intent(in) :: un 
character(len=*), intent(in) :: path 
character(len=128)   :: tempstring 
complex(DOUBLE), intent(out) :: var 
integer :: res, tn = 1 

call follow_path(un, path, back = .true.) 
if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), & 
typ='complex', tnum=tn)) call error(trim(path)//'), not found') 
!get_elements 
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found') 
read (un, *, iostat=res) var 
if (res /= 0) call error('fread_complex/read ('//trim(path)//'), #'//trim(string(res))) 
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found') 
write(tempstring,*) var 
call info('fread_complex ('//trim(path)//'), '//trim(tempstring)) 

end subroutine 

!----------------------------------------------------------------------- 
! fread: read data from xml file 
!----------------------------------------------------------------------- 
subroutine fread_vcomplex(un, path, var) 

integer,   intent(in) :: un 
character(len=*),   intent(in) :: path 
character(len=128)      :: tempstring 
complex(DOUBLE), dimension(:), intent(out) :: var 
integer :: res, tn, i 

call follow_path(un, path, back = .true.) 
!get the total number 
tn = -1; if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), & 
typ='complex', tnum=tn)) call error(trim(path)//'), not found') 
if (tn > size(var,1)) call error('fread_vcomplex ('//trim(path)//'), found totalnum '//& 
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1)))) 
!get elements 
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found') 
if (tn>0) then 
    read (un, *, iostat=res) var(1:tn) 
    if (res /= 0) call error('fread_vcomplex/read ('//trim(path)//'), #'//trim(string(res))) 
endif 
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found') 
do i = 1, tn 
    write(tempstring,*) var(i) 
    call info('fread_vcomplex ('//trim(path)//'), '//trim(tempstring)) 
enddo 

end subroutine 

!----------------------------------------------------------------------- 
! fread: read data from xml file 
!----------------------------------------------------------------------- 
subroutine fread_vcomplex_alloc(un, path, var, realloc) 

integer,     intent(in) :: un 
character(len=*),   intent(in) :: path 
character(len=128)      :: tempstring 
complex(DOUBLE), dimension(:), intent(inout), allocatable :: var 
logical,     intent(in), optional :: realloc 
integer :: res, tn, i 

call follow_path(un, path, back = .true.) 
!get the total number 
tn = -1; if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), & 
typ='complex', tnum=tn)) call error(trim(path)//'), not found') 
if (present(realloc)) then; if (realloc) then 
    if (allocated(var)) deallocate(var) 
endif; endif 
if (.not. allocated(var)) allocate(var(tn)) 
if (tn > size(var,1)) call error('fread_vcomplex_alloc ('//trim(path)//'), found totalnum '//& 
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1)))) 
!get elements 
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found') 
if (tn>0) then 
    read (un, *, iostat=res) var(1:tn) 
    if (res /= 0) call error('fread_vcomplex_alloc/read ('//trim(path)//'), #'//trim(string(res))) 
endif 
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found') 
do i = 1, tn 
    write(tempstring,*) var(i) 
    call info('fread_vcomplex_alloc ('//trim(path)//'), '//trim(tempstring)) 
enddo 

end subroutine 

!----------------------------------------------------------------------- 
! fread: read data from xml file 
!----------------------------------------------------------------------- 
subroutine fread_char(un, path, var) 

integer,   intent(in) :: un 
character(len=*), intent(in) :: path 
character(len=*), intent(out) :: var 
integer :: res, tn = 1 

call follow_path(un, path, back = .true.) 
if (.not.search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), tnum=tn)) & !typ can be diverse 
    call error(trim(path)//'), not found') 
!get_elements 
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found') 
read (un, '(a)', iostat=res) var 
var = adjustlt(var) 
if (res /= 0) call error('fread_char/read ('//trim(path)//'), #'//trim(string(res))) 
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found') 
call info('fread_char ('//trim(path)//'), '//trim(var)) 

end subroutine 

!----------------------------------------------------------------------- 
! fread: read data from xml file 
!----------------------------------------------------------------------- 
subroutine fread_vchar(un, path, var) 

integer,      intent(in) :: un 
character(len=*),    intent(in) :: path 
character(len=*), dimension(:), intent(inout) :: var 
integer :: res, tn, i 

call follow_path(un, path, back = .true.) 
!get the total number 
tn = -1; if (.not. search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), tnum=tn)) & !typ can be diverse 
    call error('fread_vchar ('//trim(path)//'), not found') 
if (tn > size(var,1)) call error('fread_vchar ('//trim(path)//'), found totalnum '//& 
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1)))) 
!get elements 
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found') 
if (tn>0) then 
    read (un, '(a'//trim(string(len(var(1))))//')', iostat=res) var(1:tn) 
    if (res /= 0) call error('fread_vreal/read ('//trim(path)//'), #'//trim(string(res))) 
endif 
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found') 
do i = 1, tn 
    var(i) = adjustlt(var(i)) 
    call info('fread_vchar ('//trim(path)//'), '//trim(var(i))) 
enddo 

end subroutine 

!----------------------------------------------------------------------- 
! fread: read data from xml file 
!----------------------------------------------------------------------- 
subroutine fread_vchar_alloc(un, path, var, realloc) 

integer,   intent(in) :: un 
character(len=*), intent(in) :: path 
character(len=*), intent(inout), dimension(:), allocatable :: var 
logical,   intent(in), optional :: realloc 
integer :: res, tn, i 

call follow_path(un, path, back = .true.) 
!get the total number 
tn = -1; if (.not. search_mark_once(un, path, OPEN_MARK_LEAF, name = last_part(path), tnum=tn)) & !typ can be diverse 
    call error('fread_vchar_alloc ('//trim(path)//'), not found') 
if (present(realloc)) then; if (realloc) then 
    if (allocated(var)) call dealloc(var) 
endif; endif 
if (.not. allocated(var)) call alloc(var, tn) 
if (tn > size(var,1)) call error('fread_vreal_alloc ('//trim(path)//'), found totalnum '//& 
trim(string(tn))//' is bigger than expected '//trim(string(size(var,1)))) 
!get elements 
if (.not.search_mark_once(un, path, OPEN_MARK_ELEMENT)) call error(trim(path)//', not found') 
if (tn>0) then 
    read (un, '(a'//trim(string(len(var(1))))//')', iostat=res) var(1:tn) 
    if (res /= 0) call error('fread_vchar/read ('//trim(path)//'), #'//trim(string(res))) 
endif 
if (.not.search_mark_once(un, path,CLOSE_MARK_ELEMENT)) call error(trim(path)//', not found') 
do i = 1, tn 
    var(i) = adjustlt(var(i)) 
    call info('fread_vchar_alloc ('//trim(path)//'), '//trim(var(i))) 
enddo 

end subroutine 

!----------------------------------------------------------------------- 
! flist: list the members of a structure 
!----------------------------------------------------------------------- 
subroutine flist(un, path, var) 

integer,    intent(in) :: un 
character(len=*),  intent(in) :: path 
character(len=*), allocatable, dimension(:) :: var 
character(len=MAXPATH), allocatable, dimension(:) :: tmp 
integer :: p, n, res 
character(len=MAXPATH) :: line 
logical :: close_mark_found 

n = 0 
!initial allocation of tmp 
if (.not. allocated(tmp)) call alloc(tmp, 10) 
!follow the path (advancing the last line) 
call follow_path(un, path) 
!check whether a close mark is reached 
close_mark_found = search_mark_once(un, path, CLOSE_MARK_MEMBERS, back = .true.) 
!loop to catch members 
do while (.not. close_mark_found) 
    !searchs a new member 
    call search_mark(un, path, OPEN_MARK_MEMBERS, back=.true.) 
    !stores the name 
    read (un, fmt='(A)', iostat=res) line 
    if (res /= 0) call error('flist/read ('//trim(path)//'), #'//trim(string(res))) 
    p = index(line, 'name=') 
    n = n + 1; if (n > size(tmp, 1)) call extend(tmp, 10) 
    tmp(n) = trim(string(cut_end_delimiter(line(p+5:),'>'))) 
    !searchs the end of the member 
    call search_close_mark(un, path) 
    !check whether a close mark is reached 
    close_mark_found = search_mark_once(un, path, CLOSE_MARK_MEMBERS, back = .true.) 
enddo 
!advance one line in file 
close_mark_found = search_mark_once(un, path, CLOSE_MARK_MEMBERS) 
!final result 
if (allocated(var)) call dealloc(var) 
call alloc(var, n) 
var(1:n) = tmp(1:n) 

end subroutine 

!----------------------------------------------------------------------- 
! fclose: close a xml file 
!----------------------------------------------------------------------- 
subroutine fclose(un) 

integer, intent(in) :: un 
integer :: ios 
close(unit=un, iostat=ios) 
if (ios /= 0) call error('read_xml/close, #'//trim(string(ios))) 

end subroutine 

!*********************************************************************** 
! PRIVATE PROCEDURES 
!*********************************************************************** 
!----------------------------------------------------------------------- 
! search_mark_once: searchs a mark only once 
! RETURN: .true. if the mark is found 
!   .false. otherwise 
!----------------------------------------------------------------------- 
recursive function search_mark_once(un, path, marks, name, typ, tnum, advance, back) result(res) 
integer,   intent(in) :: un 
character(len=*), intent(in) :: path 
character(len=*), intent(in), dimension(:) :: marks 
character(len=*), intent(in), optional :: name, typ 
integer,   intent(inout), optional :: tnum 
logical, intent(in), optional :: back, advance 
logical :: res 
integer :: ios, i, p 
character(len=MAXPATH) :: line 

res = .false. 
!read a line 
read (un, fmt='(A)', iostat=ios) line 
if (ios /= 0) call error('search_mark_once/read ('//trim(path)//'), #'//trim(string(ios))) 
!backspace 
if (present(back)) then 
    if (back) then 
    backspace(unit=un, iostat=ios) 
    if (ios /= 0) call error('search_mark_once/backspace ('//trim(path)//'), #'//trim(string(ios))) 
    endif 
endif 
do i = 1, size(marks, 1) 
    if (index(line, trim(marks(i))) > 0) then 
    !check name 
    if (present(name)) then 
     p = index(line, 'name=') 
     if (trim(name) /= trim(string(cut_end_delimiter(line(p+5:),'>')))) then 
     if (present(advance)) then 
      if (advance) call search_close_mark(un, path) 
     endif 
     cycle 
     endif 
    endif 
    !check type 
    if (present(typ)) then 
     p = index(line, 'type=') 
     if (trim(typ) /= trim(string(cut_end_delimiter(line(p+5:),'>')))) then 
     if (present(advance)) then 
      if (advance) call search_close_mark(un, path) 
     endif 
     cycle 
     endif 
    endif 
    !check totalnum 
    if (present(tnum)) then 
     p = index(line, 'totalnum=') 
     if (tnum > 0) then 
     if (tnum /= int(string(cut_end_delimiter(line(p+9:),'>')))) then 
      if (present(advance)) then 
      if (advance) call search_close_mark(un, path) 
      endif 
      cycle 
     endif 
     else 
     tnum = int(string(cut_end_delimiter(line(p+9:),'>'))) 
     endif 
    endif 
    !the mark, name, type and/or tnum matches 
    res = .true.; return 
    endif 
enddo 

end function 

!----------------------------------------------------------------------- 
! search_mark: searchs a mark 
!----------------------------------------------------------------------- 
subroutine search_mark(un, path, marks, name, typ, tnum, back, advance) 
integer,   intent(in) :: un 
character(len=*), intent(in) :: path 
character(len=*), intent(in), dimension(:) :: marks 
character(len=*), intent(in), optional :: name, typ 
integer,   intent(inout), optional :: tnum 
logical, intent(in), optional :: back, advance 
integer :: ios 

do 
    if (search_mark_once(un, path, marks, name, typ, tnum, advance, back=.false.)) then 
    !backspace 
    if (present(back)) then; if (back) then 
     backspace(unit=un, iostat=ios) 
     if (ios /= 0) call error('search_mark/backspace, ('//trim(path)//') #'//trim(string(ios))) 
    endif; endif 
    return 
    endif 
    !ends the loop if a close mark is found 
    if (search_mark_once(un, path, CLOSE_MARK_MEMBERS, back = .true.)) exit 
enddo 
!mark not found 
call error('search_mark ('//trim(path)//'), not found') 

end subroutine 

!----------------------------------------------------------------------- 
! search_close_mark: search a close mark 
!----------------------------------------------------------------------- 
recursive subroutine search_close_mark(un, path) 

integer,   intent(in) :: un 
character(len=*), intent(in) :: path 
integer :: n 

n = 1 !number of open marks 
do while (n > 0) 
    if (search_mark_once(un, path, OPEN_MARK_MEMBERS, back=.true.)) n = n + 1 
    if (search_mark_once(un, path, CLOSE_MARK_MEMBERS)) n = n - 1 
enddo 

end subroutine 

!----------------------------------------------------------------------- 
! follow_path: follow the path 
!----------------------------------------------------------------------- 
subroutine follow_path(un, path, back) 

integer,   intent(in) :: un 
character(len=*), intent(in) :: path 
logical, optional, intent(in) :: back 
character(len=len(path)) :: lpath, parte 
character(len=1) :: separador 
integer :: p, res 

rewind(un) 
separador = path(1:1) 
lpath = path(2:) 
parte = lpath 
do while (len_trim(parte) > 0) 
    p = index(lpath, separador) 
    if (p > 0) then 
    parte = lpath(:p-1); lpath = lpath(p+1:) 
    else 
    parte = lpath;  lpath = ' ' 
    endif 
    call search_mark(un, path, OPEN_MARK_MEMBERS, parte, advance=.true.) 
    parte = lpath 
enddo 
if (present(back)) then; if (back) then 
    backspace(unit=un, iostat=res) 
    if (res /= 0) call error('follow_path/backspace ('//trim(path)//'), #'//trim(string(res))) 
endif; endif 

end subroutine 

!----------------------------------------------------------------------- 
! last_part: extracts the last part of a path 
!----------------------------------------------------------------------- 
function last_part(path) result(res) 

character(len=*), intent(in) :: path 
character(len=len(path)) :: res 
character(len=1) :: separador 
integer :: p 

separador = path(1:1) 
p = index(path, separador, back=.true.) 
res = path(p+1:) 

end function 

!----------------------------------------------------------------------- 
! cut_end_delimiter: cuts an end delimiter 
!----------------------------------------------------------------------- 
function cut_end_delimiter(str, delimiter) result(res) 
character(len=*), intent(in) :: str, delimiter 
character(len=len(str)) :: res 
integer :: p 

res = str 
p = index(str, delimiter) 
if (p > 0) res = str(:p-1) 

end function 

end module