Actual source code: bagenum.F90


  2: #include "petsc/finclude/petscsys.h"

  4: #if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)
  5: !DEC$ ATTRIBUTES DLLEXPORT::PetscBagRegisterEnum
  6: #endif
  7:       Subroutine PetscBagRegisterEnum(bag,addr,FArray,def,n,h,ierr)
  8:       use,intrinsic :: iso_c_binding
  9:       use petscsys
 10:       implicit none

 12:       PetscBag   bag
 13:       character(*)                n,h
 14:       character(*)                FArray(*)
 15:       PetscEnum                   :: def
 16:       PetscErrorCode,intent(out)  :: ierr
 17:       PetscReal addr(*)

 19:       Type(C_Ptr),Dimension(:),Pointer :: CArray
 20:       character(kind=c_char),pointer   :: nullc => null()
 21:       PetscInt   :: i,Len
 22:       Character(kind=C_char,len=256),Dimension(:),Pointer::list1

 24:       do i=1,256
 25:         if (len_trim(Farray(i)) .eq. 0) then
 26:           Len = i-1
 27:           goto 100
 28:         endif
 29:         if (len_trim(Farray(i)) .gt. 255) then
 30:           PETSC_ERR_ARG_OUTOFRANGE
 31:           return
 32:         endif
 33:       enddo
 34:       PETSC_ERR_ARG_OUTOFRANGE
 35:       return

 37:  100  continue

 39:       Allocate(list1(Len),stat=ierr)
 40:       if (ierr .ne. 0) return
 41:       Allocate(CArray(Len+1),stat=ierr)
 42:       if (ierr .ne. 0) return

 44:       do i=1,Len
 45:          list1(i) = trim(FArray(i))//C_NULL_CHAR
 46:       enddo

 48:       CArray = (/(c_loc(list1(i)),i=1,Len),c_loc(nullc)/)
 49:       call PetscBagRegisterEnumPrivate(bag,addr,CArray,def,n,h,ierr)
 50:       DeAllocate(CArray)
 51:       DeAllocate(list1)
 52:       End Subroutine