Actual source code: bagenum.F90

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

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

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

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

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

     36:  100  continue

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

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

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