首页 文章

从Fortran中的子例程返回一个已分配的字符串数组?

提问于
浏览
4

我需要从fortran中的子例程返回一个字符串数组,其长度应该在运行时确定 . 我找到的解决方案,与英特尔Fortran一起工作,然而与gfortran崩溃 .

示例代码

以下代码似乎适用于英特尔Fortran(15.0.3),但因gfortran 5.3.0的分段错误而失败:

program stringtest   ! filename:str2.f08
  implicit none
  integer n
  character(len=:), allocatable :: y(:)

  write(*,*) 'mkchars...'
  call mkchars(y)
  write(*,*) 'mkchars... Done.'
  write(*,'(5("|",A,"|"))') y

contains 

  subroutine mkchars(oc)
    character(len=:), allocatable, intent(out) :: oc(:)
    allocate(character(len=8) :: oc(5))
    write(*,*) 'shape  ', shape(oc)
    write(*,*) 'length ', (len(oc(n)), n=1,5)
    write(*,*) 'storage', storage_size(oc)
    oc(1) = "Hello"
    oc(2) = "World" ! <-------------------- crashes here with gfortran
    oc(3) = "how"
    oc(4) = "are"
    oc(5) = "you?"
  end subroutine mkchars

end program stringtest

IFort输出

使用英特尔Fortran 15.0.3,可以生成

mkchars...
 shape             5
 length            8           8           8           8           8
 storage          64
 mkchars... Done.
|Hello   ||World   ||how     ||are     ||you?    |

GFortran:可执行文件在分配给OC时崩溃(2)

但是,使用gfortran时,在分配给 OC(2) 时会出现分段错误,即使数组的形状和每个条目的长度按预期报告:

C:\tmp>gdb -batch -ex run -ex bt a.exe
[New Thread 12024.0x38e4]
 mkchars...
 shape             5
 length            8           8           8           8           8
 storage          64

Program received signal SIGSEGV, Segmentation fault.
0x0000000000401840 in mkchars (oc=<incomplete type>, _oc=_oc@entry=0x61fdbc) at c:/tmp/str2.f08:20
20          oc(2) = "World"
#0  0x0000000000401840 in mkchars (oc=<incomplete type>, _oc=_oc@entry=0x61fdbc) at c:/tmp/str2.f08:20
#1  0x00000000004019a0 in stringtest () at c:/tmp/str2.f08:9
#2  0x0000000000401a84 in main (argc=1, argv=0x6f5890) at c:/tmp/str2.f08:9
#3  0x00000000004013e8 in __tmainCRTStartup ()
#4  0x000000000040151b in mainCRTStartup ()

我做错了什么,或者这是一个可能的编译错误?

是否有一些其他方法从子程序返回分配的字符串数组在gfortran中工作?

对于手头的实际用例,我可以回到使用超大的固定大小的阵列(大约100KB而不是<1KB)并忽略未使用的部分 . 但我更喜欢更清洁的解决方案 .

1 回答

  • 1

    我一段时间为我的代码“MOONS”编写了一个Fortran字符串类 . 我编写字符串类的方法是首先在派生类型(char)中包装单个字符,然后创建一个使用char类型的可分配的外部类(字符串) . 这样,我避免编写可分配的字符,而是编写一个可分配的派生类型 .

    当我第一次开发这个类时,我首先尝试使用您所显示的相同方法,但我遇到了编译/运行时错误 . 此字符串类适用于gfortran 4.9.2 . 我已经测试了其他版本,但我不记得具体哪些版本 .

    这是github,它将拥有最新的字符串类版本

    https://github.com/charliekawczynski/MOONS

    字符串类的当前目录是

    https://github.com/charliekawczynski/MOONS/blob/master/code/pre_generated/string.f90

    但我不能保证将来不会改变 . 我会在这里包含当前版本:

    module string_mod
      implicit none
      ! Implimentation:
    
      ! program test_string
      ! use string_mod
      ! implicit none
      ! type(string) :: s
      ! call init(s,'This is');            write(*,*) 'string = ',str(s)
      ! call append(s,' a variable');      write(*,*) 'string = ',str(s)
      ! call append(s,' sized string!');   write(*,*) 'string = ',str(s)
      ! call compress(s);                  write(*,*) 'string, no spaces = ',str(s)
      ! call delete(s)
      ! end program
    
      private
    
      character(len=4),parameter :: dot_dat = '.dat'
    
      public :: string
      public :: init,delete,display,print,export,import ! Essentials
    
      public :: write_formatted
      public :: string_allocated
      public :: get_str,str ! str does not require length
      public :: len,match,match_index
      public :: compress,append,prepend
      public :: get_char,set_char
      public :: remove_element
      public :: identical
    
      public :: set_IO_dir
      public :: make_IO_dir
      public :: export_structured
      public :: import_structured
      public :: export_primitives
      public :: import_primitives
    
      interface init;                 module procedure init_size;                      end interface
      interface init;                 module procedure init_string;                    end interface
      interface init;                 module procedure init_copy;                      end interface
      interface delete;               module procedure delete_string;                  end interface
      interface display;              module procedure display_string;                 end interface
      interface print;                module procedure print_string;                   end interface
      interface export;               module procedure export_string;                  end interface
      interface import;               module procedure import_string;                  end interface
    
      interface write_formatted;      module procedure write_formatted_string;         end interface
      interface string_allocated;     module procedure string_allocated_string;        end interface
    
      interface append;               module procedure app_string_char;                end interface
      interface append;               module procedure app_string_string;              end interface
      interface prepend;              module procedure prep_string_char;               end interface
      interface prepend;              module procedure prep_string_string;             end interface
      interface compress;             module procedure compress_string;                end interface
      interface len;                  module procedure str_len_string;                 end interface
      interface str;                  module procedure get_str_short;                  end interface
      interface get_str;              module procedure get_str_string;                 end interface
      interface match;                module procedure substring_in_string;            end interface
      interface match_index;          module procedure index_substring_in_string;      end interface
      interface get_char;             module procedure get_char_string;                end interface
      interface set_char;             module procedure set_char_string;                end interface
      interface remove_element;       module procedure remove_element_string;          end interface
      interface identical;            module procedure identical_string_string;        end interface
      interface identical;            module procedure identical_string_char;          end interface
    
      interface insist_allocated;     module procedure insist_allocated_string;        end interface
    
      ! Copied from generated code:
    
      interface set_IO_dir;           module procedure set_IO_dir_string;              end interface
      interface make_IO_dir;          module procedure make_IO_dir_string;             end interface
      interface export_structured;    module procedure export_structured_D_string;     end interface
      interface import_structured;    module procedure import_structured_D_string;     end interface
      interface export_primitives;    module procedure export_primitives_string;       end interface
      interface import_primitives;    module procedure import_primitives_string;       end interface
      interface suppress_warnings;    module procedure suppress_warnings_string;       end interface
    
      type char
        private
        character(len=1) :: c
      end type
    
      type string
        private
        type(char),dimension(:),allocatable :: s ! string
        integer :: n = 0                         ! string length
      end type
    
      contains
    
      subroutine init_size(st,n)
        implicit none
        type(string),intent(inout) :: st
        integer,intent(in) :: n
        if (n.lt.1) stop 'Error: string must be of size > 1 in string.f90'
        call delete(st)
        allocate(st%s(n))
        st%n = n
      end subroutine
    
      subroutine init_string(st,s)
        implicit none
        type(string),intent(inout) :: st
        character(len=*),intent(in) :: s
        integer :: i
        call init(st,len(s))
        do i=1,st%n
          call init_char(st%s(i),s(i:i))
        enddo
      end subroutine
    
      subroutine init_copy(a,b)
        implicit none
        type(string),intent(inout) :: a
        type(string),intent(in) :: b
        integer :: i
        call delete(a)
        ! call insist_allocated(b,'init_copy')
        if ((b%n.gt.0).and.(string_allocated(b))) then
          call init(a,b%n)
          do i=1,b%n
          call init_copy_char(a%s(i),b%s(i))
          enddo
          a%n = b%n
        endif
      end subroutine
    
      subroutine delete_string(st)
        implicit none
        type(string),intent(inout) :: st
        if (allocated(st%s)) deallocate(st%s)
        st%n = 0
      end subroutine
    
      subroutine display_string(st,un)
        implicit none
        type(string),intent(in) :: st
        integer,intent(in) :: un
        call export(st,un)
      end subroutine
    
      subroutine print_string(st)
        implicit none
        type(string),intent(in) :: st
        call display(st,6)
        write(6,*) ''
      end subroutine
    
      subroutine export_string(st,un)
        implicit none
        type(string),intent(in) :: st
        integer,intent(in) :: un
        ! call insist_allocated(st,'export_string')
        if (string_allocated(st)) then
          write(un,*) str(st)
        else
          write(un,*) 'string not allocated'
        endif
      end subroutine
    
      subroutine import_string(s,un)
        implicit none
        type(string),intent(inout) :: s
        integer,intent(in) :: un
        character(len=1) :: c
        logical :: first_iteration,continue_loop
        integer :: ReadCode
        ReadCode = 0; continue_loop = .true.
        call delete(s); first_iteration = .true.
        do while (continue_loop)
          if (ReadCode.eq.0) then
            read(un,'(A)',advance='no',iostat=ReadCode) c
            if (first_iteration) then; call init(s,c); else; call append(s,c); endif
          else; continue_loop = .false.; exit
          endif; first_iteration = .false.
        enddo
        if (s%s(s%n)%c.eq.' ') call remove_element(s,s%n)
        if (s%s(1)%c.eq.' ') call remove_element(s,1)
      end subroutine
    
      subroutine write_formatted_string(s,un)
        implicit none
        integer,intent(in) :: un
        type(string),intent(in) :: s
        write(un,'('//int2str(len(s))//'A)') str(s)
      end subroutine
    
      function int2Str(i) result(s)
        implicit none
        integer,intent(in) :: i
        character(len=15) :: s
        write(s,'(I15.15)') i
        s = trim(adjustl(s))
      end function
    
      ! **********************************************************
      ! **********************************************************
      ! **********************************************************
    
      subroutine app_string_char(st,s)
        implicit none
        type(string),intent(inout) :: st
        character(len=*),intent(in) :: s
        type(string) :: temp
        integer :: i,n
        n = len(s)
        call init(temp,st)
        call init(st,temp%n+n)
        do i=1,temp%n
          call init_copy_char(st%s(i),temp%s(i))
        enddo
        do i=1,n
          call init_char(st%s(temp%n+i),s(i:i))
        enddo
        call delete(temp)
      end subroutine
    
      subroutine app_string_string(a,b)
        implicit none
        type(string),intent(inout) :: a
        type(string),intent(in) :: b
        call append(a,str(b))
      end subroutine
    
      subroutine prep_string_char(a,b)
        implicit none
        type(string),intent(inout) :: a
        character(len=*),intent(in) :: b
        type(string) :: temp
        call init(temp,b)
        call append(temp,a)
        call init(a,temp)
        call delete(temp)
      end subroutine
    
      subroutine prep_string_string(a,b)
        implicit none
        type(string),intent(inout) :: a
        type(string),intent(in) :: b
        call prepend(a,str(b))
      end subroutine
    
      subroutine compress_string(st)
        implicit none
        type(string),intent(inout) :: st
        type(string) :: temp
        integer :: i,n_spaces,k
        if (st%n.lt.1) stop 'Error: input string must be > 1 in string.f90'
        n_spaces = 0
        do i=1,st%n
          if (st%s(i)%c.eq.' ') n_spaces = n_spaces + 1
        enddo
        if (n_spaces.ne.0) then
          if (st%n-n_spaces.lt.1) stop 'Error: only spaces in string in compress_string in string.f90'
          call init(temp,st%n-n_spaces)
          k = 0
          do i=1,st%n
            if (st%s(i)%c.ne.' ') then
              temp%s(i-k)%c = st%s(i)%c
            else; k = k+1
            endif
          enddo
          call init(st,temp)
          call delete(temp)
        endif
      end subroutine
    
      subroutine remove_element_string(st,i)
        implicit none
        type(string),intent(inout) :: st
        integer,intent(in) :: i
        type(string) :: temp
        integer :: j,k
        if (st%n.lt.1) stop 'Error: input string must be > 1 in remove_element_string in string.f90'
        if ((i.lt.1).or.(i.gt.st%n)) stop 'Error: element out of bounds in remove_element_string in string.f90'
        k = 0
        call init(temp,st%n-1)
        do j=1,st%n
          if (i.ne.j) then
            temp%s(j-k)%c = st%s(j)%c
          else; k = 1
          endif
        enddo
        call init(st,temp)
        call delete(temp)
      end subroutine
    
      function identical_string_string(A,B) result(L)
        implicit none
        type(string),intent(in) :: A,B
        logical :: L
        integer :: i
        call insist_allocated(A,'A identical_string_string')
        call insist_allocated(B,'B identical_string_string')
        L = .false.
        if (A%n.eq.B%n) then
          L = .true.
          do i=1,A%n
            if (A%s(i)%c.ne.B%s(i)%c) L = .false.
          enddo
        endif
      end function
    
      function identical_string_char(A,B) result(L)
        implicit none
        type(string),intent(in) :: A
        character(len=*),intent(in) :: B
        type(string) :: temp
        logical :: L
        call insist_allocated(A,'A identical_string_string')
        call init(temp,B)
        L = identical(A,temp)
        call delete(temp)
      end function
    
      function get_char_string(st,i) result(c)
        implicit none
        type(string),intent(in) :: st
        integer,intent(in) :: i
        character(len=1) :: c
        c = st%s(i)%c
      end function
    
      subroutine set_char_string(st,c,i)
        implicit none
        type(string),intent(inout) :: st
        integer,intent(in) :: i
        character(len=1),intent(in) :: c
        st%s(i)%c = c
      end subroutine
    
      function get_str_short(st) result(str)
        type(string),intent(in) :: st
        character(len=st%n) :: str
        str = get_str_string(st,st%n)
      end function
    
      pure function str_len_string(s) result(n)
        type(string),intent(in) :: s
        integer :: n
        n = s%n
      end function
    
      function get_str_string(st,n) result(str)
        implicit none
        type(string),intent(in) :: st
        integer,intent(in) :: n
        character(len=n) :: str
        integer :: i
        call insist_allocated(st,'get_str_string')
        if (st%n.lt.1) stop 'Error: st%n.lt.0 in get_str_string in string.f90'
        if (n.lt.1) stop 'Error: n.lt.1 in get_str_string in string.f90'
        do i=1,st%n
          str(i:i) = st%s(i)%c
        enddo
      end function
    
      function substring_in_string(str,substr) result(L)
        implicit none
        type(string),intent(in) :: str
        character(len=*),intent(in) :: substr
        logical :: L,cond
        integer :: i,j,s
        L = .false.
        s = len(substr)
        if (s.lt.1) stop 'Error: len(substr) must be > 1 in substring_in_string in string.f90'
        do i=1,len(str)-s
          cond = all((/(str%s(i+j-1:i+j-1)%c .eq. substr(j:j),j=1,s)/))
          if (cond) then
            L = .true.
            exit
          endif
        enddo
      end function
    
      function index_substring_in_string(str,substr) result(index)
        implicit none
        type(string),intent(in) :: str
        character(len=*),intent(in) :: substr
        logical :: cond
        integer :: index,i,j,s
        s = len(substr)
        cond = .false.
        index = 1
        if (s.lt.1) stop 'Error: len(substr) must be > 1 in index_substring_in_string in string.f90'
        do i=1,len(str)-s
          cond = all((/(str%s(i+j-1:i+j-1)%c .eq. substr(j:j),j=1,s)/))
          if (cond) then
            index = i
            exit
          endif
        enddo
        if (.not.cond) stop 'Error: substring not found in index_substring_in_string in string.f90'
      end function
    
      subroutine init_char(CH,c)
        implicit none
        type(char),intent(inout) :: CH
        character(len=1),intent(in) :: c
        CH%c = c
      end subroutine
    
      subroutine init_copy_char(a,b)
        implicit none
        type(char),intent(inout) :: a
        type(char),intent(in) :: b
        a%c = b%c
      end subroutine
    
      function string_allocated_string(st) result(L)
        implicit none
        type(string),intent(in) :: st
        logical :: L
        L = allocated(st%s)
      end function
    
      function valid_length(st) result(L)
        implicit none
        type(string),intent(in) :: st
        logical :: L
        L = st%n.gt.0
      end function
    
      ! function valid_string(st) result(L)
      !   implicit none
      !   type(string),intent(in) :: st
      !   logical :: L
      !   L = string_allocated(st).and.valid_length(st)
      ! end function
    
      subroutine insist_allocated_string(st,s)
        implicit none
        type(string),intent(in) :: st
        character(len=*),intent(in) :: s
        if (.not.string_allocated(st)) then
          write(*,*) 'Error: string must be allocated in '//s//' in string.f90'
          stop 'Done'
        elseif (.not.valid_length(st)) then
          write(*,*) 'Error: string must have a valid length in '//s//' in string.f90'
          stop 'Done'
        endif
      end subroutine
    
      ! --------------------------------------------------------------------------------
      ! ----------------------------- COPIED FROM IO TOOLS -----------------------------
      ! --------------------------------------------------------------------------------
    
      function open_to_read(dir,name) result(un)
        implicit none
        character(len=*),intent(in) :: dir,name
        integer :: un
        type(string) :: s
        call init(s,dir//name//dot_dat)
        un = new_unit()
        open(un,file=str(s),status = 'old',action = 'read')
        call delete(s)
      end function
    
      function new_and_open(dir,name) result(un)
        implicit none
        character(len=*),intent(in) :: dir,name
        integer :: un
        type(string) :: s
        call init(s,dir//name//dot_dat)
        un = new_unit()
        call attempt_to_open_to_write(un,s,dir,name)
        call delete(s)
      end function
    
      function new_unit() result(nu)
        implicit none
        integer,parameter :: lun_min=10,lun_max=1000
        integer :: lun,nu
        nu=-1
        do lun=lun_min,lun_max
          if (.not.unit_open(lun)) then; nu=lun; exit; endif
        enddo
      end function
    
      subroutine attempt_to_open_to_write(un,s,dir,name)
        implicit none
        integer,intent(in) :: un
        type(string),intent(in) :: s
        character(len=*),intent(in) :: dir,name
        integer :: n,i
        logical :: failed
        failed = .true.
        do n=1,100000
          open(un,file=str(s),pad='YES',action='readwrite',iostat=i)
          if (i.eq.0) then; failed = .false.; exit; endif
        enddo
        if (failed) then
          write(*,*) 'Error: tried to open file but failed!!'
          write(*,*) 'File = ',str(s)
          write(*,*) 'dir = ',dir
          write(*,*) 'name = ',name
          stop 'Done in attempt_to_open_to_write in IO_tools.f90'
        endif
      end subroutine
    
      function unit_open(un) result(op)
        implicit none
        integer,intent(in) :: un
        logical :: op
        inquire(unit=un,opened=op)
      end function
    
      ! subroutine make_dir(d)
      !   implicit none
      !   character(len=*),intent(in) :: d
      !   logical :: ex
      !   inquire (file=d, EXIST=ex)
      !   if (.not.ex) then
      !     call system('mkdir ' // d )
      !     write(*,*) 'Directory ' // d // ' created.'
      !   else
      !     write(*,*) 'Directory ' // d // ' already exists.'
      !   endif
      ! end subroutine
    
      subroutine make_dir_quiet(d)
        implicit none
        character(len=*),intent(in) :: d
        logical :: ex
        inquire (file=d, EXIST=ex)
        if (.not.ex) call system('mkdir ' // d )
      end subroutine
    
      ! --------------------------------------------------------------------------------
      ! -------------------------- COPIED FROM GENERATED CODE --------------------------
      ! --------------------------------------------------------------------------------
    
       subroutine set_IO_dir_string(this,dir)
         implicit none
         type(string),intent(inout) :: this
         character(len=*),intent(in) :: dir
         call suppress_warnings(this)
         if (.false.) then
           write(*,*) dir
         endif
       end subroutine
    
       subroutine make_IO_dir_string(this,dir)
         implicit none
         type(string),intent(inout) :: this
         character(len=*),intent(in) :: dir
         call suppress_warnings(this)
         call make_dir_quiet(dir)
       end subroutine
    
       subroutine export_structured_D_string(this,dir)
         implicit none
         type(string),intent(in) :: this
         character(len=*),intent(in) :: dir
         integer :: un
         un = new_and_open(dir,'primitives')
         call export(this,un)
         close(un)
       end subroutine
    
       subroutine import_structured_D_string(this,dir)
         implicit none
         type(string),intent(inout) :: this
         character(len=*),intent(in) :: dir
         integer :: un
         un = open_to_read(dir,'primitives')
         call import(this,un)
         close(un)
       end subroutine
    
       subroutine export_primitives_string(this,un)
         implicit none
         type(string),intent(in) :: this
         integer,intent(in) :: un
         call export(this,un)
       end subroutine
    
       subroutine import_primitives_string(this,un)
         implicit none
         type(string),intent(inout) :: this
         integer,intent(in) :: un
         call import(this,un)
       end subroutine
    
       subroutine suppress_warnings_string(this)
         implicit none
         type(string),intent(in) :: this
         if (.false.) then
           call print(this)
         endif
       end subroutine
    
      end module
    

相关问题