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#include <petsc/finclude/petscsys.h> 6#include "petsc/finclude/petscsnes.h" 7module ex18f90base_module 8 use PetscSys 9 use PetscSnes 10 implicit none 11 private 12 13 type, public :: base_type 14 PetscInt :: A ! junk 15 PetscReal :: I ! junk 16 contains 17 procedure, public :: Print => BasePrint 18 end type base_type 19contains 20 subroutine BasePrint(this) 21 implicit none 22 class(base_type) :: this 23 print * 24 print *, 'Base printout' 25 print * 26 end subroutine BasePrint 27end module ex18f90base_module 28 29module ex18f90extended_module 30 use ex18f90base_module 31 use PetscSys 32 implicit none 33 private 34 type, public, extends(base_type) :: extended_type 35 PetscInt :: B ! junk 36 PetscReal :: J ! junk 37 contains 38 procedure, public :: Print => ExtendedPrint 39 end type extended_type 40contains 41 subroutine ExtendedPrint(this) 42 implicit none 43 class(extended_type) :: this 44 print * 45 print *, 'Extended printout' 46 print * 47 end subroutine ExtendedPrint 48end module ex18f90extended_module 49 50module ex18f90function_module 51 use petscsnes 52 implicit none 53 public :: TestFunction 54contains 55 subroutine TestFunction(snes, xx, r, ctx, ierr) 56 use ex18f90base_module 57 implicit none 58 SNES :: snes 59 Vec :: xx 60 Vec :: r 61 class(base_type) :: ctx ! yes, this should be base_type in order to handle all 62 PetscErrorCode :: ierr ! polymorphic extensions 63 call ctx%Print() 64 end subroutine TestFunction 65end module ex18f90function_module 66 67program ex18f90 68 69 use ex18f90base_module 70 use ex18f90extended_module 71 use ex18f90function_module 72 implicit none 73 74! 75! Since class(base_type) has a bound function (method), Print, one must 76! provide an interface definition as below and use SNESSetFunctionNoInterface() 77! instead of SNESSetFunction() 78! 79 interface 80 subroutine SNESSetFunctionNoInterface(snes_base, x, TestFunction, base, ierr) 81 use ex18f90base_module 82 use petscsnes 83 SNES snes_base 84 Vec x 85 external TestFunction 86 class(base_type) :: base 87 PetscErrorCode ierr 88 end subroutine 89 end interface 90 91 PetscMPIInt :: size 92 PetscMPIInt :: rank 93 94 SNES :: snes_base, snes_extended 95 Vec :: x 96 class(base_type), pointer :: base 97 class(extended_type), pointer :: extended 98 PetscErrorCode :: ierr 99 100 print *, 'Start of Fortran2003 test program' 101 102 nullify (base) 103 nullify (extended) 104 allocate (base) 105 allocate (extended) 106 PetscCallA(PetscInitialize(ierr)) 107 PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD, size, ierr)) 108 PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr)) 109 110 PetscCallA(VecCreate(PETSC_COMM_WORLD, x, ierr)) 111 112 ! use the base class as the context 113 print * 114 print *, 'the base class will succeed by printing out Base printout below' 115 PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_base, ierr)) 116 PetscCallA(SNESSetFunctionNoInterface(snes_base, x, TestFunction, base, ierr)) 117 PetscCallA(SNESComputeFunction(snes_base, x, x, ierr)) 118 PetscCallA(SNESDestroy(snes_base, ierr)) 119 120 ! use the extended class as the context 121 print *, 'the extended class will succeed by printing out Extended printout below' 122 PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_extended, ierr)) 123 PetscCallA(SNESSetFunctionNoInterface(snes_extended, x, TestFunction, extended, ierr)) 124 PetscCallA(SNESComputeFunction(snes_extended, x, x, ierr)) 125 PetscCallA(VecDestroy(x, ierr)) 126 PetscCallA(SNESDestroy(snes_extended, ierr)) 127 if (associated(base)) deallocate (base) 128 if (associated(extended)) deallocate (extended) 129 PetscCallA(PetscFinalize(ierr)) 130 131 print *, 'End of Fortran2003 test program' 132end program ex18f90 133 134!/*TEST 135! 136! build: 137! requires: defined(PETSC_USING_F2003) defined(PETSC_USING_F90FREEFORM) 138! test: 139! requires: !pgf90_compiler 140! 141!TEST*/ 142