在尝试实现用户派生的类型层次结构之前，我试图了解使用 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**
最佳答案
您没有做错任何事 - 您使用的英特尔 Fortran 版本有一个错误。我在当前版本 (13.1.3) 中重现了它，但在 14.0 的最新测试版中没有重现，因此看起来该错误已被修复。新版本将于 9 月初发布。
关于class - 如何在 Fortran 2003 中以多态方式解除分配？，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/8550873/