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" 7c5e229c2SMartin 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 class(base_type) :: this 22c4762a1bSJed Brown print * 23c4762a1bSJed Brown print *, 'Base printout' 24c4762a1bSJed Brown print * 25c4762a1bSJed Brown end subroutine BasePrint 2677d968b7SBarry Smithend module ex18f90base_module 27c4762a1bSJed Brown 2877d968b7SBarry Smithmodule ex18f90extended_module 2977d968b7SBarry Smith use ex18f90base_module 30fe66ebccSMartin Diehl use PetscSys 31c4762a1bSJed Brown implicit none 32c4762a1bSJed Brown private 33c4762a1bSJed Brown type, public, extends(base_type) :: extended_type 34c4762a1bSJed Brown PetscInt :: B ! junk 35c4762a1bSJed Brown PetscReal :: J ! junk 36c4762a1bSJed Brown contains 37c4762a1bSJed Brown procedure, public :: Print => ExtendedPrint 38c4762a1bSJed Brown end type extended_type 39c4762a1bSJed Browncontains 40c4762a1bSJed Brown subroutine ExtendedPrint(this) 41c4762a1bSJed Brown class(extended_type) :: this 42c4762a1bSJed Brown print * 43c4762a1bSJed Brown print *, 'Extended printout' 44c4762a1bSJed Brown print * 45c4762a1bSJed Brown end subroutine ExtendedPrint 4677d968b7SBarry Smithend module ex18f90extended_module 47c4762a1bSJed Brown 4877d968b7SBarry Smithmodule ex18f90function_module 49c4762a1bSJed Brown use petscsnes 50*e7a95102SMartin Diehl use ex18f90base_module 51c4762a1bSJed Brown implicit none 52c4762a1bSJed Brown public :: TestFunction 53c4762a1bSJed Browncontains 54c4762a1bSJed Brown subroutine TestFunction(snes, xx, r, ctx, ierr) 55c4762a1bSJed Brown SNES :: snes 56c4762a1bSJed Brown Vec :: xx 57c4762a1bSJed Brown Vec :: r 58c4762a1bSJed Brown class(base_type) :: ctx ! yes, this should be base_type in order to handle all 59c4762a1bSJed Brown PetscErrorCode :: ierr ! polymorphic extensions 60c4762a1bSJed Brown call ctx%Print() 61c4762a1bSJed Brown end subroutine TestFunction 6277d968b7SBarry Smithend module ex18f90function_module 63c4762a1bSJed Brown 64c4762a1bSJed Brownprogram ex18f90 65c4762a1bSJed Brown 6677d968b7SBarry Smith use ex18f90base_module 6777d968b7SBarry Smith use ex18f90extended_module 6877d968b7SBarry Smith use ex18f90function_module 69c4762a1bSJed Brown implicit none 70c4762a1bSJed Brown 71f51a5268SBarry Smith! 72f51a5268SBarry Smith! Since class(base_type) has a bound function (method), Print, one must 73f51a5268SBarry Smith! provide an interface definition as below and use SNESSetFunctionNoInterface() 74f51a5268SBarry Smith! instead of SNESSetFunction() 75f51a5268SBarry Smith! 76c4762a1bSJed Brown interface 77f51a5268SBarry Smith subroutine SNESSetFunctionNoInterface(snes_base, x, TestFunction, base, ierr) 7877d968b7SBarry Smith use ex18f90base_module 79c4762a1bSJed Brown use petscsnes 80c4762a1bSJed Brown SNES snes_base 81c4762a1bSJed Brown Vec x 82c4762a1bSJed Brown external TestFunction 83c4762a1bSJed Brown class(base_type) :: base 84c4762a1bSJed Brown PetscErrorCode ierr 85c4762a1bSJed Brown end subroutine 86c4762a1bSJed Brown end interface 87c4762a1bSJed Brown 88c4762a1bSJed Brown PetscMPIInt :: size 89c4762a1bSJed Brown PetscMPIInt :: rank 90c4762a1bSJed Brown 91c4762a1bSJed Brown SNES :: snes_base, snes_extended 92c4762a1bSJed Brown Vec :: x 93c4762a1bSJed Brown class(base_type), pointer :: base 94c4762a1bSJed Brown class(extended_type), pointer :: extended 95c4762a1bSJed Brown PetscErrorCode :: ierr 96c4762a1bSJed Brown 97c4762a1bSJed Brown print *, 'Start of Fortran2003 test program' 98c4762a1bSJed Brown 99c4762a1bSJed Brown nullify (base) 100c4762a1bSJed Brown nullify (extended) 101c4762a1bSJed Brown allocate (base) 102c4762a1bSJed Brown allocate (extended) 103d8606c27SBarry Smith PetscCallA(PetscInitialize(ierr)) 104d8606c27SBarry Smith PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD, size, ierr)) 105d8606c27SBarry Smith PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr)) 106c4762a1bSJed Brown 107d8606c27SBarry Smith PetscCallA(VecCreate(PETSC_COMM_WORLD, x, ierr)) 108c4762a1bSJed Brown 109c4762a1bSJed Brown ! use the base class as the context 110c4762a1bSJed Brown print * 111c4762a1bSJed Brown print *, 'the base class will succeed by printing out Base printout below' 112d8606c27SBarry Smith PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_base, ierr)) 113f51a5268SBarry Smith PetscCallA(SNESSetFunctionNoInterface(snes_base, x, TestFunction, base, ierr)) 114d8606c27SBarry Smith PetscCallA(SNESComputeFunction(snes_base, x, x, ierr)) 115d8606c27SBarry Smith PetscCallA(SNESDestroy(snes_base, ierr)) 116c4762a1bSJed Brown 117c4762a1bSJed Brown ! use the extended class as the context 118c4762a1bSJed Brown print *, 'the extended class will succeed by printing out Extended printout below' 119d8606c27SBarry Smith PetscCallA(SNESCreate(PETSC_COMM_WORLD, snes_extended, ierr)) 120f51a5268SBarry Smith PetscCallA(SNESSetFunctionNoInterface(snes_extended, x, TestFunction, extended, ierr)) 121d8606c27SBarry Smith PetscCallA(SNESComputeFunction(snes_extended, x, x, ierr)) 122d8606c27SBarry Smith PetscCallA(VecDestroy(x, ierr)) 123d8606c27SBarry Smith PetscCallA(SNESDestroy(snes_extended, ierr)) 124c4762a1bSJed Brown if (associated(base)) deallocate (base) 125c4762a1bSJed Brown if (associated(extended)) deallocate (extended) 126d8606c27SBarry Smith PetscCallA(PetscFinalize(ierr)) 127c4762a1bSJed Brown 128c4762a1bSJed Brown print *, 'End of Fortran2003 test program' 129c4762a1bSJed Brownend program ex18f90 130c4762a1bSJed Brown 131c4762a1bSJed Brown!/*TEST 132c4762a1bSJed Brown! 133c4762a1bSJed Brown! build: 134dfd57a17SPierre Jolivet! requires: defined(PETSC_USING_F2003) defined(PETSC_USING_F90FREEFORM) 135c4762a1bSJed Brown! test: 136c4762a1bSJed Brown! requires: !pgf90_compiler 137c4762a1bSJed Brown! 138c4762a1bSJed Brown!TEST*/ 139