Actual source code: ex18f90.F90
petsc-3.12.2 2019-11-22
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 Base_module
7: #include "petsc/finclude/petscsnes.h"
8: implicit none
9: private
11: type, public :: base_type
12: PetscInt :: A ! junk
13: PetscReal :: I ! junk
14: contains
15: procedure, public :: Print => BasePrint
16: end type base_type
17: contains
18: subroutine BasePrint(this)
19: implicit none
20: class(base_type) :: this
21: print *
22: print *, 'Base printout'
23: print *
24: end subroutine BasePrint
25: end module Base_module
27: module Extended_module
28: use Base_module
29: implicit none
30: private
31: type, public, extends(base_type) :: extended_type
32: PetscInt :: B ! junk
33: PetscReal :: J ! junk
34: contains
35: procedure, public :: Print => ExtendedPrint
36: end type extended_type
37: contains
38: subroutine ExtendedPrint(this)
39: implicit none
40: class(extended_type) :: this
41: print *
42: print *, 'Extended printout'
43: print *
44: end subroutine ExtendedPrint
45: end module Extended_module
47: module Function_module
48: use petscsnes
49: implicit none
50: public :: TestFunction
51: contains
52: subroutine TestFunction(snes,xx,r,ctx,ierr)
53: use Base_module
54: implicit none
55: SNES :: snes
56: Vec :: xx
57: Vec :: r
58: class(base_type) :: ctx ! yes, this should be base_type in order to handle all
59: PetscErrorCode :: ierr ! polymorphic extensions
60: call ctx%Print()
61: end subroutine TestFunction
62: end module Function_module
64: program ex18f90
66: use Base_module
67: use Extended_module
68: use Function_module
69: implicit none
71: ! ifort on windows requires this interface definition
72: interface
73: subroutine SNESSetFunction(snes_base,x,TestFunction,base,ierr)
74: use Base_module
75: use petscsnes
76: SNES snes_base
77: Vec x
78: external TestFunction
79: class(base_type) :: base
80: PetscErrorCode ierr
81: end subroutine
82: end interface
84: PetscMPIInt :: size
85: PetscMPIInt :: rank
87: SNES :: snes_base, snes_extended
88: Vec :: x
89: class(base_type), pointer :: base
90: class(extended_type), pointer :: extended
91: PetscErrorCode :: ierr
93: print *, 'Start of Fortran2003 test program'
95: nullify(base)
96: nullify(extended)
97: allocate(base)
98: allocate(extended)
99: call PetscInitialize(PETSC_NULL_CHARACTER, ierr)
100: if (ierr .ne. 0) then
101: print*,'Unable to initialize PETSc'
102: stop
103: endif
104: call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr);CHKERRA(ierr)
105: call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr);CHKERRA(ierr)
107: call VecCreate(PETSC_COMM_WORLD,x,ierr);CHKERRA(ierr)
109: ! use the base class as the context
110: print *
111: print *, 'the base class will succeed by printing out Base printout below'
112: call SNESCreate(PETSC_COMM_WORLD,snes_base,ierr);CHKERRA(ierr)
113: call SNESSetFunction(snes_base,x,TestFunction,base,ierr);CHKERRA(ierr)
114: call SNESComputeFunction(snes_base,x,x,ierr);CHKERRA(ierr)
115: call SNESDestroy(snes_base,ierr);CHKERRA(ierr)
117: ! use the extended class as the context
118: print *, 'the extended class will succeed by printing out Extended printout below'
119: call SNESCreate(PETSC_COMM_WORLD,snes_extended,ierr);CHKERRA(ierr)
120: call SNESSetFunction(snes_extended,x,TestFunction,extended,ierr);CHKERRA(ierr)
121: call SNESComputeFunction(snes_extended,x,x,ierr);CHKERRA(ierr)
122: call VecDestroy(x,ierr);CHKERRA(ierr)
123: call SNESDestroy(snes_extended,ierr);CHKERRA(ierr)
124: if (associated(base)) deallocate(base)
125: if (associated(extended)) deallocate(extended)
126: call PetscFinalize(ierr)
128: print *, 'End of Fortran2003 test program'
130: end program ex18f90
132: !/*TEST
133: !
134: ! test:
135: ! requires: !pgf90_compiler
136: !
137: !TEST*/