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