Actual source code: ex18f90.F90
petsc-3.13.4 2020-08-01
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
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 Base_module
26: module Extended_module
27: use Base_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 Extended_module
46: module Function_module
47: use petscsnes
48: implicit none
49: public :: TestFunction
50: contains
51: subroutine TestFunction(snes,xx,r,ctx,ierr)
52: use Base_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 Function_module
63: program ex18f90
65: use Base_module
66: use Extended_module
67: use Function_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 Base_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: call PetscInitialize(PETSC_NULL_CHARACTER, ierr)
99: if (ierr .ne. 0) then
100: print*,'Unable to initialize PETSc'
101: stop
102: endif
103: call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr);CHKERRA(ierr)
104: call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr);CHKERRA(ierr)
106: call VecCreate(PETSC_COMM_WORLD,x,ierr);CHKERRA(ierr)
108: ! use the base class as the context
109: print *
110: print *, 'the base class will succeed by printing out Base printout below'
111: call SNESCreate(PETSC_COMM_WORLD,snes_base,ierr);CHKERRA(ierr)
112: call SNESSetFunction(snes_base,x,TestFunction,base,ierr);CHKERRA(ierr)
113: call SNESComputeFunction(snes_base,x,x,ierr);CHKERRA(ierr)
114: call SNESDestroy(snes_base,ierr);CHKERRA(ierr)
116: ! use the extended class as the context
117: print *, 'the extended class will succeed by printing out Extended printout below'
118: call SNESCreate(PETSC_COMM_WORLD,snes_extended,ierr);CHKERRA(ierr)
119: call SNESSetFunction(snes_extended,x,TestFunction,extended,ierr);CHKERRA(ierr)
120: call SNESComputeFunction(snes_extended,x,x,ierr);CHKERRA(ierr)
121: call VecDestroy(x,ierr);CHKERRA(ierr)
122: call SNESDestroy(snes_extended,ierr);CHKERRA(ierr)
123: if (associated(base)) deallocate(base)
124: if (associated(extended)) deallocate(extended)
125: call PetscFinalize(ierr)
127: print *, 'End of Fortran2003 test program'
129: end program ex18f90
131: !/*TEST
132: !
133: ! build:
134: ! requires: define(PETSC_USING_F2003) define(PETSC_USING_F90FREEFORM)
135: ! test:
136: ! requires: !pgf90_compiler
137: !
138: !TEST*/