class - 如何在 Fortran 2003 中以多态方式解除分配？

Question

在尝试实现用户派生的类型层次结构之前，我试图了解使用 Fortran 2003 功能的多态重新分配。理想的目标是弄清楚如何释放可能指向任何其他兼容子类型的已声明父类型指针。

如以下代码所示，文件 liboo.f90 声明了一个基类型 Parent 和一个继承类型 Child。对于标量和数组情况，这两种类型都分别具有 FINAL。文件 test_liboo.f90 使用 18 个不同的子例程尝试不同的释放。

子例程 TestParent_3_POINTER_CLASS, TestParent_7_array_POINTER_CLASS,TestChild_3_POINTER_CLASS, TestChild_7_array_POINTER_CLASS,TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents,TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents，都给出段错误。 TestParent_3_POINTER_CLASS 的错误消息如下所示。

子例程 TestPolymorph_1_Pointer_TypeForChild_ClassForParent 说 forrtl: severe (173): A pointer passed to DEALLOCATE points to an array that cannot be deallocated。

可以帮忙评论一下原因吗？

TestPolymorph_2_Pointer_ClassForChild_ClassForParent 不会给出段错误，只会调用 Child 的 Final，而 TestChild_1 等可以同时调用 Child 的 Final 和 Parent 的 Final，这应该是可取的。

我想知道如何在 Fortran 2003 中解除分配实际上包含继承类型的已声明父类型？任何见解将不胜感激!

PS:编译器为Intel Fortran Compiler，版本如下:

[root@localhost new]# ifort --version
ifort (IFORT) 12.1.0 20111011
Copyright (C) 1985-2011 Intel Corporation.  All rights reserved.

错误信息之一

[root@localhost new]# make clean
rm -rf liboo.mod liboo.o test_liboo.o test_liboo
[root@localhost new]# make
ifort -c -O0 -check -g -traceback  -openmp liboo.f90
ifort -c -O0 -check -g -traceback  -openmp test_liboo.f90
ifort -o test_liboo liboo.o test_liboo.o -static  -openmp 
[root@localhost new]# ./test_liboo
 TestParent_1 begins.
 DestroyParent
 TestParent_1 ends.

 TestParent_2_POINTER_TYPE begins.
 DestroyParent
 TestParent_2_POINTER_TYPE ends.

 TestParent_3_POINTER_CLASS begins.
 DestroyParent
forrtl: severe (174): SIGSEGV, segmentation fault occurred
Image              PC                Routine            Line        Source             
test_liboo         0000000000404B9C  Unknown               Unknown  Unknown
test_liboo         0000000000404A9F  Unknown               Unknown  Unknown
test_liboo         0000000000401ED5  test_liboo_IP_tes         140  test_liboo.f90
test_liboo         0000000000400829  MAIN__                     20  test_liboo.f90
test_liboo         00000000004002EC  Unknown               Unknown  Unknown
test_liboo         00000000004F4B90  Unknown               Unknown  Unknown
test_liboo         00000000004001B9  Unknown               Unknown  Unknown
[root@localhost new]# 

生成文件

# Compiler
 FC            = ifort
# Linker
 LINKER        = ${FC}
# Compiler flags  
 FCFLAGS       = -c -O0 -check -g -traceback 
 FCFLAGS2      = -openmp
# Linker flags
 FLFLAGS       = -static 
 FLFLAGS2      = -openmp
# Utilities
 RM            = rm -rf
 ECHO          = echo
 SHELL         = /bin/sh


# clear out all suffixes
.SUFFIXES:
# list only those we use
.SUFFIXES: .o .f90 .f


# define a suffix rule for .f90 -> .o
.f90.o:
    ${FC} ${FCFLAGS} ${FCFLAGS2} $<


# define a suffix rule for .f -> .o
.f.o:
    ${FC} ${FCFLAGS} ${FCFLAGS2} $<


#
test_liboo: liboo.o test_liboo.o
    ${LINKER} -o test_liboo liboo.o test_liboo.o ${FLFLAGS} ${FLFLAGS2} 


#
clean:
    ${RM} liboo.mod liboo.o test_liboo.o test_liboo

liboo.f90

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
    MODULE LibOO

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7** 
        TYPE :: Parent
          INTEGER :: a    
        CONTAINS
            FINAL :: DestroyParent
            FINAL :: DestroyParents
        END TYPE

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7** 
        TYPE, EXTENDS (Parent) :: child 
            INTEGER :: b
        CONTAINS
            FINAL :: DestroyChild
            FINAL :: DestroyChildren
        END TYPE

    CONTAINS

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
        SUBROUTINE DestroyParent(this)

        TYPE(Parent) :: this

        WRITE (*,*) 'DestroyParent'

        END SUBROUTINE

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
        SUBROUTINE DestroyParents(this)

        TYPE(Parent), DIMENSION(:) :: this

        WRITE (*,*) 'DestroyParents'

        END SUBROUTINE

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
        SUBROUTINE DestroyChild(this)

        TYPE(Child) :: this

        WRITE (*,*) 'DestroyChild'

        END SUBROUTINE

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
        SUBROUTINE DestroyChildren(this)

        TYPE(Child), DIMENSION(:) :: this

        WRITE (*,*) 'DestroyChildren'

        END SUBROUTINE

    END MODULE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    

test_liboo.f90

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
    PROGRAM test_liboo

    USE LibOO
    IMPLICIT NONE

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**  

    WRITE (*,*) 'TestParent_1 begins.'
    CALL TestParent_1
    WRITE (*,*) 'TestParent_1 ends.'
    READ (*,*)

    WRITE (*,*) 'TestParent_2_POINTER_TYPE begins.'
    CALL TestParent_2_POINTER_TYPE
    WRITE (*,*) 'TestParent_2_POINTER_TYPE ends.'
    READ (*,*)

    WRITE (*,*) 'TestParent_3_POINTER_CLASS begins.'
    CALL TestParent_3_POINTER_CLASS
    WRITE (*,*) 'TestParent_3_POINTER_CLASS ends.'
    READ (*,*)

    WRITE (*,*) 'TestParent_4_array begins.'
    CALL TestParent_4_array
    WRITE (*,*) 'TestParent_4_array ends.'
    READ (*,*)

    WRITE (*,*) 'TestParent_5_array_ALLOCATABLE begins.'
    CALL TestParent_5_array_ALLOCATABLE
    WRITE (*,*) 'TestParent_5_array_ALLOCATABLE ends.'
    READ (*,*)

    WRITE (*,*) 'TestParent_6_array_POINTER_TYPE begins.'
    CALL TestParent_6_array_POINTER_TYPE
    WRITE (*,*) 'TestParent_6_array_POINTER_TYPE ends.'
    READ (*,*)

    WRITE (*,*) 'TestParent_7_array_POINTER_CLASS begins.'
    CALL TestParent_7_array_POINTER_CLASS
    WRITE (*,*) 'TestParent_7_array_POINTER_CLASS ends.'
    READ (*,*)

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**  

    WRITE (*,*) 'TestChild_1 begins.'
    CALL TestChild_1
    WRITE (*,*) 'TestChild_1 ends.'
    READ (*,*)

    WRITE (*,*) 'TestChild_2_POINTER_TYPE begins.'
    CALL TestChild_2_POINTER_TYPE
    WRITE (*,*) 'TestChild_2_POINTER_TYPE ends.'
    READ (*,*)

    WRITE (*,*) 'TestChild_3_POINTER_CLASS begins.'
    CALL TestChild_3_POINTER_CLASS
    WRITE (*,*) 'TestChild_3_POINTER_CLASS ends.'
    READ (*,*)

    WRITE (*,*) 'TestChild_4_array begins.'
    CALL TestChild_4_array
    WRITE (*,*) 'TestChild_4_array ends.'
    READ (*,*)

    WRITE (*,*) 'TestChild_5_array_ALLOCATABLE begins.'
    CALL TestChild_5_array_ALLOCATABLE
    WRITE (*,*) 'TestChild_5_array_ALLOCATABLE ends.'
    READ (*,*)

    WRITE (*,*) 'TestChild_6_array_POINTER_TYPE begins.'
    CALL TestChild_6_array_POINTER_TYPE
    WRITE (*,*) 'TestChild_6_array_POINTER_TYPE ends.'
    READ (*,*)

    WRITE (*,*) 'TestChild_7_array_POINTER_CLASS begins.'
    CALL TestChild_7_array_POINTER_CLASS
    WRITE (*,*) 'TestChild_7_array_POINTER_CLASS ends.'
    READ (*,*)

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**  

    WRITE (*,*) 'TestPolymorph_1_Pointer_TypeForChild_ClassForParent begins.'
    CALL TestPolymorph_1_Pointer_TypeForChild_ClassForParent
    WRITE (*,*) 'TestPolymorph_1_Pointer_TypeForChild_ClassForParent ends.'
    READ (*,*)

    WRITE (*,*) 'TestPolymorph_2_Pointer_ClassForChild_ClassForParent begins.'
    CALL TestPolymorph_2_Pointer_ClassForChild_ClassForParent
    WRITE (*,*) 'TestPolymorph_2_Pointer_ClassForChild_ClassForParent ends.'
    READ (*,*)

    WRITE (*,*) 'TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents begins.'
    CALL TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents
    WRITE (*,*) 'TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents ends.'
    READ (*,*)

    WRITE (*,*) 'TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents begins.'
    CALL TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents
    WRITE (*,*) 'TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents ends.'
    READ (*,*)

    CONTAINS

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
    SUBROUTINE TestParent_1

    USE LibOO
    IMPLICIT NONE

    TYPE(Parent) :: myParent
    myParent%a = 6

    END SUBROUTINE TestParent_1

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
    SUBROUTINE TestParent_2_POINTER_TYPE

    USE LibOO
    IMPLICIT NONE

    TYPE(Parent), POINTER :: pMyParent

    ALLOCATE(pMyParent)
    pMyParent%a = 6
    DEALLOCATE(pMyParent)

    END SUBROUTINE TestParent_2_POINTER_TYPE

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
    SUBROUTINE TestParent_3_POINTER_CLASS

    USE LibOO
    IMPLICIT NONE

    CLASS(Parent), POINTER :: pMyParent

    ALLOCATE(pMyParent)
    pMyParent%a = 6
    DEALLOCATE(pMyParent)

    END SUBROUTINE TestParent_3_POINTER_CLASS

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
    SUBROUTINE TestParent_4_array

    USE LibOO
    IMPLICIT NONE

    TYPE(Parent), DIMENSION(3) :: myParents
    myParents(1)%a = 6

    END SUBROUTINE TestParent_4_array

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
    SUBROUTINE TestParent_5_array_ALLOCATABLE

    USE LibOO
    IMPLICIT NONE

    TYPE(Parent), DIMENSION(:), ALLOCATABLE :: myParents

    ALLOCATE(myParents(3))
    myParents(1)%a = 6
    DEALLOCATE(myParents)

    END SUBROUTINE TestParent_5_array_ALLOCATABLE

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
    SUBROUTINE TestParent_6_array_POINTER_TYPE

    USE LibOO
    IMPLICIT NONE

    TYPE(Parent), DIMENSION(:), POINTER :: pMyParents

    ALLOCATE(pMyParents(3))
    pMyParents(1)%a = 6
    DEALLOCATE(pMyParents)

    END SUBROUTINE TestParent_6_array_POINTER_TYPE

 !***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
    SUBROUTINE TestParent_7_array_POINTER_CLASS

    USE LibOO
    IMPLICIT NONE

    CLASS(Parent), DIMENSION(:), POINTER :: pMyParents

    ALLOCATE(pMyParents(3))
    pMyParents(1)%a = 6
    DEALLOCATE(pMyParents)

    END SUBROUTINE TestParent_7_array_POINTER_CLASS

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
    SUBROUTINE TestChild_1

    USE LibOO
    IMPLICIT NONE

    TYPE(child) :: myChild
    myChild%b = 6

    END SUBROUTINE TestChild_1

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
    SUBROUTINE TestChild_2_POINTER_TYPE

    USE LibOO
    IMPLICIT NONE

    TYPE(child), POINTER :: pMyChild

    ALLOCATE(pMyChild)
    pMyChild%b = 6
    DEALLOCATE(pMyChild)

    END SUBROUTINE TestChild_2_POINTER_TYPE

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
    SUBROUTINE TestChild_3_POINTER_CLASS

    USE LibOO
    IMPLICIT NONE

    CLASS(child), POINTER :: pMyChild

    ALLOCATE(pMyChild)
    pMyChild%b = 6
    DEALLOCATE(pMyChild)

    END SUBROUTINE TestChild_3_POINTER_CLASS

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
    SUBROUTINE TestChild_4_array

    USE LibOO 
    IMPLICIT NONE

    TYPE(child), DIMENSION(3) :: myChild
    myChild(1)%b = 6

    END SUBROUTINE TestChild_4_array

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
    SUBROUTINE TestChild_5_array_ALLOCATABLE

    USE LibOO
    IMPLICIT NONE

    TYPE(child), DIMENSION(:), ALLOCATABLE :: myChildren
    ALLOCATE(myChildren(3))
    myChildren(1)%b = 6
    DEALLOCATE(myChildren)

    END SUBROUTINE TestChild_5_array_ALLOCATABLE

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
    SUBROUTINE TestChild_6_array_POINTER_TYPE

    USE LibOO
    IMPLICIT NONE

    TYPE(child), DIMENSION(:), POINTER :: pMyChildren

    ALLOCATE(pMyChildren(3))
    pMyChildren(1)%b = 6
    DEALLOCATE(pMyChildren)

    END SUBROUTINE TestChild_6_array_POINTER_TYPE

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
    SUBROUTINE TestChild_7_array_POINTER_CLASS

    USE LibOO
    IMPLICIT NONE

    CLASS(child), DIMENSION(:), POINTER :: pMyChildren

    ALLOCATE(pMyChildren(3))
    pMyChildren(1)%b = 6
    DEALLOCATE(pMyChildren)

    END SUBROUTINE TestChild_7_array_POINTER_CLASS

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
    SUBROUTINE TestPolymorph_1_Pointer_TypeForChild_ClassForParent

    USE LibOO
    IMPLICIT NONE

    TYPE(child), POINTER :: pMyChild
    CLASS(parent), POINTER :: pMyParent

    ALLOCATE(pMyChild)
    pMyChild%b = 6
    pMyParent => pMyChild
    DEALLOCATE(pMyParent)

    END SUBROUTINE TestPolymorph_1_Pointer_TypeForChild_ClassForParent

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
    SUBROUTINE TestPolymorph_2_Pointer_ClassForChild_ClassForParent

    USE LibOO
    IMPLICIT NONE

    CLASS(child), POINTER :: pMyChild
    CLASS(parent), POINTER :: pMyParent

    ALLOCATE(pMyChild)
    pMyChild%b = 6
    pMyParent => pMyChild
    DEALLOCATE(pMyParent)

    END SUBROUTINE TestPolymorph_2_Pointer_ClassForChild_ClassForParent

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
    SUBROUTINE TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents

    USE LibOO
    IMPLICIT NONE

    TYPE(child), DIMENSION(:), POINTER :: pMyChildren
    CLASS(parent), DIMENSION(:), POINTER :: pMyParents

    ALLOCATE(pMyChildren(3))
    pMyChildren(1)%b = 6
    pMyParents => pMyChildren
    DEALLOCATE(pMyParents)

    END SUBROUTINE TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents

!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**    
    SUBROUTINE TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents

    USE LibOO
    IMPLICIT NONE

    CLASS(child), DIMENSION(:), POINTER :: pMyChildren
    CLASS(parent), DIMENSION(:), POINTER :: pMyParents

    ALLOCATE(pMyChildren(3))
    pMyChildren(1)%b = 6
    pMyParents => pMyChildren
    DEALLOCATE(pMyParents)

    END SUBROUTINE TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents

    END PROGRAM test_liboo
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**

Answer 1

您没有做错任何事 - 您使用的英特尔 Fortran 版本有一个错误。我在当前版本 (13.1.3) 中重现了它，但在 14.0 的最新测试版中没有重现，因此看起来该错误已被修复。新版本将于 9 月初发布。