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