1c4762a1bSJed Brown! 2c4762a1bSJed Brown! Example usage of Fortran 2003/2008 classes (extended derived types) as 3c4762a1bSJed Brown! user-defined contexts in PETSc. Example contributed by Glenn Hammond. 4c4762a1bSJed Brown! 5c4762a1bSJed Brown#include "petsc/finclude/petscsnes.h" 6c5e229c2SMartin Diehlmodule ex18f90base_module 7*01fa2b5aSMartin Diehl use petscsnes 8c4762a1bSJed Brown implicit none 9c4762a1bSJed Brown private 10c4762a1bSJed Brown 11c4762a1bSJed Brown type, public :: base_type 12c4762a1bSJed Brown PetscInt :: A ! junk 13c4762a1bSJed Brown PetscReal :: I ! junk 14c4762a1bSJed Brown contains 15c4762a1bSJed Brown procedure, public :: Print => BasePrint 16c4762a1bSJed Brown end type base_type 17c4762a1bSJed Browncontains 18c4762a1bSJed Brown subroutine BasePrint(this) 19c4762a1bSJed Brown class(base_type) :: this 20c4762a1bSJed Brown print * 21c4762a1bSJed Brown print *, 'Base printout' 22c4762a1bSJed Brown print * 23c4762a1bSJed Brown end subroutine BasePrint 2477d968b7SBarry Smithend module ex18f90base_module 25c4762a1bSJed Brown 2677d968b7SBarry Smithmodule ex18f90extended_module 2777d968b7SBarry Smith use ex18f90base_module 28*01fa2b5aSMartin Diehl use petscsys 29c4762a1bSJed Brown implicit none 30c4762a1bSJed Brown private 31c4762a1bSJed Brown type, public, extends(base_type) :: extended_type 32c4762a1bSJed Brown PetscInt :: B ! junk 33c4762a1bSJed Brown PetscReal :: J ! junk 34c4762a1bSJed Brown contains 35c4762a1bSJed Brown procedure, public :: Print => ExtendedPrint 36c4762a1bSJed Brown end type extended_type 37c4762a1bSJed Browncontains 38c4762a1bSJed Brown subroutine ExtendedPrint(this) 39c4762a1bSJed Brown class(extended_type) :: this 40c4762a1bSJed Brown print * 41c4762a1bSJed Brown print *, 'Extended printout' 42c4762a1bSJed Brown print * 43c4762a1bSJed Brown end subroutine ExtendedPrint 4477d968b7SBarry Smithend module ex18f90extended_module 45c4762a1bSJed Brown 4677d968b7SBarry Smithmodule ex18f90function_module 47c4762a1bSJed Brown use petscsnes 48e7a95102SMartin Diehl use ex18f90base_module 49c4762a1bSJed Brown implicit none 50c4762a1bSJed Brown public :: TestFunction 51c4762a1bSJed Browncontains 52c4762a1bSJed Brown subroutine TestFunction(snes, xx, r, ctx, ierr) 53c4762a1bSJed Brown SNES :: snes 54c4762a1bSJed Brown Vec :: xx 55c4762a1bSJed Brown Vec :: r 56c4762a1bSJed Brown class(base_type) :: ctx ! yes, this should be base_type in order to handle all 57c4762a1bSJed Brown PetscErrorCode :: ierr ! polymorphic extensions 58c4762a1bSJed Brown call ctx%Print() 59c4762a1bSJed Brown end subroutine TestFunction 6077d968b7SBarry Smithend module ex18f90function_module 61c4762a1bSJed Brown 62c4762a1bSJed Brownprogram ex18f90 63c4762a1bSJed Brown 6477d968b7SBarry Smith use ex18f90base_module 6577d968b7SBarry Smith use ex18f90extended_module 6677d968b7SBarry Smith use ex18f90function_module 67c4762a1bSJed Brown implicit none 68c4762a1bSJed Brown 69f51a5268SBarry Smith! 70f51a5268SBarry Smith! Since class(base_type) has a bound function (method), Print, one must 71f51a5268SBarry Smith! provide an interface definition as below and use SNESSetFunctionNoInterface() 72f51a5268SBarry Smith! instead of SNESSetFunction() 73f51a5268SBarry Smith! 74c4762a1bSJed Brown interface 75f51a5268SBarry Smith subroutine SNESSetFunctionNoInterface(snes_base, x, TestFunction, base, ierr) 7677d968b7SBarry Smith use ex18f90base_module 77c4762a1bSJed Brown use petscsnes 78c4762a1bSJed Brown SNES snes_base 79c4762a1bSJed Brown Vec x 80c4762a1bSJed Brown external TestFunction 81c4762a1bSJed Brown class(base_type) :: base 82c4762a1bSJed Brown PetscErrorCode ierr 83c4762a1bSJed Brown end subroutine 84c4762a1bSJed Brown end interface 85c4762a1bSJed Brown 86c4762a1bSJed Brown PetscMPIInt :: size 87c4762a1bSJed Brown PetscMPIInt :: rank 88c4762a1bSJed Brown 89c4762a1bSJed Brown SNES :: snes_base, snes_extended 90c4762a1bSJed Brown Vec :: x 91c4762a1bSJed Brown class(base_type), pointer :: base 92c4762a1bSJed Brown class(extended_type), pointer :: extended 93c4762a1bSJed Brown PetscErrorCode :: ierr 94c4762a1bSJed Brown 95c4762a1bSJed Brown print *, 'Start of Fortran2003 test program' 96c4762a1bSJed Brown 97c4762a1bSJed Brown nullify (base) 98c4762a1bSJed Brown nullify (extended) 99c4762a1bSJed Brown allocate (base) 100c4762a1bSJed Brown allocate (extended) 101d8606c27SBarry Smith PetscCallA(PetscInitialize(ierr)) 102d8606c27SBarry Smith PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD, size, ierr)) 103d8606c27SBarry Smith PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr)) 104c4762a1bSJed Brown 105d8606c27SBarry Smith PetscCallA(VecCreate(PETSC_COMM_WORLD, x, ierr)) 106c4762a1bSJed Brown 107c4762a1bSJed Brown ! use the base class as the context 108c4762a1bSJed Brown print * 109c4762a1bSJed Brown print *, 'the base class will succeed by printing out Base printout below' 110d8606c27SBarry Smith PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_base, ierr)) 111f51a5268SBarry Smith PetscCallA(SNESSetFunctionNoInterface(snes_base, x, TestFunction, base, ierr)) 112d8606c27SBarry Smith PetscCallA(SNESComputeFunction(snes_base, x, x, ierr)) 113d8606c27SBarry Smith PetscCallA(SNESDestroy(snes_base, ierr)) 114c4762a1bSJed Brown 115c4762a1bSJed Brown ! use the extended class as the context 116c4762a1bSJed Brown print *, 'the extended class will succeed by printing out Extended printout below' 117d8606c27SBarry Smith PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_extended, ierr)) 118f51a5268SBarry Smith PetscCallA(SNESSetFunctionNoInterface(snes_extended, x, TestFunction, extended, ierr)) 119d8606c27SBarry Smith PetscCallA(SNESComputeFunction(snes_extended, x, x, ierr)) 120d8606c27SBarry Smith PetscCallA(VecDestroy(x, ierr)) 121d8606c27SBarry Smith PetscCallA(SNESDestroy(snes_extended, ierr)) 122c4762a1bSJed Brown if (associated(base)) deallocate (base) 123c4762a1bSJed Brown if (associated(extended)) deallocate (extended) 124d8606c27SBarry Smith PetscCallA(PetscFinalize(ierr)) 125c4762a1bSJed Brown 126c4762a1bSJed Brown print *, 'End of Fortran2003 test program' 127c4762a1bSJed Brownend program ex18f90 128c4762a1bSJed Brown 129c4762a1bSJed Brown!/*TEST 130c4762a1bSJed Brown! 131c4762a1bSJed Brown! build: 132dfd57a17SPierre Jolivet! requires: defined(PETSC_USING_F2003) defined(PETSC_USING_F90FREEFORM) 133c4762a1bSJed Brown! test: 134c4762a1bSJed Brown! requires: !pgf90_compiler 135c4762a1bSJed Brown! 136c4762a1bSJed Brown!TEST*/ 137