1*c4762a1bSJed Brown! 2*c4762a1bSJed Brown! Example usage of Fortran 2003/2008 classes (extended derived types) as 3*c4762a1bSJed Brown! user-defined contexts in PETSc. Example contributed by Glenn Hammond. 4*c4762a1bSJed Brown! 5*c4762a1bSJed Brownmodule Base_module 6*c4762a1bSJed Brown#include "petsc/finclude/petscsnes.h" 7*c4762a1bSJed Brown implicit none 8*c4762a1bSJed Brown private 9*c4762a1bSJed Brown 10*c4762a1bSJed Brown type, public :: base_type 11*c4762a1bSJed Brown PetscInt :: A ! junk 12*c4762a1bSJed Brown PetscReal :: I ! junk 13*c4762a1bSJed Brown contains 14*c4762a1bSJed Brown procedure, public :: Print => BasePrint 15*c4762a1bSJed Brown end type base_type 16*c4762a1bSJed Browncontains 17*c4762a1bSJed Brownsubroutine BasePrint(this) 18*c4762a1bSJed Brown implicit none 19*c4762a1bSJed Brown class(base_type) :: this 20*c4762a1bSJed Brown print * 21*c4762a1bSJed Brown print *, 'Base printout' 22*c4762a1bSJed Brown print * 23*c4762a1bSJed Brownend subroutine BasePrint 24*c4762a1bSJed Brownend module Base_module 25*c4762a1bSJed Brown 26*c4762a1bSJed Brownmodule Extended_module 27*c4762a1bSJed Brown use Base_module 28*c4762a1bSJed Brown implicit none 29*c4762a1bSJed Brown private 30*c4762a1bSJed Brown type, public, extends(base_type) :: extended_type 31*c4762a1bSJed Brown PetscInt :: B ! junk 32*c4762a1bSJed Brown PetscReal :: J ! junk 33*c4762a1bSJed Brown contains 34*c4762a1bSJed Brown procedure, public :: Print => ExtendedPrint 35*c4762a1bSJed Brown end type extended_type 36*c4762a1bSJed Browncontains 37*c4762a1bSJed Brownsubroutine ExtendedPrint(this) 38*c4762a1bSJed Brown implicit none 39*c4762a1bSJed Brown class(extended_type) :: this 40*c4762a1bSJed Brown print * 41*c4762a1bSJed Brown print *, 'Extended printout' 42*c4762a1bSJed Brown print * 43*c4762a1bSJed Brownend subroutine ExtendedPrint 44*c4762a1bSJed Brownend module Extended_module 45*c4762a1bSJed Brown 46*c4762a1bSJed Brownmodule Function_module 47*c4762a1bSJed Brown use petscsnes 48*c4762a1bSJed Brown implicit none 49*c4762a1bSJed Brown public :: TestFunction 50*c4762a1bSJed Brown contains 51*c4762a1bSJed Brownsubroutine TestFunction(snes,xx,r,ctx,ierr) 52*c4762a1bSJed Brown use Base_module 53*c4762a1bSJed Brown implicit none 54*c4762a1bSJed Brown SNES :: snes 55*c4762a1bSJed Brown Vec :: xx 56*c4762a1bSJed Brown Vec :: r 57*c4762a1bSJed Brown class(base_type) :: ctx ! yes, this should be base_type in order to handle all 58*c4762a1bSJed Brown PetscErrorCode :: ierr ! polymorphic extensions 59*c4762a1bSJed Brown call ctx%Print() 60*c4762a1bSJed Brownend subroutine TestFunction 61*c4762a1bSJed Brownend module Function_module 62*c4762a1bSJed Brown 63*c4762a1bSJed Brownprogram ex18f90 64*c4762a1bSJed Brown 65*c4762a1bSJed Brown use Base_module 66*c4762a1bSJed Brown use Extended_module 67*c4762a1bSJed Brown use Function_module 68*c4762a1bSJed Brown implicit none 69*c4762a1bSJed Brown 70*c4762a1bSJed Brown! ifort on windows requires this interface definition 71*c4762a1bSJed Browninterface 72*c4762a1bSJed Brown subroutine SNESSetFunction(snes_base,x,TestFunction,base,ierr) 73*c4762a1bSJed Brown use Base_module 74*c4762a1bSJed Brown use petscsnes 75*c4762a1bSJed Brown SNES snes_base 76*c4762a1bSJed Brown Vec x 77*c4762a1bSJed Brown external TestFunction 78*c4762a1bSJed Brown class(base_type) :: base 79*c4762a1bSJed Brown PetscErrorCode ierr 80*c4762a1bSJed Brown end subroutine 81*c4762a1bSJed Brownend interface 82*c4762a1bSJed Brown 83*c4762a1bSJed Brown PetscMPIInt :: size 84*c4762a1bSJed Brown PetscMPIInt :: rank 85*c4762a1bSJed Brown 86*c4762a1bSJed Brown SNES :: snes_base, snes_extended 87*c4762a1bSJed Brown Vec :: x 88*c4762a1bSJed Brown class(base_type), pointer :: base 89*c4762a1bSJed Brown class(extended_type), pointer :: extended 90*c4762a1bSJed Brown PetscErrorCode :: ierr 91*c4762a1bSJed Brown 92*c4762a1bSJed Brown print *, 'Start of Fortran2003 test program' 93*c4762a1bSJed Brown 94*c4762a1bSJed Brown nullify(base) 95*c4762a1bSJed Brown nullify(extended) 96*c4762a1bSJed Brown allocate(base) 97*c4762a1bSJed Brown allocate(extended) 98*c4762a1bSJed Brown call PetscInitialize(PETSC_NULL_CHARACTER, ierr) 99*c4762a1bSJed Brown if (ierr .ne. 0) then 100*c4762a1bSJed Brown print*,'Unable to initialize PETSc' 101*c4762a1bSJed Brown stop 102*c4762a1bSJed Brown endif 103*c4762a1bSJed Brown call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr);CHKERRA(ierr) 104*c4762a1bSJed Brown call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr);CHKERRA(ierr) 105*c4762a1bSJed Brown 106*c4762a1bSJed Brown call VecCreate(PETSC_COMM_WORLD,x,ierr);CHKERRA(ierr) 107*c4762a1bSJed Brown 108*c4762a1bSJed Brown ! use the base class as the context 109*c4762a1bSJed Brown print * 110*c4762a1bSJed Brown print *, 'the base class will succeed by printing out Base printout below' 111*c4762a1bSJed Brown call SNESCreate(PETSC_COMM_WORLD,snes_base,ierr);CHKERRA(ierr) 112*c4762a1bSJed Brown call SNESSetFunction(snes_base,x,TestFunction,base,ierr);CHKERRA(ierr) 113*c4762a1bSJed Brown call SNESComputeFunction(snes_base,x,x,ierr);CHKERRA(ierr) 114*c4762a1bSJed Brown call SNESDestroy(snes_base,ierr);CHKERRA(ierr) 115*c4762a1bSJed Brown 116*c4762a1bSJed Brown ! use the extended class as the context 117*c4762a1bSJed Brown print *, 'the extended class will succeed by printing out Extended printout below' 118*c4762a1bSJed Brown call SNESCreate(PETSC_COMM_WORLD,snes_extended,ierr);CHKERRA(ierr) 119*c4762a1bSJed Brown call SNESSetFunction(snes_extended,x,TestFunction,extended,ierr);CHKERRA(ierr) 120*c4762a1bSJed Brown call SNESComputeFunction(snes_extended,x,x,ierr);CHKERRA(ierr) 121*c4762a1bSJed Brown call VecDestroy(x,ierr);CHKERRA(ierr) 122*c4762a1bSJed Brown call SNESDestroy(snes_extended,ierr);CHKERRA(ierr) 123*c4762a1bSJed Brown if (associated(base)) deallocate(base) 124*c4762a1bSJed Brown if (associated(extended)) deallocate(extended) 125*c4762a1bSJed Brown call PetscFinalize(ierr) 126*c4762a1bSJed Brown 127*c4762a1bSJed Brown print *, 'End of Fortran2003 test program' 128*c4762a1bSJed Brown 129*c4762a1bSJed Brownend program ex18f90 130*c4762a1bSJed Brown 131*c4762a1bSJed Brown!/*TEST 132*c4762a1bSJed Brown! 133*c4762a1bSJed Brown! build: 134*c4762a1bSJed Brown! requires: define(PETSC_USING_F2003) define(PETSC_USING_F90FREEFORM) 135*c4762a1bSJed Brown! test: 136*c4762a1bSJed Brown! requires: !pgf90_compiler 137*c4762a1bSJed Brown! 138*c4762a1bSJed Brown!TEST*/ 139