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