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