Actual source code: bagenum.F

petsc-3.3-p5 2012-12-01
  2: #include "finclude/petscdef.h"

  4:       Subroutine PetscBagRegisterEnum(bag,addr,FArray,def,n,h,ierr)
  5:       use,intrinsic :: iso_c_binding
  6:       implicit none

  8:       PetscBag   bag
  9:       character(*)                n,h
 10:       character(*)                FArray(*)
 11:       PetscEnum                   :: def
 12:       PetscErrorCode,intent(out)  :: ierr
 13:       PetscReal addr(*)

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

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

 33:  100  continue

 35:       Allocate(list1(Len),stat=ierr);
 36:       Allocate(CArray(Len+1),stat=ierr)
 37:       do i=1,Len
 38:          list1(i) = trim(FArray(i))//C_NULL_CHAR
 39:       enddo

 41:       CArray = (/(c_loc(list1(i)),i=1,Len),c_loc(nullc)/)
 42:       call PetscBagRegisterEnumPrivate(bag,addr,CArray,def,n,h,ierr)
 43:       DeAllocate(CArray)
 44:       DeAllocate(list1)
 45:       End Subroutine