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 petscsnes 77 SNES snes_base 78 Vec x 79 external TestFunction 80 class(*) :: base 81 PetscErrorCode ierr 82 end subroutine 83 end interface 84 85 PetscMPIInt :: size 86 PetscMPIInt :: rank 87 88 SNES :: snes_base, snes_extended 89 Vec :: x 90 class(base_type), pointer :: base 91 class(extended_type), pointer :: extended 92 PetscErrorCode :: ierr 93 94 print *, 'Start of Fortran2003 test program' 95 96 nullify (base) 97 nullify (extended) 98 allocate (base) 99 allocate (extended) 100 PetscCallA(PetscInitialize(ierr)) 101 PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD, size, ierr)) 102 PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr)) 103 104 PetscCallA(VecCreate(PETSC_COMM_WORLD, x, ierr)) 105 106 ! use the base class as the context 107 print * 108 print *, 'the base class will succeed by printing out Base printout below' 109 PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_base, ierr)) 110 PetscCallA(SNESSetFunctionNoInterface(snes_base, x, TestFunction, base, ierr)) 111 PetscCallA(SNESComputeFunction(snes_base, x, x, ierr)) 112 PetscCallA(SNESDestroy(snes_base, ierr)) 113 114 ! use the extended class as the context 115 print *, 'the extended class will succeed by printing out Extended printout below' 116 PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_extended, ierr)) 117 PetscCallA(SNESSetFunctionNoInterface(snes_extended, x, TestFunction, extended, ierr)) 118 PetscCallA(SNESComputeFunction(snes_extended, x, x, ierr)) 119 PetscCallA(VecDestroy(x, ierr)) 120 PetscCallA(SNESDestroy(snes_extended, ierr)) 121 if (associated(base)) deallocate (base) 122 if (associated(extended)) deallocate (extended) 123 PetscCallA(PetscFinalize(ierr)) 124 125 print *, 'End of Fortran2003 test program' 126end program ex18f90 127 128!/*TEST 129! 130! test: 131! requires: !pgf90_compiler 132! 133!TEST*/ 134