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