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