Read derived types from namelist

Help
4

@iarbina , @urbanjost :

If you don’t mind some code toward custom handling of NAMELIST components of derived type, you could consider defined input/output data transfers that the standard supports since Fortran 2003.

See a working example below if you wish to try (again, hope you don’t mind it’s with a commercial processor whose support staff I have bugged over the years to get this and other standard features working):

Click to see Fortran code

Defined input/output with NAMELIST

module point_m
   enum, bind(C)
      enumerator :: RED
      enumerator :: BLUE
      enumerator :: GREEN  
   end enum
   type :: point_t
      real :: x = 0.0
      real :: y = 0.0
      integer :: color = RED
   contains
      private
      procedure, pass(dtv) :: read_point_t
      procedure, pass(dtv) :: write_point_t
      generic, public :: read(formatted) => read_point_t
      generic, public :: write(formatted) => write_point_t
   end type

   character(len=*), parameter :: QUOTE = "'"
   character(len=*), parameter :: BEGIN_TOKEN = "<"
   character(len=*), parameter :: END_TOKEN = ">"

contains
 
   subroutine read_point_t(dtv, lun, iotype, vlist, istat, imsg)

      ! Argument list
      class(point_t), intent(inout)   :: dtv
      integer, intent(in)             :: lun
      character(len=*), intent(in)    :: iotype
      integer, intent(in)             :: vlist(:)
      integer, intent(out)            :: istat
      character(len=*), intent(inout) :: imsg

      ! Local variables
      real :: x
      real :: y
      integer :: color
      integer :: beg_idx, end_idx
      character(len=2048) :: nml_str
      namelist / point / x, y, color

      select case ( iotype )

         case ( "LISTDIRECTED" )
            ! Elided
         case ( "DT" )
            ! Elided
            if ( size(vlist) == 0 ) istat = 1
         case ( "NAMELIST" )
            read_blk: block
               read( unit=lun, fmt=*, iostat=istat, iomsg=imsg ) nml_str
               if ( istat /= 0 ) exit read_blk 
               beg_idx = index( nml_str, BEGIN_TOKEN )
               if ( beg_idx == 0 ) then
                  istat = 1
                  imsg = "Error parsing namelist string for point_t type"
                  exit read_blk
               end if 
               end_idx = index( nml_str, END_TOKEN, back=.true. )
               if ( end_idx == 0 ) then
                  istat = 2
                  imsg = "Error parsing namelist string for point_t type"
                  exit read_blk
               end if 
               if ( beg_idx + 1 >= end_idx-1 ) then
                  istat = 3
                  imsg = "Error parsing namelist string for point_t type"
                  exit read_blk
               end if 
               read( unit=nml_str(beg_idx+1:end_idx-1), nml=point, iostat=istat, iomsg=imsg )
               if ( istat /= 0 ) exit read_blk
               dtv%x = x
               dtv%y = y
               dtv%color = color 
            end block read_blk 
            return
         case default

      end select

      return

   end subroutine read_point_t

   subroutine write_point_t( dtv, lun, iotype, vlist, istat, imsg )

      ! Argument list
      class(point_t), intent(in)       :: dtv
      integer, intent(in)              :: lun
      character(len=*), intent(in)     :: iotype
      integer, intent(in)              :: vlist(:)
      integer, intent(out)             :: istat
      character (len=*), intent(inout) :: imsg

      ! Local variables
      real :: x
      real :: y
      integer :: color
      character(len=2048) :: nml_str
      namelist / point / x, y, color

      istat = 0
      select case ( iotype )
         case ( "LISTDIRECTED" )
            ! Elided
         case ( "DT" )
            ! Elided
            if ( size(vlist) == 0 ) istat = 1
         case ( "NAMELIST" )
            x = dtv%x
            y = dtv%y
            color = dtv%color
            write( unit=nml_str, nml=point, iostat=istat, iomsg=imsg )
            if ( istat == 0 ) then
               write( unit=lun, fmt="(*(g0))", iostat=istat, iomsg=imsg) QUOTE, BEGIN_TOKEN,        &
                  trim(nml_str), END_TOKEN, QUOTE
            end if 
            return
      end select

      return

   end subroutine

end module
   use, intrinsic :: iso_fortran_env, only : stdout => output_unit
   use point_m
   
   type(point_t) :: point
   character(len=:), allocatable :: stream_data
   character(len=:), allocatable :: msg
   character(len=2048) :: imsg
   integer :: istat
   namelist / dat / msg, point

   stream_data = "&dat msg='Hello World!', point=" // QUOTE // BEGIN_TOKEN // &
     "&point x=1.0, y=2.0, color=1 /" // END_TOKEN // QUOTE // "/"
   allocate( character(len=132) :: msg )
   read( stream_data, nml=dat, iostat=istat, iomsg=imsg )
   if ( istat == 0 ) then
      print *, "point%x = ", point%x, "; expected is 1.0" 
      print *, "point%y = ", point%y, "; expected is 2.0" 
      print *, "point%color = ", point%color, "; expected is 1"
      msg = trim(msg)
      write( stdout, nml=dat )
   else
      print *, "Namelist read failed: iostat = ", istat
      print *, trim(imsg)
   end if 
end

C:\temp>ifort /standard-semantics p.f90
Intel(R) Fortran Intel(R) 64 Compiler Classic for applications running on Intel(R) 64, Version 2021.3.0 Build 20210609_000000
Copyright (C) 1985-2021 Intel Corporation. All rights reserved.

Microsoft (R) Incremental Linker Version 14.29.30038.1
Copyright (C) Microsoft Corporation. All rights reserved.

-out:p.exe
-subsystem:console
p.obj

C:\temp>p.exe
point%x = 1.000000 ; expected is 1.0
point%y = 2.000000 ; expected is 2.0
point%color = 1 ; expected is 1
&DAT
MSG = Hello World!,
POINT= ‘<&POINT X= 1.000000 ,Y= 2.000000 ,COLOR= 1/>’
/

C:\temp>

1 Like