Actual source code: ex18f90.F90
1: !
2: ! Example usage of Fortran 2003/2008 classes (extended derived types) as
3: ! user-defined contexts in PETSc. Example contributed by Glenn Hammond.
4: !
5: module ex18f90base_module
6: #include "petsc/finclude/petscsnes.h"
7: implicit none
8: private
10: type, public :: base_type
11: PetscInt :: A ! junk
12: PetscReal :: I ! junk
13: contains
14: procedure, public :: Print => BasePrint
15: end type base_type
16: contains
17: subroutine BasePrint(this)
18: implicit none
19: class(base_type) :: this
20: print *
21: print *, 'Base printout'
22: print *
23: end subroutine BasePrint
24: end module ex18f90base_module
26: module ex18f90extended_module
27: use ex18f90base_module
28: implicit none
29: private
30: type, public, extends(base_type) :: extended_type
31: PetscInt :: B ! junk
32: PetscReal :: J ! junk
33: contains
34: procedure, public :: Print => ExtendedPrint
35: end type extended_type
36: contains
37: subroutine ExtendedPrint(this)
38: implicit none
39: class(extended_type) :: this
40: print *
41: print *, 'Extended printout'
42: print *
43: end subroutine ExtendedPrint
44: end module ex18f90extended_module
46: module ex18f90function_module
47: use petscsnes
48: implicit none
49: public :: TestFunction
50: contains
51: subroutine TestFunction(snes,xx,r,ctx,ierr)
52: use ex18f90base_module
53: implicit none
54: SNES :: snes
55: Vec :: xx
56: Vec :: r
57: class(base_type) :: ctx ! yes, this should be base_type in order to handle all
58: PetscErrorCode :: ierr ! polymorphic extensions
59: call ctx%Print()
60: end subroutine TestFunction
61: end module ex18f90function_module
63: program ex18f90
65: use ex18f90base_module
66: use ex18f90extended_module
67: use ex18f90function_module
68: implicit none
70: ! ifort on windows requires this interface definition
71: interface
72: subroutine SNESSetFunction(snes_base,x,TestFunction,base,ierr)
73: use ex18f90base_module
74: use petscsnes
75: SNES snes_base
76: Vec x
77: external TestFunction
78: class(base_type) :: base
79: PetscErrorCode ierr
80: end subroutine
81: end interface
83: PetscMPIInt :: size
84: PetscMPIInt :: rank
86: SNES :: snes_base, snes_extended
87: Vec :: x
88: class(base_type), pointer :: base
89: class(extended_type), pointer :: extended
90: PetscErrorCode :: ierr
92: print *, 'Start of Fortran2003 test program'
94: nullify(base)
95: nullify(extended)
96: allocate(base)
97: allocate(extended)
98: PetscCallA(PetscInitialize(ierr))
99: PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD,size,ierr))
100: PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr))
102: PetscCallA(VecCreate(PETSC_COMM_WORLD,x,ierr))
104: ! use the base class as the context
105: print *
106: print *, 'the base class will succeed by printing out Base printout below'
107: PetscCallA(SNESCreate(PETSC_COMM_WORLD,snes_base,ierr))
108: PetscCallA(SNESSetFunction(snes_base,x,TestFunction,base,ierr))
109: PetscCallA(SNESComputeFunction(snes_base,x,x,ierr))
110: PetscCallA(SNESDestroy(snes_base,ierr))
112: ! use the extended class as the context
113: print *, 'the extended class will succeed by printing out Extended printout below'
114: PetscCallA(SNESCreate(PETSC_COMM_WORLD,snes_extended,ierr))
115: PetscCallA(SNESSetFunction(snes_extended,x,TestFunction,extended,ierr))
116: PetscCallA(SNESComputeFunction(snes_extended,x,x,ierr))
117: PetscCallA(VecDestroy(x,ierr))
118: PetscCallA(SNESDestroy(snes_extended,ierr))
119: if (associated(base)) deallocate(base)
120: if (associated(extended)) deallocate(extended)
121: PetscCallA(PetscFinalize(ierr))
123: print *, 'End of Fortran2003 test program'
124: end program ex18f90
126: !/*TEST
127: !
128: ! build:
129: ! requires: defined(PETSC_USING_F2003) defined(PETSC_USING_F90FREEFORM)
130: ! test:
131: ! requires: !pgf90_compiler
132: !
133: !TEST*/