shapelib.F90

!    Copyright 2011 Davide Cesari <dcesari69 at gmail dot com>
!
!    This file is part of FortranGIS.
!
!    FortranGIS is free software: you can redistribute it and/or modify
!    it under the terms of the GNU Lesser General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    FortranGIS is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Lesser General Public License for more details.
!
!    You should have received a copy of the GNU Lesser General Public
!    License along with FortranGIS.  If not, see
!    <http://www.gnu.org/licenses/>.

MODULE shapelib
use,INTRINSIC :: iso_c_binding
USE fortranc
IMPLICIT NONE

INTEGER,PARAMETER :: shpt_null = 0
INTEGER,PARAMETER :: shpt_point = 1
INTEGER,PARAMETER :: shpt_arc = 3
INTEGER,PARAMETER :: shpt_polygon = 5
INTEGER,PARAMETER :: shpt_multipoint = 8
INTEGER,PARAMETER :: shpt_pointz = 11
INTEGER,PARAMETER :: shpt_arcz = 13
INTEGER,PARAMETER :: shpt_polygonz = 15
INTEGER,PARAMETER :: shpt_multipointz = 18
INTEGER,PARAMETER :: shpt_pointm = 21
INTEGER,PARAMETER :: shpt_arcm = 23
INTEGER,PARAMETER :: shpt_polygonm = 25
INTEGER,PARAMETER :: shpt_multipointm = 28

INTEGER,PARAMETER :: shpt_multipatch = 31

INTEGER,PARAMETER :: ftstring = 0
INTEGER,PARAMETER :: ftinteger = 1
INTEGER,PARAMETER :: ftdouble = 2
INTEGER,PARAMETER :: ftlogical = 3
INTEGER,PARAMETER :: ftinvalid = 4


TYPE shpfileobject
  PRIVATE
  TYPE(c_ptr) :: shpfile_orig=c_null_ptr
  TYPE(c_ptr) :: dbffile_orig=c_null_ptr
END TYPE shpfileobject


TYPE shpobject
  TYPE(c_ptr) :: shpobject_orig=c_null_ptr 
  INTEGER :: nshptype=0
  INTEGER :: nshapeid=-1
  INTEGER :: nparts=0
  INTEGER,POINTER :: panpartstart(:)=>null() 
  INTEGER,POINTER :: panparttype(:)=>null() 
  INTEGER :: nvertices
  REAL(kind=c_double),POINTER :: padfx(:)=>null() 
  REAL(kind=c_double),POINTER :: padfy(:)=>null() 
  REAL(kind=c_double),POINTER :: padfz(:)=>null() 
  REAL(kind=c_double),POINTER :: padfm(:)=>null() 
  REAL(kind=c_double) :: dfxmin=0.0_c_double 
  REAL(kind=c_double) :: dfymin=0.0_c_double 
  REAL(kind=c_double) :: dfzmin=0.0_c_double 
  REAL(kind=c_double) :: dfmmin=0.0_c_double 
  REAL(kind=c_double) :: dfxmax=0.0_c_double 
  REAL(kind=c_double) :: dfymax=0.0_c_double 
  REAL(kind=c_double) :: dfzmax=0.0_c_double 
  REAL(kind=c_double) :: dfmmax=0.0_c_double 
END TYPE shpobject

!TYPE(shpfileobject),PARAMETER :: shpfileobject_null = shpfileobject(0, 0)
TYPE(shpobject),PARAMETER :: shpobject_null = shpobject(c_null_ptr, &
 0, -1, 0, &
 null(), null(), 0, null(), null(), null(), null(), &
 0.0_c_double, 0.0_c_double, 0.0_c_double, 0.0_c_double, &
 0.0_c_double, 0.0_c_double, 0.0_c_double, 0.0_c_double)

INTERFACE dbfreadattribute
  MODULE PROCEDURE dbfreadintegerattribute_f, dbfreaddoubleattribute_f, &
   dbfreadstringattribute_f
END INTERFACE


INTERFACE dbfwriteattribute
  MODULE PROCEDURE dbfwriteintegerattribute_f, dbfwritedoubleattribute_f, &
   dbfwritestringattribute_f, dbfwritenullattribute_f
END INTERFACE


INTERFACE
  FUNCTION shpopen_orig(pszlayer, pszaccess) BIND(C,name='SHPOpen')
  import
  CHARACTER(kind=c_char) :: pszlayer(*)
  CHARACTER(kind=c_char) :: pszaccess(*)
  TYPE(c_ptr) :: shpopen_orig
  END FUNCTION shpopen_orig

  SUBROUTINE shpclose_orig(psshp) BIND(C,name='SHPClose')
  import
  TYPE(c_ptr),VALUE :: psshp
  END SUBROUTINE shpclose_orig

  SUBROUTINE shpgetinfo_orig(psshp, pnentities, pnshapetype, padfminbound, padfmaxbound) BIND(C,name='SHPGetInfo')
  import
  TYPE(c_ptr),VALUE :: psshp
  INTEGER(kind=c_int) :: pnentities
  INTEGER(kind=c_int) :: pnshapetype
  REAL(kind=c_double) :: padfminbound(*)
  REAL(kind=c_double) :: padfmaxbound(*)
  END SUBROUTINE shpgetinfo_orig

  FUNCTION shpcreate_orig(pszlayer, nshapetype) BIND(C,name='SHPCreate')
  import
  CHARACTER(kind=c_char) :: pszlayer(*)
  INTEGER(kind=c_int),VALUE :: nshapetype
  TYPE(c_ptr) :: shpcreate_orig
  END FUNCTION shpcreate_orig

  SUBROUTINE shpcomputeextents_int(psobject, ftnobject) BIND(C,name='SHPComputeExtentsInt')
  import
  TYPE(c_ptr),VALUE :: psobject
  TYPE(c_ptr),VALUE :: ftnobject
  END SUBROUTINE shpcomputeextents_int

  FUNCTION shpcreateobject_int(nshptype, nshapeid, nparts, panpartstart, panparttype, &
   nvertices, padfx, padfy, padfz, padfm, ftnobject) bind(c,name='SHPCreateObjectInt')
  import
  INTEGER(kind=c_int),VALUE :: nshptype
  INTEGER(kind=c_int),VALUE :: nshapeid
  INTEGER(kind=c_int),VALUE :: nparts
  INTEGER(kind=c_int) :: panpartstart(*)
  INTEGER(kind=c_int) :: panparttype(*)
  INTEGER(kind=c_int),VALUE :: nvertices
  REAL(kind=c_double) :: padfx(*)
  REAL(kind=c_double) :: padfy(*)
  REAL(kind=c_double) :: padfz(*)
  REAL(kind=c_double) :: padfm(*)
  TYPE(c_ptr),VALUE :: ftnobject
  INTEGER(kind=c_int) :: shpcreateobject_int
  END FUNCTION shpcreateobject_int

  FUNCTION shpcreatesimpleobject_int(nshptype, nvertices, padfx, padfy, padfz, ftnobject) BIND(C,name='SHPCreateSimpleObjectInt')
  import
  INTEGER(kind=c_int),VALUE :: nshptype
  INTEGER(kind=c_int),VALUE :: nvertices
  REAL(kind=c_double) :: padfx(*)
  REAL(kind=c_double) :: padfy(*)
  REAL(kind=c_double) :: padfz(*)
  TYPE(c_ptr),VALUE :: ftnobject
  INTEGER(kind=c_int) :: shpcreatesimpleobject_int
  END FUNCTION shpcreatesimpleobject_int

  FUNCTION shpwriteobject_orig(psshp, nshapeid, psobject) BIND(C,name='SHPWriteObject')
  import
  TYPE(c_ptr),VALUE :: psshp
  INTEGER(kind=c_int),VALUE :: nshapeid
  TYPE(c_ptr),VALUE :: psobject
  INTEGER(kind=c_int) :: shpwriteobject_orig
  END FUNCTION shpwriteobject_orig

  FUNCTION shpreadobject_int(psshp, hentity, ftnobject) BIND(C,name='SHPReadObjectInt')
  import
  TYPE(c_ptr),VALUE :: psshp
  INTEGER(kind=c_int),VALUE :: hentity
  TYPE(c_ptr),VALUE :: ftnobject
  INTEGER(kind=c_int) :: shpreadobject_int
  END FUNCTION shpreadobject_int

  SUBROUTINE shpdestroyobject_orig(psshape) BIND(C,name='SHPDestroyObject')
  import
  TYPE(c_ptr),VALUE :: psshape
  END SUBROUTINE shpdestroyobject_orig

#ifndef SHAPELIB_PRE10
  FUNCTION shprewindobject_int(hshp, psobject, ftnobject) BIND(C,name='SHPRewindObjectInt')
  import
  TYPE(c_ptr),VALUE :: hshp
  TYPE(c_ptr),VALUE :: psobject
  TYPE(c_ptr),VALUE :: ftnobject
  INTEGER(kind=c_int) :: shprewindobject_int
  END FUNCTION shprewindobject_int
#endif
END INTERFACE

INTERFACE
  FUNCTION dbfopen(pszfilename, pszaccess) BIND(C,name='DBFOpen')
  import
  CHARACTER(kind=c_char) :: pszfilename(*)
  CHARACTER(kind=c_char) :: pszaccess(*)
  TYPE(c_ptr) :: dbfopen
  END FUNCTION dbfopen

  SUBROUTINE dbfclose(psdbf) BIND(C,name='DBFClose')
  import
  TYPE(c_ptr),VALUE :: psdbf
  END SUBROUTINE dbfclose

  FUNCTION dbfcreate(pszfilename) BIND(C,name='DBFCreate')
  import
  CHARACTER(kind=c_char) :: pszfilename(*)
  TYPE(c_ptr) :: dbfcreate
  END FUNCTION dbfcreate

  FUNCTION dbfaddfield_orig(psdbf, pszfieldname, etype, nwidth, ndecimals) BIND(C,name='DBFAddField')
  import
  TYPE(c_ptr),VALUE :: psdbf
  CHARACTER(kind=c_char) :: pszfieldname(*)
  INTEGER(kind=c_int),VALUE :: etype
  INTEGER(kind=c_int),VALUE :: nwidth
  INTEGER(kind=c_int),VALUE :: ndecimals
  INTEGER(kind=c_int) :: dbfaddfield_orig
  END FUNCTION dbfaddfield_orig

  FUNCTION dbfreadintegerattribute_orig(psdbf, irecord, ifield) BIND(C,name='DBFReadIntegerAttribute')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  INTEGER(kind=c_int) :: dbfreadintegerattribute_orig
  END FUNCTION dbfreadintegerattribute_orig

  FUNCTION dbfreaddoubleattribute_orig(psdbf, irecord, ifield) BIND(C,name='DBFReadDoubleAttribute')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  REAL(kind=c_double) :: dbfreaddoubleattribute_orig
  END FUNCTION dbfreaddoubleattribute_orig

  FUNCTION dbfreadstringattribute_orig(psdbf, irecord, ifield) BIND(C,name='DBFReadStringAttribute')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  TYPE(c_ptr) :: dbfreadstringattribute_orig
  END FUNCTION dbfreadstringattribute_orig

  SUBROUTINE dbfreadstringattribute_int(psdbf, irecord, ifield, attr, lattr) BIND(C,name='DBFReadStringAttributeInt')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  CHARACTER(kind=c_char) :: attr(*)
  INTEGER(kind=c_int),VALUE :: lattr
  END SUBROUTINE dbfreadstringattribute_int

  FUNCTION dbfreadlogicalattribute(psdbf, irecord, ifield) BIND(C,name='DBFReadLogicalAttribute')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  CHARACTER(kind=c_char) :: dbfreadlogicalattribute
  END FUNCTION dbfreadlogicalattribute

#ifndef SHAPELIB_PRE10
  FUNCTION dbfisattributenull_orig(psdbf, irecord, ifield) BIND(C,name='DBFIsAttributeNULL')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  INTEGER(kind=c_int) :: dbfisattributenull_orig
  END FUNCTION dbfisattributenull_orig
#endif

  FUNCTION dbfgetfieldcount(psdbf) BIND(C,name='DBFGetFieldCount')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int) :: dbfgetfieldcount
  END FUNCTION dbfgetfieldcount

  FUNCTION dbfgetrecordcount(psdbf) BIND(C,name='DBFGetRecordCount')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int) :: dbfgetrecordcount
  END FUNCTION dbfgetrecordcount

  FUNCTION dbfgetfieldinfo_orig(psdbf, ifield, pszfieldname, pnwidth, pndecimals) BIND(C,name='DBFGetFieldInfo')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: ifield
  CHARACTER(kind=c_char) :: pszfieldname(*)
  INTEGER(kind=c_int) :: pnwidth
  INTEGER(kind=c_int) :: pndecimals
  INTEGER(kind=c_int) :: dbfgetfieldinfo_orig
  END FUNCTION dbfgetfieldinfo_orig

  FUNCTION dbfwritedoubleattribute(psdbf, irecord, ifield, dvalue) BIND(C,name='DBFWriteDoubleAttribute')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  REAL(kind=c_double),VALUE :: dvalue
  INTEGER(kind=c_int) :: dbfwritedoubleattribute
  END FUNCTION dbfwritedoubleattribute

  FUNCTION dbfwriteintegerattribute(psdbf, irecord, ifield, nvalue) BIND(C,name='DBFWriteIntegerAttribute')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  INTEGER(kind=c_int),VALUE :: nvalue
  INTEGER(kind=c_int) :: dbfwriteintegerattribute
  END FUNCTION dbfwriteintegerattribute

  FUNCTION dbfwritestringattribute(psdbf, irecord, ifield, pszvalue) BIND(C,name='DBFWriteStringAttribute')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  CHARACTER(kind=c_char) :: pszvalue(*)
  INTEGER(kind=c_int) :: dbfwritestringattribute
  END FUNCTION dbfwritestringattribute

  FUNCTION dbfwritenullattribute(psdbf, irecord, ifield) BIND(C,name='DBFWriteNULLAttribute')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  INTEGER(kind=c_int) :: dbfwritenullattribute
  END FUNCTION dbfwritenullattribute

  FUNCTION dbfwritelogicalattribute(psdbf, irecord, ifield, lvalue) BIND(C,name='DBFWriteLogicalAttribute')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: irecord
  INTEGER(kind=c_int),VALUE :: ifield
  CHARACTER(kind=c_char),VALUE :: lvalue
  INTEGER(kind=c_int) :: dbfwritelogicalattribute
  END FUNCTION dbfwritelogicalattribute

#ifndef SHAPELIB_PRE10
  FUNCTION dbfgetnativefieldtype_orig(psdbf, ifield) BIND(C,name='DBFGetNativeFieldType')
  import
  TYPE(c_ptr),VALUE :: psdbf
  INTEGER(kind=c_int),VALUE :: ifield
  INTEGER(kind=c_signed_char) :: dbfgetnativefieldtype_orig
  END FUNCTION dbfgetnativefieldtype_orig

  FUNCTION dbfgetfieldindex_orig(psdbf, pszfieldname) BIND(C,name='DBFGetFieldIndex')
  import
  TYPE(c_ptr),VALUE :: psdbf
  CHARACTER(kind=c_char) :: pszfieldname(*)
  INTEGER(kind=c_int) :: dbfgetfieldindex_orig
  END FUNCTION dbfgetfieldindex_orig
#endif

END INTERFACE

PRIVATE
PUBLIC shpt_null, shpt_point, shpt_arc, shpt_polygon, shpt_multipoint, &
 shpt_pointz, shpt_arcz, shpt_polygonz, shpt_multipointz, shpt_pointm, &
 shpt_arcm, shpt_polygonm, shpt_multipointm, shpt_multipatch, &
 ftstring, ftinteger, ftdouble, ftlogical, ftinvalid
PUBLIC shpfileobject, shpobject
PUBLIC dbfreadattribute, dbfwriteattribute
PUBLIC shpopen, shpfileisnull, dbffileisnull, shpcreate, shpgetinfo, &
 shpreadobject, shpisnull, shpclose, shpcreatesimpleobject, shpcreateobject, &
 shpcomputeextents, shpwriteobject, shpdestroyobject, &
 dbfgetfieldindex, dbfgetfieldinfo, dbfaddfield, dbfisattributenull, &
 dbfgetnativefieldtype

CONTAINS


FUNCTION shpopen(pszshapefile, pszaccess)
CHARACTER(len=*),INTENT(in) :: pszshapefile
CHARACTER(len=*),INTENT(in) :: pszaccess
TYPE(shpfileobject) :: shpopen

shpopen%shpfile_orig = shpopen_orig(fchartrimtostr(pszshapefile), fchartrimtostr(pszaccess))
shpopen%dbffile_orig = dbfopen(fchartrimtostr(pszshapefile), fchartrimtostr(pszaccess))

END FUNCTION shpopen


FUNCTION shpfileisnull(hshp) RESULT(isnull)
TYPE(shpfileobject),INTENT(in) :: hshp
LOGICAL :: isnull

isnull = .NOT.c_associated(hshp%shpfile_orig)

END FUNCTION shpfileisnull


FUNCTION dbffileisnull(hshp) RESULT(isnull)
TYPE(shpfileobject),INTENT(in) :: hshp
LOGICAL :: isnull

isnull = .NOT.c_associated(hshp%dbffile_orig)

END FUNCTION dbffileisnull


FUNCTION shpcreate(pszshapefile, nshapetype)
CHARACTER(len=*),INTENT(in) :: pszshapefile
INTEGER,INTENT(in) :: nshapetype
TYPE(shpfileobject) :: shpcreate

shpcreate%shpfile_orig = shpcreate_orig(fchartrimtostr(pszshapefile), nshapetype)
shpcreate%dbffile_orig = dbfcreate(fchartrimtostr(pszshapefile))

END FUNCTION shpcreate


SUBROUTINE shpgetinfo(hshp, nentities, shapetype, minbound, maxbound, &
 dbffieldcount, dbfrecordcount)
TYPE(shpfileobject),INTENT(in) :: hshp
INTEGER,INTENT(out) :: nentities
INTEGER,INTENT(out) :: shapetype
REAL(kind=c_double),INTENT(out) :: minbound(4)
REAL(kind=c_double),INTENT(out) :: maxbound(4)
INTEGER,INTENT(out) :: dbffieldcount
INTEGER,INTENT(out) :: dbfrecordcount

IF (.NOT.shpfileisnull(hshp)) THEN
  CALL shpgetinfo_orig(hshp%shpfile_orig, nentities, shapetype, minbound, maxbound)
ELSE
  nentities = 0
  shapetype = 0
  minbound(:) = 0.0d0
  maxbound(:) = 0.0d0
ENDIF
IF (.NOT.dbffileisnull(hshp)) THEN
  dbffieldcount = dbfgetfieldcount(hshp%dbffile_orig)
  dbfrecordcount = dbfgetrecordcount(hshp%dbffile_orig)
ELSE
  dbffieldcount = 0
  dbfrecordcount = 0
ENDIF

END SUBROUTINE shpgetinfo


FUNCTION shpreadobject(hshp, ishape)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER :: ishape
TYPE(shpobject),TARGET :: shpreadobject

TYPE(shpobject) :: lshpobject

INTEGER :: ier

IF (.NOT.shpfileisnull(hshp)) THEN
  ier = shpreadobject_int(hshp%shpfile_orig, ishape, c_loc(shpreadobject))
ELSE ! initialize to empty
  shpreadobject = shpobject_null
ENDIF

END FUNCTION shpreadobject


FUNCTION shpisnull(psobject) RESULT(isnull)
TYPE(shpobject),INTENT(in) :: psobject
LOGICAL :: isnull

isnull = .NOT.c_associated(psobject%shpobject_orig)

END FUNCTION shpisnull


SUBROUTINE shpclose(hshp)
TYPE(shpfileobject),INTENT(inout) :: hshp

IF (.NOT.shpfileisnull(hshp)) THEN
  CALL shpclose_orig(hshp%shpfile_orig)
  hshp%shpfile_orig = c_null_ptr
ENDIF
IF (.NOT.dbffileisnull(hshp)) THEN
  CALL dbfclose(hshp%dbffile_orig)
  hshp%dbffile_orig = c_null_ptr
ENDIF

END SUBROUTINE shpclose


FUNCTION shpcreatesimpleobject(nshptype, nvertices, padfx, padfy, padfz)
INTEGER :: nshptype
INTEGER :: nvertices
REAL(kind=c_double) :: padfx(nvertices)
REAL(kind=c_double) :: padfy(nvertices)
REAL(kind=c_double),OPTIONAL :: padfz(nvertices)
TYPE(shpobject),TARGET :: shpcreatesimpleobject

TYPE(shpobject) :: lshpobject

IF (shpcreatesimpleobject_int(nshptype, nvertices, padfx, padfy, padfz, &
 c_loc(shpcreatesimpleobject)) /= 0) THEN
  shpcreatesimpleobject = shpobject_null
ENDIF

END FUNCTION shpcreatesimpleobject


FUNCTION shpcreateobject(nshptype, ishape, nparts, panpartstart, panparttype, &
 nvertices, padfx, padfy, padfz, padfm)
INTEGER :: nshptype
INTEGER :: ishape
INTEGER :: nparts
INTEGER :: nvertices
INTEGER :: panpartstart(nparts)
INTEGER :: panparttype(nparts)
REAL(kind=c_double) :: padfx(nvertices)
REAL(kind=c_double) :: padfy(nvertices)
REAL(kind=c_double),OPTIONAL :: padfz(nvertices)
REAL(kind=c_double),OPTIONAL :: padfm(nvertices)
TYPE(shpobject),TARGET :: shpcreateobject

TYPE(shpobject) :: lshpobject

IF (shpcreateobject_int(nshptype, ishape, nparts, panpartstart, panparttype, &
 nvertices, padfx, padfy, padfz, padfm, c_loc(shpcreateobject)) /= 0) THEN
  shpcreateobject = shpobject_null
ENDIF

END FUNCTION shpcreateobject


SUBROUTINE shpcomputeextents(psobject)
TYPE(shpobject),TARGET :: psobject

CALL shpcomputeextents_int(psobject%shpobject_orig, c_loc(psobject))

END SUBROUTINE shpcomputeextents


FUNCTION shpwriteobject(hshp, ishape, psobject)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER :: ishape
TYPE(shpobject) :: psobject
INTEGER :: shpwriteobject

IF (.NOT.shpfileisnull(hshp)) THEN
  shpwriteobject = shpwriteobject_orig(hshp%shpfile_orig, ishape, psobject%shpobject_orig)
ELSE
  shpwriteobject = 0
ENDIF

END FUNCTION shpwriteobject


SUBROUTINE shpdestroyobject(psobject)
TYPE(shpobject) :: psobject

IF (c_associated(psobject%shpobject_orig)) THEN
  CALL shpdestroyobject_orig(psobject%shpobject_orig)
ENDIF
psobject = shpobject_null

END SUBROUTINE shpdestroyobject


#ifndef SHAPELIB_PRE10

FUNCTION shprewindobject(hshp, psobject)
TYPE(shpfileobject),INTENT(inout) :: hshp
TYPE(shpobject),INTENT(inout),TARGET :: psobject
LOGICAL :: shprewindobject

INTEGER :: ier

ier = shprewindobject_int(hshp%shpfile_orig, psobject%shpobject_orig, &
 c_loc(psobject))
IF (ier == 0) THEN
  shprewindobject = .false.
ELSE
  shprewindobject = .true.
ENDIF

END FUNCTION shprewindobject


FUNCTION dbfgetfieldindex(hshp, pszfieldname)
TYPE(shpfileobject),INTENT(in) :: hshp
CHARACTER(len=*),INTENT(in) :: pszfieldname
INTEGER :: dbfgetfieldindex

IF (.NOT.dbffileisnull(hshp)) THEN
  dbfgetfieldindex = dbfgetfieldindex_orig(hshp%dbffile_orig, fchartrimtostr(pszfieldname))
ELSE
  dbfgetfieldindex = -1
ENDIF

END FUNCTION dbfgetfieldindex
#endif


FUNCTION dbfgetfieldinfo(hshp, ifield, pszfieldname, pnwidth, pndecimals)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER,INTENT(in) :: ifield
CHARACTER(len=*),INTENT(out) :: pszfieldname
INTEGER,INTENT(out) :: pnwidth
INTEGER,INTENT(out) :: pndecimals
INTEGER :: dbfgetfieldinfo

CHARACTER(len=11) :: lpszfieldname

IF (.NOT.dbffileisnull(hshp)) THEN
  dbfgetfieldinfo = dbfgetfieldinfo_orig(hshp%dbffile_orig, ifield, &
   lpszfieldname, pnwidth, pndecimals)
  pszfieldname = lpszfieldname ! must strip null here!
ELSE
  dbfgetfieldinfo = -1
ENDIF

END FUNCTION dbfgetfieldinfo


FUNCTION dbfaddfield(hshp, pszfieldname, etype, nwidth, ndecimals)
TYPE(shpfileobject),INTENT(inout) :: hshp
CHARACTER(len=*),INTENT(in) :: pszfieldname
INTEGER,INTENT(in) :: etype
INTEGER,INTENT(in) :: nwidth
INTEGER,INTENT(in) :: ndecimals
INTEGER :: dbfaddfield

IF (.NOT.dbffileisnull(hshp)) THEN
  dbfaddfield = dbfaddfield_orig(hshp%dbffile_orig, fchartrimtostr(pszfieldname), &
   etype, nwidth, ndecimals)
ELSE
  dbfaddfield = -1
ENDIF

END FUNCTION dbfaddfield


SUBROUTINE dbfreadintegerattribute_f(hshp, ishape, ifield, attr)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER,INTENT(in) :: ishape, ifield
INTEGER,INTENT(out) :: attr

IF (.NOT.dbffileisnull(hshp)) THEN
  attr = dbfreadintegerattribute_orig(hshp%dbffile_orig, ishape, ifield)
ELSE
  attr = 0
ENDIF

END SUBROUTINE dbfreadintegerattribute_f


SUBROUTINE dbfreaddoubleattribute_f(hshp, ishape, ifield, attr)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER,INTENT(in) :: ishape, ifield
REAL(kind=c_double),INTENT(out) :: attr

IF (.NOT.dbffileisnull(hshp)) THEN
  attr = dbfreaddoubleattribute_orig(hshp%dbffile_orig, ishape, ifield)
ELSE
  attr = 0.0_c_double
ENDIF

END SUBROUTINE dbfreaddoubleattribute_f


SUBROUTINE dbfreadstringattribute_f(hshp, ishape, ifield, attr)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER,INTENT(in) :: ishape, ifield
CHARACTER(len=*),INTENT(out) :: attr

IF (.NOT.dbffileisnull(hshp)) THEN
  attr = strtofchar(dbfreadstringattribute_orig(hshp%dbffile_orig, ishape, ifield), len(attr))
ELSE
  attr = ''
ENDIF

END SUBROUTINE dbfreadstringattribute_f


#ifndef SHAPELIB_PRE10

FUNCTION dbfisattributenull(hshp, ishape, ifield)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER,INTENT(in) :: ishape
INTEGER,INTENT(in) :: ifield
LOGICAL :: dbfisattributenull

IF (.NOT.dbffileisnull(hshp)) THEN
  dbfisattributenull = dbfisattributenull_orig(hshp%dbffile_orig, ishape, ifield) == 0
ELSE ! force to null
  dbfisattributenull = .false.
ENDIF

END FUNCTION dbfisattributenull
#endif


FUNCTION dbfwriteintegerattribute_f(hshp, ishape, ifield, attr) RESULT(dbfwriteattribute)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER,INTENT(in) :: ishape, ifield
INTEGER,INTENT(in) :: attr
INTEGER :: dbfwriteattribute

IF (.NOT.dbffileisnull(hshp)) THEN
  dbfwriteattribute = dbfwriteintegerattribute(hshp%dbffile_orig, ishape, ifield, attr)
ELSE
  dbfwriteattribute = 0
ENDIF

END FUNCTION dbfwriteintegerattribute_f


FUNCTION dbfwritedoubleattribute_f(hshp, ishape, ifield, attr) RESULT(dbfwriteattribute)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER,INTENT(in) :: ishape, ifield
REAL(kind=c_double),INTENT(in) :: attr
INTEGER :: dbfwriteattribute

IF (.NOT.dbffileisnull(hshp)) THEN
  dbfwriteattribute = dbfwritedoubleattribute(hshp%dbffile_orig, ishape, ifield, attr)
ELSE
  dbfwriteattribute = 0
ENDIF

END FUNCTION dbfwritedoubleattribute_f


FUNCTION dbfwritestringattribute_f(hshp, ishape, ifield, attr) RESULT(dbfwriteattribute)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER,INTENT(in) :: ishape, ifield
CHARACTER(len=*),INTENT(in) :: attr
INTEGER :: dbfwriteattribute

IF (.NOT.dbffileisnull(hshp)) THEN
  dbfwriteattribute = dbfwritestringattribute(hshp%dbffile_orig, ishape, ifield, fchartostr(attr))
ELSE
  dbfwriteattribute = 0
ENDIF

END FUNCTION dbfwritestringattribute_f


FUNCTION dbfwritenullattribute_f(hshp, ishape, ifield) RESULT(dbfwriteattribute)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER,INTENT(in) :: ishape, ifield
INTEGER :: dbfwriteattribute

IF (.NOT.dbffileisnull(hshp)) THEN
  dbfwriteattribute = dbfwritenullattribute(hshp%dbffile_orig, ishape, ifield)
ELSE
  dbfwriteattribute = 0
ENDIF

END FUNCTION dbfwritenullattribute_f


#ifndef SHAPELIB_PRE10

FUNCTION dbfgetnativefieldtype(hshp, ifield)
TYPE(shpfileobject),INTENT(inout) :: hshp
INTEGER,INTENT(in) :: ifield
CHARACTER(len=1) :: dbfgetnativefieldtype

IF (.NOT.dbffileisnull(hshp)) THEN
  dbfgetnativefieldtype = char(dbfgetnativefieldtype_orig(hshp%dbffile_orig, ifield))
ELSE ! force to null
  dbfgetnativefieldtype = ' '
ENDIF

END FUNCTION dbfgetnativefieldtype
#endif


SUBROUTINE shpsetobjectfortran(ftnobject, cobject, nshptype, nshapeid, &
 nparts, panpartstart, panparttype, &
 nvertices, padfx, padfy, padfz, padfm, &
 dfxmin, dfymin, dfzmin, dfmmin, dfxmax, dfymax, dfzmax, dfmmax) &
 bind(c,name='SHPSetObjectFortran')
TYPE(c_ptr),VALUE :: ftnobject
TYPE(c_ptr),VALUE :: cobject
INTEGER(kind=c_int) :: nshptype ! Shape Type (SHPT_* - see list above)
INTEGER(kind=c_int) :: nshapeid ! Shape Number (-1 is unknown/unassigned)
INTEGER(kind=c_int) :: nparts ! # of Parts (0 implies single part with no info)
INTEGER(kind=c_int),TARGET :: panpartstart(nparts), & ! Start Vertex of part
 panparttype(nparts) ! Part Type (SHPP_RING if not SHPT_MULTIPATCH)
INTEGER(kind=c_int) :: nvertices ! Vertex list 
REAL(kind=c_double),TARGET ::  padfx(nvertices), padfy(nvertices), &
 padfz(nvertices), padfm(nvertices) ! (all zero if not provided)
REAL(kind=c_double) :: & ! Bounds in X, Y, Z and M dimensions
 dfxmin, dfymin, dfzmin, dfmmin, dfxmax, dfymax, dfzmax, dfmmax

TYPE(shpobject),POINTER :: obj

CALL c_f_pointer(ftnobject, obj)

obj%shpobject_orig = cobject
obj%nshptype = nshptype
obj%nshapeid = nshapeid
obj%nparts = nparts
obj%panpartstart => panpartstart
obj%panparttype => panparttype
obj%nvertices = nvertices
obj%padfx => padfx
obj%padfy => padfy
obj%padfz => padfz
obj%padfm => padfm
obj%dfxmin = dfxmin
obj%dfymin = dfymin
obj%dfzmin = dfzmin
obj%dfmmin = dfmmin
obj%dfxmax = dfxmax
obj%dfymax = dfymax
obj%dfzmax = dfzmax
obj%dfmmax = dfmmax

END SUBROUTINE shpsetobjectfortran

END MODULE shapelib