FortranGIS  Version 3.0
shapelib.F90
1 ! Copyright 2011 Davide Cesari <dcesari69 at gmail dot com>
2 !
3 ! This file is part of FortranGIS.
4 !
5 ! FortranGIS is free software: you can redistribute it and/or modify
6 ! it under the terms of the GNU Lesser General Public License as
7 ! published by the Free Software Foundation, either version 3 of the
8 ! License, or (at your option) any later version.
9 !
10 ! FortranGIS is distributed in the hope that it will be useful, but
11 ! WITHOUT ANY WARRANTY; without even the implied warranty of
12 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ! Lesser General Public License for more details.
14 !
15 ! You should have received a copy of the GNU Lesser General Public
16 ! License along with FortranGIS. If not, see
17 ! <http://www.gnu.org/licenses/>.
18 
42 MODULE shapelib
43 use,INTRINSIC :: iso_c_binding
44 USE fortranc
45 IMPLICIT NONE
46 
47 INTEGER,PARAMETER :: shpt_null = 0
48 INTEGER,PARAMETER :: shpt_point = 1
49 INTEGER,PARAMETER :: shpt_arc = 3
50 INTEGER,PARAMETER :: shpt_polygon = 5
51 INTEGER,PARAMETER :: shpt_multipoint = 8
52 INTEGER,PARAMETER :: shpt_pointz = 11
53 INTEGER,PARAMETER :: shpt_arcz = 13
54 INTEGER,PARAMETER :: shpt_polygonz = 15
55 INTEGER,PARAMETER :: shpt_multipointz = 18
56 INTEGER,PARAMETER :: shpt_pointm = 21
57 INTEGER,PARAMETER :: shpt_arcm = 23
58 INTEGER,PARAMETER :: shpt_polygonm = 25
59 INTEGER,PARAMETER :: shpt_multipointm = 28
60 
61 INTEGER,PARAMETER :: shpt_multipatch = 31
62 
63 INTEGER,PARAMETER :: ftstring = 0
64 INTEGER,PARAMETER :: ftinteger = 1
65 INTEGER,PARAMETER :: ftdouble = 2
66 INTEGER,PARAMETER :: ftlogical = 3
67 INTEGER,PARAMETER :: ftinvalid = 4
68 
69 
73 TYPE shpfileobject
74  PRIVATE
75  TYPE(c_ptr) :: shpfile_orig=c_null_ptr
76  TYPE(c_ptr) :: dbffile_orig=c_null_ptr
77 END TYPE shpfileobject
78 
79 
85  TYPE(c_ptr) :: shpobject_orig=c_null_ptr
86  INTEGER :: nshptype=0
87  INTEGER :: nshapeid=-1
88  INTEGER :: nparts=0
89  INTEGER,POINTER :: panpartstart(:)=>null()
90  INTEGER,POINTER :: panparttype(:)=>null()
91  INTEGER :: nvertices
92  REAL(kind=c_double),POINTER :: padfx(:)=>null()
93  REAL(kind=c_double),POINTER :: padfy(:)=>null()
94  REAL(kind=c_double),POINTER :: padfz(:)=>null()
95  REAL(kind=c_double),POINTER :: padfm(:)=>null()
96  REAL(kind=c_double) :: dfxmin=0.0_c_double
97  REAL(kind=c_double) :: dfymin=0.0_c_double
98  REAL(kind=c_double) :: dfzmin=0.0_c_double
99  REAL(kind=c_double) :: dfmmin=0.0_c_double
100  REAL(kind=c_double) :: dfxmax=0.0_c_double
101  REAL(kind=c_double) :: dfymax=0.0_c_double
102  REAL(kind=c_double) :: dfzmax=0.0_c_double
103  REAL(kind=c_double) :: dfmmax=0.0_c_double
104 END TYPE shpobject
105 
106 !TYPE(shpfileobject),PARAMETER :: shpfileobject_null = shpfileobject(0, 0)
107 TYPE(shpobject),PARAMETER :: shpobject_null = shpobject(c_null_ptr, &
108  0, -1, 0, &
109  null(), null(), 0, null(), null(), null(), null(), &
110  0.0_c_double, 0.0_c_double, 0.0_c_double, 0.0_c_double, &
111  0.0_c_double, 0.0_c_double, 0.0_c_double, 0.0_c_double)
112 
127 INTERFACE dbfreadattribute
128  MODULE PROCEDURE dbfreadintegerattribute_f, dbfreaddoubleattribute_f, &
129  dbfreadstringattribute_f
130 END INTERFACE
131 
132 
145 INTERFACE dbfwriteattribute
146  MODULE PROCEDURE dbfwriteintegerattribute_f, dbfwritedoubleattribute_f, &
147  dbfwritestringattribute_f, dbfwritenullattribute_f
148 END INTERFACE
149 
150 
151 INTERFACE
152  FUNCTION shpopen_orig(pszlayer, pszaccess) bind(C,name='SHPOpen')
153  IMPORT
154  CHARACTER(kind=c_char) :: pszlayer(*)
155  CHARACTER(kind=c_char) :: pszaccess(*)
156  TYPE(c_ptr) :: shpopen_orig
157  END FUNCTION shpopen_orig
158 
159  SUBROUTINE shpclose_orig(psshp) bind(C,name='SHPClose')
160  IMPORT
161  TYPE(c_ptr),VALUE :: psshp
162  END SUBROUTINE shpclose_orig
163 
164  SUBROUTINE shpgetinfo_orig(psshp, pnentities, pnshapetype, padfminbound, padfmaxbound) bind(C,name='SHPGetInfo')
165  IMPORT
166  TYPE(c_ptr),VALUE :: psshp
167  INTEGER(kind=c_int) :: pnentities
168  INTEGER(kind=c_int) :: pnshapetype
169  REAL(kind=c_double) :: padfminbound(*)
170  REAL(kind=c_double) :: padfmaxbound(*)
171  END SUBROUTINE shpgetinfo_orig
172 
173  FUNCTION shpcreate_orig(pszlayer, nshapetype) bind(C,name='SHPCreate')
174  IMPORT
175  CHARACTER(kind=c_char) :: pszlayer(*)
176  INTEGER(kind=c_int),VALUE :: nshapetype
177  TYPE(c_ptr) :: shpcreate_orig
178  END FUNCTION shpcreate_orig
179 
180  SUBROUTINE shpcomputeextents_int(psobject, ftnobject) bind(C,name='SHPComputeExtentsInt')
181  IMPORT
182  TYPE(c_ptr),VALUE :: psobject
183  TYPE(c_ptr),VALUE :: ftnobject
184  END SUBROUTINE shpcomputeextents_int
185 
186  FUNCTION shpcreateobject_int(nshptype, nshapeid, nparts, panpartstart, panparttype, &
187  nvertices, padfx, padfy, padfz, padfm, ftnobject) bind(C,name='SHPCreateObjectInt')
188  IMPORT
189  INTEGER(kind=c_int),VALUE :: nshptype
190  INTEGER(kind=c_int),VALUE :: nshapeid
191  INTEGER(kind=c_int),VALUE :: nparts
192  INTEGER(kind=c_int) :: panpartstart(*)
193  INTEGER(kind=c_int) :: panparttype(*)
194  INTEGER(kind=c_int),VALUE :: nvertices
195  REAL(kind=c_double) :: padfx(*)
196  REAL(kind=c_double) :: padfy(*)
197  REAL(kind=c_double) :: padfz(*)
198  REAL(kind=c_double) :: padfm(*)
199  TYPE(c_ptr),VALUE :: ftnobject
200  INTEGER(kind=c_int) :: shpcreateobject_int
201  END FUNCTION shpcreateobject_int
202 
203  FUNCTION shpcreatesimpleobject_int(nshptype, nvertices, padfx, padfy, padfz, ftnobject) bind(C,name='SHPCreateSimpleObjectInt')
204  IMPORT
205  INTEGER(kind=c_int),VALUE :: nshptype
206  INTEGER(kind=c_int),VALUE :: nvertices
207  REAL(kind=c_double) :: padfx(*)
208  REAL(kind=c_double) :: padfy(*)
209  REAL(kind=c_double) :: padfz(*)
210  TYPE(c_ptr),VALUE :: ftnobject
211  INTEGER(kind=c_int) :: shpcreatesimpleobject_int
212  END FUNCTION shpcreatesimpleobject_int
213 
214  FUNCTION shpwriteobject_orig(psshp, nshapeid, psobject) bind(C,name='SHPWriteObject')
215  IMPORT
216  TYPE(c_ptr),VALUE :: psshp
217  INTEGER(kind=c_int),VALUE :: nshapeid
218  TYPE(c_ptr),VALUE :: psobject
219  INTEGER(kind=c_int) :: shpwriteobject_orig
220  END FUNCTION shpwriteobject_orig
221 
222  FUNCTION shpreadobject_int(psshp, hentity, ftnobject) bind(C,name='SHPReadObjectInt')
223  IMPORT
224  TYPE(c_ptr),VALUE :: psshp
225  INTEGER(kind=c_int),VALUE :: hentity
226  TYPE(c_ptr),VALUE :: ftnobject
227  INTEGER(kind=c_int) :: shpreadobject_int
228  END FUNCTION shpreadobject_int
229 
230  SUBROUTINE shpdestroyobject_orig(psshape) bind(C,name='SHPDestroyObject')
231  IMPORT
232  TYPE(c_ptr),VALUE :: psshape
233  END SUBROUTINE shpdestroyobject_orig
234 
235 #ifndef SHAPELIB_PRE10
236  FUNCTION shprewindobject_int(hshp, psobject, ftnobject) bind(C,name='SHPRewindObjectInt')
237  IMPORT
238  TYPE(c_ptr),VALUE :: hshp
239  TYPE(c_ptr),VALUE :: psobject
240  TYPE(c_ptr),VALUE :: ftnobject
241  INTEGER(kind=c_int) :: shprewindobject_int
242  END FUNCTION shprewindobject_int
243 #endif
244 END INTERFACE
245 
246 INTERFACE
247  FUNCTION dbfopen(pszfilename, pszaccess) bind(C,name='DBFOpen')
248  IMPORT
249  CHARACTER(kind=c_char) :: pszfilename(*)
250  CHARACTER(kind=c_char) :: pszaccess(*)
251  TYPE(c_ptr) :: dbfopen
252  END FUNCTION dbfopen
253 
254  SUBROUTINE dbfclose(psdbf) bind(C,name='DBFClose')
255  IMPORT
256  TYPE(c_ptr),VALUE :: psdbf
257  END SUBROUTINE dbfclose
258 
259  FUNCTION dbfcreate(pszfilename) bind(C,name='DBFCreate')
260  IMPORT
261  CHARACTER(kind=c_char) :: pszfilename(*)
262  TYPE(c_ptr) :: dbfcreate
263  END FUNCTION dbfcreate
264 
265  FUNCTION dbfaddfield_orig(psdbf, pszfieldname, etype, nwidth, ndecimals) bind(C,name='DBFAddField')
266  IMPORT
267  TYPE(c_ptr),VALUE :: psdbf
268  CHARACTER(kind=c_char) :: pszfieldname(*)
269  INTEGER(kind=c_int),VALUE :: etype
270  INTEGER(kind=c_int),VALUE :: nwidth
271  INTEGER(kind=c_int),VALUE :: ndecimals
272  INTEGER(kind=c_int) :: dbfaddfield_orig
273  END FUNCTION dbfaddfield_orig
274 
275  FUNCTION dbfreadintegerattribute_orig(psdbf, irecord, ifield) bind(C,name='DBFReadIntegerAttribute')
276  IMPORT
277  TYPE(c_ptr),VALUE :: psdbf
278  INTEGER(kind=c_int),VALUE :: irecord
279  INTEGER(kind=c_int),VALUE :: ifield
280  INTEGER(kind=c_int) :: dbfreadintegerattribute_orig
281  END FUNCTION dbfreadintegerattribute_orig
282 
283  FUNCTION dbfreaddoubleattribute_orig(psdbf, irecord, ifield) bind(C,name='DBFReadDoubleAttribute')
284  IMPORT
285  TYPE(c_ptr),VALUE :: psdbf
286  INTEGER(kind=c_int),VALUE :: irecord
287  INTEGER(kind=c_int),VALUE :: ifield
288  REAL(kind=c_double) :: dbfreaddoubleattribute_orig
289  END FUNCTION dbfreaddoubleattribute_orig
290 
291  FUNCTION dbfreadstringattribute_orig(psdbf, irecord, ifield) bind(C,name='DBFReadStringAttribute')
292  IMPORT
293  TYPE(c_ptr),VALUE :: psdbf
294  INTEGER(kind=c_int),VALUE :: irecord
295  INTEGER(kind=c_int),VALUE :: ifield
296  TYPE(c_ptr) :: dbfreadstringattribute_orig
297  END FUNCTION dbfreadstringattribute_orig
298 
299  SUBROUTINE dbfreadstringattribute_int(psdbf, irecord, ifield, attr, lattr) bind(C,name='DBFReadStringAttributeInt')
300  IMPORT
301  TYPE(c_ptr),VALUE :: psdbf
302  INTEGER(kind=c_int),VALUE :: irecord
303  INTEGER(kind=c_int),VALUE :: ifield
304  CHARACTER(kind=c_char) :: attr(*)
305  INTEGER(kind=c_int),VALUE :: lattr
306  END SUBROUTINE dbfreadstringattribute_int
307 
308  FUNCTION dbfreadlogicalattribute(psdbf, irecord, ifield) bind(C,name='DBFReadLogicalAttribute')
309  IMPORT
310  TYPE(c_ptr),VALUE :: psdbf
311  INTEGER(kind=c_int),VALUE :: irecord
312  INTEGER(kind=c_int),VALUE :: ifield
313  CHARACTER(kind=c_char) :: dbfreadlogicalattribute
314  END FUNCTION dbfreadlogicalattribute
315 
316 #ifndef SHAPELIB_PRE10
317  FUNCTION dbfisattributenull_orig(psdbf, irecord, ifield) bind(C,name='DBFIsAttributeNULL')
318  IMPORT
319  TYPE(c_ptr),VALUE :: psdbf
320  INTEGER(kind=c_int),VALUE :: irecord
321  INTEGER(kind=c_int),VALUE :: ifield
322  INTEGER(kind=c_int) :: dbfisattributenull_orig
323  END FUNCTION dbfisattributenull_orig
324 #endif
325 
326  FUNCTION dbfgetfieldcount(psdbf) bind(C,name='DBFGetFieldCount')
327  IMPORT
328  TYPE(c_ptr),VALUE :: psdbf
329  INTEGER(kind=c_int) :: dbfgetfieldcount
330  END FUNCTION dbfgetfieldcount
331 
332  FUNCTION dbfgetrecordcount(psdbf) bind(C,name='DBFGetRecordCount')
333  IMPORT
334  TYPE(c_ptr),VALUE :: psdbf
335  INTEGER(kind=c_int) :: dbfgetrecordcount
336  END FUNCTION dbfgetrecordcount
337 
338  FUNCTION dbfgetfieldinfo_orig(psdbf, ifield, pszfieldname, pnwidth, pndecimals) bind(C,name='DBFGetFieldInfo')
339  IMPORT
340  TYPE(c_ptr),VALUE :: psdbf
341  INTEGER(kind=c_int),VALUE :: ifield
342  CHARACTER(kind=c_char) :: pszfieldname(*)
343  INTEGER(kind=c_int) :: pnwidth
344  INTEGER(kind=c_int) :: pndecimals
345  INTEGER(kind=c_int) :: dbfgetfieldinfo_orig
346  END FUNCTION dbfgetfieldinfo_orig
347 
348  FUNCTION dbfwritedoubleattribute(psdbf, irecord, ifield, dvalue) bind(C,name='DBFWriteDoubleAttribute')
349  IMPORT
350  TYPE(c_ptr),VALUE :: psdbf
351  INTEGER(kind=c_int),VALUE :: irecord
352  INTEGER(kind=c_int),VALUE :: ifield
353  REAL(kind=c_double),VALUE :: dvalue
354  INTEGER(kind=c_int) :: dbfwritedoubleattribute
355  END FUNCTION dbfwritedoubleattribute
356 
357  FUNCTION dbfwriteintegerattribute(psdbf, irecord, ifield, nvalue) bind(C,name='DBFWriteIntegerAttribute')
358  IMPORT
359  TYPE(c_ptr),VALUE :: psdbf
360  INTEGER(kind=c_int),VALUE :: irecord
361  INTEGER(kind=c_int),VALUE :: ifield
362  INTEGER(kind=c_int),VALUE :: nvalue
363  INTEGER(kind=c_int) :: dbfwriteintegerattribute
364  END FUNCTION dbfwriteintegerattribute
365 
366  FUNCTION dbfwritestringattribute(psdbf, irecord, ifield, pszvalue) bind(C,name='DBFWriteStringAttribute')
367  IMPORT
368  TYPE(c_ptr),VALUE :: psdbf
369  INTEGER(kind=c_int),VALUE :: irecord
370  INTEGER(kind=c_int),VALUE :: ifield
371  CHARACTER(kind=c_char) :: pszvalue(*)
372  INTEGER(kind=c_int) :: dbfwritestringattribute
373  END FUNCTION dbfwritestringattribute
374 
375  FUNCTION dbfwritenullattribute(psdbf, irecord, ifield) bind(C,name='DBFWriteNULLAttribute')
376  IMPORT
377  TYPE(c_ptr),VALUE :: psdbf
378  INTEGER(kind=c_int),VALUE :: irecord
379  INTEGER(kind=c_int),VALUE :: ifield
380  INTEGER(kind=c_int) :: dbfwritenullattribute
381  END FUNCTION dbfwritenullattribute
382 
383  FUNCTION dbfwritelogicalattribute(psdbf, irecord, ifield, lvalue) bind(C,name='DBFWriteLogicalAttribute')
384  IMPORT
385  TYPE(c_ptr),VALUE :: psdbf
386  INTEGER(kind=c_int),VALUE :: irecord
387  INTEGER(kind=c_int),VALUE :: ifield
388  CHARACTER(kind=c_char),VALUE :: lvalue
389  INTEGER(kind=c_int) :: dbfwritelogicalattribute
390  END FUNCTION dbfwritelogicalattribute
391 
392 #ifndef SHAPELIB_PRE10
393  FUNCTION dbfgetnativefieldtype_orig(psdbf, ifield) bind(C,name='DBFGetNativeFieldType')
394  IMPORT
395  TYPE(c_ptr),VALUE :: psdbf
396  INTEGER(kind=c_int),VALUE :: ifield
397  INTEGER(kind=c_signed_char) :: dbfgetnativefieldtype_orig
398  END FUNCTION dbfgetnativefieldtype_orig
399 
400  FUNCTION dbfgetfieldindex_orig(psdbf, pszfieldname) bind(C,name='DBFGetFieldIndex')
401  IMPORT
402  TYPE(c_ptr),VALUE :: psdbf
403  CHARACTER(kind=c_char) :: pszfieldname(*)
404  INTEGER(kind=c_int) :: dbfgetfieldindex_orig
405  END FUNCTION dbfgetfieldindex_orig
406 #endif
407 
408 END INTERFACE
409 
410 PRIVATE
411 PUBLIC shpt_null, shpt_point, shpt_arc, shpt_polygon, shpt_multipoint, &
412  shpt_pointz, shpt_arcz, shpt_polygonz, shpt_multipointz, shpt_pointm, &
413  shpt_arcm, shpt_polygonm, shpt_multipointm, shpt_multipatch, &
414  ftstring, ftinteger, ftdouble, ftlogical, ftinvalid
415 PUBLIC shpfileobject, shpobject
417 PUBLIC shpopen, shpfileisnull, dbffileisnull, shpcreate, shpgetinfo, &
418  shpreadobject, shpisnull, shpclose, shpcreatesimpleobject, shpcreateobject, &
419  shpcomputeextents, shpwriteobject, shpdestroyobject, &
420  dbfgetfieldindex, dbfgetfieldinfo, dbfaddfield, dbfisattributenull, &
421  dbfgetnativefieldtype
422 
423 CONTAINS
424 
425 
437 FUNCTION shpopen(pszshapefile, pszaccess)
438 CHARACTER(len=*),INTENT(in) :: pszshapefile
439 CHARACTER(len=*),INTENT(in) :: pszaccess
440 TYPE(shpfileobject) :: shpopen
441 
442 shpopen%shpfile_orig = shpopen_orig(fchartrimtostr(pszshapefile), fchartrimtostr(pszaccess))
443 shpopen%dbffile_orig = dbfopen(fchartrimtostr(pszshapefile), fchartrimtostr(pszaccess))
444 
445 END FUNCTION shpopen
446 
447 
452 FUNCTION shpfileisnull(hshp) RESULT(isnull)
453 TYPE(shpfileobject),INTENT(in) :: hshp
454 LOGICAL :: isnull
455 
456 isnull = .NOT.c_associated(hshp%shpfile_orig)
457 
458 END FUNCTION shpfileisnull
459 
460 
464 FUNCTION dbffileisnull(hshp) RESULT(isnull)
465 TYPE(shpfileobject),INTENT(in) :: hshp
466 LOGICAL :: isnull
467 
468 isnull = .NOT.c_associated(hshp%dbffile_orig)
469 
470 END FUNCTION dbffileisnull
471 
472 
480 FUNCTION shpcreate(pszshapefile, nshapetype)
481 CHARACTER(len=*),INTENT(in) :: pszshapefile
482 INTEGER,INTENT(in) :: nshapetype
483 TYPE(shpfileobject) :: shpcreate
484 
485 shpcreate%shpfile_orig = shpcreate_orig(fchartrimtostr(pszshapefile), nshapetype)
486 shpcreate%dbffile_orig = dbfcreate(fchartrimtostr(pszshapefile))
487 
488 END FUNCTION shpcreate
489 
490 
495 SUBROUTINE shpgetinfo(hshp, nentities, shapetype, minbound, maxbound, &
496  dbffieldcount, dbfrecordcount)
497 TYPE(shpfileobject),INTENT(in) :: hshp
498 INTEGER,INTENT(out) :: nentities
499 INTEGER,INTENT(out) :: shapetype
500 REAL(kind=c_double),INTENT(out) :: minbound(4)
501 REAL(kind=c_double),INTENT(out) :: maxbound(4)
502 INTEGER,INTENT(out) :: dbffieldcount
503 INTEGER,INTENT(out) :: dbfrecordcount
504 
505 IF (.NOT.shpfileisnull(hshp)) THEN
506  CALL shpgetinfo_orig(hshp%shpfile_orig, nentities, shapetype, minbound, maxbound)
507 ELSE
508  nentities = 0
509  shapetype = 0
510  minbound(:) = 0.0d0
511  maxbound(:) = 0.0d0
512 ENDIF
513 IF (.NOT.dbffileisnull(hshp)) THEN
514  dbffieldcount = dbfgetfieldcount(hshp%dbffile_orig)
515  dbfrecordcount = dbfgetrecordcount(hshp%dbffile_orig)
516 ELSE
517  dbffieldcount = 0
518  dbfrecordcount = 0
519 ENDIF
520 
521 END SUBROUTINE shpgetinfo
522 
523 
532 FUNCTION shpreadobject(hshp, ishape)
533 TYPE(shpfileobject),INTENT(inout) :: hshp
534 INTEGER :: ishape
535 TYPE(shpobject),TARGET :: shpreadobject
536 
537 TYPE(shpobject) :: lshpobject
538 
539 INTEGER :: ier
540 
541 IF (.NOT.shpfileisnull(hshp)) THEN
542  ier = shpreadobject_int(hshp%shpfile_orig, ishape, c_loc(shpreadobject))
543 ELSE ! initialize to empty
544  shpreadobject = shpobject_null
545 ENDIF
546 
547 END FUNCTION shpreadobject
548 
549 
553 FUNCTION shpisnull(psobject) RESULT(isnull)
554 TYPE(shpobject),INTENT(in) :: psobject
555 LOGICAL :: isnull
556 
557 isnull = .NOT.c_associated(psobject%shpobject_orig)
558 
559 END FUNCTION shpisnull
560 
561 
563 SUBROUTINE shpclose(hshp)
564 TYPE(shpfileobject),INTENT(inout) :: hshp
565 
566 IF (.NOT.shpfileisnull(hshp)) THEN
567  CALL shpclose_orig(hshp%shpfile_orig)
568  hshp%shpfile_orig = c_null_ptr
569 ENDIF
570 IF (.NOT.dbffileisnull(hshp)) THEN
571  CALL dbfclose(hshp%dbffile_orig)
572  hshp%dbffile_orig = c_null_ptr
573 ENDIF
574 
575 END SUBROUTINE shpclose
576 
577 
583 FUNCTION shpcreatesimpleobject(nshptype, nvertices, padfx, padfy, padfz)
584 INTEGER :: nshptype
585 INTEGER :: nvertices
586 REAL(kind=c_double) :: padfx(nvertices)
587 REAL(kind=c_double) :: padfy(nvertices)
588 REAL(kind=c_double),OPTIONAL :: padfz(nvertices)
589 TYPE(shpobject),TARGET :: shpcreatesimpleobject
590 
591 TYPE(shpobject) :: lshpobject
592 
593 IF (shpcreatesimpleobject_int(nshptype, nvertices, padfx, padfy, padfz, &
594  c_loc(shpcreatesimpleobject)) /= 0) THEN
595  shpcreatesimpleobject = shpobject_null
596 ENDIF
597 
598 END FUNCTION shpcreatesimpleobject
599 
600 
606 FUNCTION shpcreateobject(nshptype, ishape, nparts, panpartstart, panparttype, &
607  nvertices, padfx, padfy, padfz, padfm)
608 INTEGER :: nshptype
609 INTEGER :: ishape
610 INTEGER :: nparts
611 INTEGER :: nvertices
612 INTEGER :: panpartstart(nparts)
613 INTEGER :: panparttype(nparts)
614 REAL(kind=c_double) :: padfx(nvertices)
615 REAL(kind=c_double) :: padfy(nvertices)
616 REAL(kind=c_double),OPTIONAL :: padfz(nvertices)
617 REAL(kind=c_double),OPTIONAL :: padfm(nvertices)
618 TYPE(shpobject),TARGET :: shpcreateobject
619 
620 TYPE(shpobject) :: lshpobject
621 
622 IF (shpcreateobject_int(nshptype, ishape, nparts, panpartstart, panparttype, &
623  nvertices, padfx, padfy, padfz, padfm, c_loc(shpcreateobject)) /= 0) THEN
624  shpcreateobject = shpobject_null
625 ENDIF
626 
627 END FUNCTION shpcreateobject
628 
629 
637 SUBROUTINE shpcomputeextents(psobject)
638 TYPE(shpobject),TARGET :: psobject
639 
640 CALL shpcomputeextents_int(psobject%shpobject_orig, c_loc(psobject))
641 
642 END SUBROUTINE shpcomputeextents
643 
644 
648 FUNCTION shpwriteobject(hshp, ishape, psobject)
649 TYPE(shpfileobject),INTENT(inout) :: hshp
650 INTEGER :: ishape
651 TYPE(shpobject) :: psobject
652 INTEGER :: shpwriteobject
653 
654 IF (.NOT.shpfileisnull(hshp)) THEN
655  shpwriteobject = shpwriteobject_orig(hshp%shpfile_orig, ishape, psobject%shpobject_orig)
656 ELSE
657  shpwriteobject = 0
658 ENDIF
659 
660 END FUNCTION shpwriteobject
661 
662 
664 SUBROUTINE shpdestroyobject(psobject)
665 TYPE(shpobject) :: psobject
666 
667 IF (c_associated(psobject%shpobject_orig)) THEN
668  CALL shpdestroyobject_orig(psobject%shpobject_orig)
669 ENDIF
670 psobject = shpobject_null
671 
672 END SUBROUTINE shpdestroyobject
673 
674 
675 #ifndef SHAPELIB_PRE10
676 
684 FUNCTION shprewindobject(hshp, psobject)
685 TYPE(shpfileobject),INTENT(inout) :: hshp
686 TYPE(shpobject),INTENT(inout),TARGET :: psobject
687 LOGICAL :: shprewindobject
688 
689 shprewindobject = shprewindobject_int(hshp%shpfile_orig, psobject%shpobject_orig, &
690  c_loc(psobject)) /= 0
691 
692 END FUNCTION shprewindobject
693 
694 
701 FUNCTION dbfgetfieldindex(hshp, pszfieldname)
702 TYPE(shpfileobject),INTENT(in) :: hshp
703 CHARACTER(len=*),INTENT(in) :: pszfieldname
704 INTEGER :: dbfgetfieldindex
705 
706 IF (.NOT.dbffileisnull(hshp)) THEN
707  dbfgetfieldindex = dbfgetfieldindex_orig(hshp%dbffile_orig, fchartrimtostr(pszfieldname))
708 ELSE
709  dbfgetfieldindex = -1
710 ENDIF
711 
712 END FUNCTION dbfgetfieldindex
713 #endif
714 
715 
722 FUNCTION dbfgetfieldinfo(hshp, ifield, pszfieldname, pnwidth, pndecimals)
723 TYPE(shpfileobject),INTENT(inout) :: hshp
724 INTEGER,INTENT(in) :: ifield
725 CHARACTER(len=*),INTENT(out) :: pszfieldname
726 INTEGER,INTENT(out) :: pnwidth
727 INTEGER,INTENT(out) :: pndecimals
728 INTEGER :: dbfgetfieldinfo
729 
730 CHARACTER(len=11) :: lpszfieldname
731 
732 IF (.NOT.dbffileisnull(hshp)) THEN
733  dbfgetfieldinfo = dbfgetfieldinfo_orig(hshp%dbffile_orig, ifield, &
734  lpszfieldname, pnwidth, pndecimals)
735  pszfieldname = lpszfieldname ! must strip null here!
736 ELSE
737  dbfgetfieldinfo = -1
738 ENDIF
739 
740 END FUNCTION dbfgetfieldinfo
741 
742 
748 FUNCTION dbfaddfield(hshp, pszfieldname, etype, nwidth, ndecimals)
749 TYPE(shpfileobject),INTENT(inout) :: hshp
750 CHARACTER(len=*),INTENT(in) :: pszfieldname
751 INTEGER,INTENT(in) :: etype
752 INTEGER,INTENT(in) :: nwidth
753 INTEGER,INTENT(in) :: ndecimals
754 INTEGER :: dbfaddfield
755 
756 IF (.NOT.dbffileisnull(hshp)) THEN
757  dbfaddfield = dbfaddfield_orig(hshp%dbffile_orig, fchartrimtostr(pszfieldname), &
758  etype, nwidth, ndecimals)
759 ELSE
760  dbfaddfield = -1
761 ENDIF
762 
763 END FUNCTION dbfaddfield
764 
765 
766 SUBROUTINE dbfreadintegerattribute_f(hshp, ishape, ifield, attr)
767 TYPE(shpfileobject),INTENT(inout) :: hshp
768 INTEGER,INTENT(in) :: ishape, ifield
769 INTEGER,INTENT(out) :: attr
770 
771 IF (.NOT.dbffileisnull(hshp)) THEN
772  attr = dbfreadintegerattribute_orig(hshp%dbffile_orig, ishape, ifield)
773 ELSE
774  attr = 0
775 ENDIF
776 
777 END SUBROUTINE dbfreadintegerattribute_f
778 
779 
780 SUBROUTINE dbfreaddoubleattribute_f(hshp, ishape, ifield, attr)
781 TYPE(shpfileobject),INTENT(inout) :: hshp
782 INTEGER,INTENT(in) :: ishape, ifield
783 REAL(kind=c_double),INTENT(out) :: attr
784 
785 IF (.NOT.dbffileisnull(hshp)) THEN
786  attr = dbfreaddoubleattribute_orig(hshp%dbffile_orig, ishape, ifield)
787 ELSE
788  attr = 0.0_c_double
789 ENDIF
790 
791 END SUBROUTINE dbfreaddoubleattribute_f
792 
793 
794 SUBROUTINE dbfreadstringattribute_f(hshp, ishape, ifield, attr)
795 TYPE(shpfileobject),INTENT(inout) :: hshp
796 INTEGER,INTENT(in) :: ishape, ifield
797 CHARACTER(len=*),INTENT(out) :: attr
798 
799 IF (.NOT.dbffileisnull(hshp)) THEN
800  attr = strtofchar(dbfreadstringattribute_orig(hshp%dbffile_orig, ishape, ifield), len(attr))
801 ELSE
802  attr = ''
803 ENDIF
804 
805 END SUBROUTINE dbfreadstringattribute_f
806 
807 
808 #ifndef SHAPELIB_PRE10
809 
816 FUNCTION dbfisattributenull(hshp, ishape, ifield)
817 TYPE(shpfileobject),INTENT(inout) :: hshp
818 INTEGER,INTENT(in) :: ishape
819 INTEGER,INTENT(in) :: ifield
820 LOGICAL :: dbfisattributenull
821 
822 IF (.NOT.dbffileisnull(hshp)) THEN
823  dbfisattributenull = dbfisattributenull_orig(hshp%dbffile_orig, ishape, ifield) /= 0
824 ELSE ! force to null
825  dbfisattributenull = .false.
826 ENDIF
827 
828 END FUNCTION dbfisattributenull
829 #endif
830 
831 
832 FUNCTION dbfwriteintegerattribute_f(hshp, ishape, ifield, attr) RESULT(dbfwriteattribute)
833 TYPE(shpfileobject),INTENT(inout) :: hshp
834 INTEGER,INTENT(in) :: ishape, ifield
835 INTEGER,INTENT(in) :: attr
836 INTEGER :: dbfwriteattribute
837 
838 IF (.NOT.dbffileisnull(hshp)) THEN
839  dbfwriteattribute = dbfwriteintegerattribute(hshp%dbffile_orig, ishape, ifield, attr)
840 ELSE
842 ENDIF
843 
844 END FUNCTION dbfwriteintegerattribute_f
845 
846 
847 FUNCTION dbfwritedoubleattribute_f(hshp, ishape, ifield, attr) RESULT(dbfwriteattribute)
848 TYPE(shpfileobject),INTENT(inout) :: hshp
849 INTEGER,INTENT(in) :: ishape, ifield
850 REAL(kind=c_double),INTENT(in) :: attr
851 INTEGER :: dbfwriteattribute
852 
853 IF (.NOT.dbffileisnull(hshp)) THEN
854  dbfwriteattribute = dbfwritedoubleattribute(hshp%dbffile_orig, ishape, ifield, attr)
855 ELSE
857 ENDIF
858 
859 END FUNCTION dbfwritedoubleattribute_f
860 
861 
862 FUNCTION dbfwritestringattribute_f(hshp, ishape, ifield, attr) RESULT(dbfwriteattribute)
863 TYPE(shpfileobject),INTENT(inout) :: hshp
864 INTEGER,INTENT(in) :: ishape, ifield
865 CHARACTER(len=*),INTENT(in) :: attr
866 INTEGER :: dbfwriteattribute
867 
868 IF (.NOT.dbffileisnull(hshp)) THEN
869  dbfwriteattribute = dbfwritestringattribute(hshp%dbffile_orig, ishape, ifield, fchartostr(attr))
870 ELSE
872 ENDIF
873 
874 END FUNCTION dbfwritestringattribute_f
875 
876 
877 FUNCTION dbfwritenullattribute_f(hshp, ishape, ifield) RESULT(dbfwriteattribute)
878 TYPE(shpfileobject),INTENT(inout) :: hshp
879 INTEGER,INTENT(in) :: ishape, ifield
880 INTEGER :: dbfwriteattribute
881 
882 IF (.NOT.dbffileisnull(hshp)) THEN
883  dbfwriteattribute = dbfwritenullattribute(hshp%dbffile_orig, ishape, ifield)
884 ELSE
886 ENDIF
887 
888 END FUNCTION dbfwritenullattribute_f
889 
890 
891 #ifndef SHAPELIB_PRE10
892 
906 FUNCTION dbfgetnativefieldtype(hshp, ifield)
907 TYPE(shpfileobject),INTENT(inout) :: hshp
908 INTEGER,INTENT(in) :: ifield
909 CHARACTER(len=1) :: dbfgetnativefieldtype
910 
911 IF (.NOT.dbffileisnull(hshp)) THEN
912  dbfgetnativefieldtype = char(dbfgetnativefieldtype_orig(hshp%dbffile_orig, ifield))
913 ELSE ! force to null
914  dbfgetnativefieldtype = ' '
915 ENDIF
916 
917 END FUNCTION dbfgetnativefieldtype
918 #endif
919 
920 
921 SUBROUTINE shpsetobjectfortran(ftnobject, cobject, nshptype, nshapeid, &
922  nparts, panpartstart, panparttype, &
923  nvertices, padfx, padfy, padfz, padfm, &
924  dfxmin, dfymin, dfzmin, dfmmin, dfxmax, dfymax, dfzmax, dfmmax) &
925  bind(c,name='SHPSetObjectFortran')
926 TYPE(c_ptr),VALUE :: ftnobject
927 TYPE(c_ptr),VALUE :: cobject
928 INTEGER(kind=c_int) :: nshptype ! Shape Type (SHPT_* - see list above)
929 INTEGER(kind=c_int) :: nshapeid ! Shape Number (-1 is unknown/unassigned)
930 INTEGER(kind=c_int) :: nparts ! # of Parts (0 implies single part with no info)
931 INTEGER(kind=c_int),TARGET :: panpartstart(nparts), & ! Start Vertex of part
932  panparttype(nparts) ! Part Type (SHPP_RING if not SHPT_MULTIPATCH)
933 INTEGER(kind=c_int) :: nvertices ! Vertex list
934 REAL(kind=c_double),TARGET :: padfx(nvertices), padfy(nvertices), &
935  padfz(nvertices), padfm(nvertices) ! (all zero if not provided)
936 REAL(kind=c_double) :: & ! Bounds in X, Y, Z and M dimensions
937  dfxmin, dfymin, dfzmin, dfmmin, dfxmax, dfymax, dfzmax, dfmmax
938 
939 TYPE(shpobject),POINTER :: obj
940 
941 CALL c_f_pointer(ftnobject, obj)
942 
943 obj%shpobject_orig = cobject
944 obj%nshptype = nshptype
945 obj%nshapeid = nshapeid
946 obj%nparts = nparts
947 obj%panpartstart => panpartstart
948 obj%panparttype => panparttype
949 obj%nvertices = nvertices
950 obj%padfx => padfx
951 obj%padfy => padfy
952 obj%padfz => padfz
953 obj%padfm => padfm
954 obj%dfxmin = dfxmin
955 obj%dfymin = dfymin
956 obj%dfzmin = dfzmin
957 obj%dfmmin = dfmmin
958 obj%dfxmax = dfxmax
959 obj%dfymax = dfymax
960 obj%dfzmax = dfzmax
961 obj%dfmmax = dfmmax
962 
963 END SUBROUTINE shpsetobjectfortran
964 
965 END MODULE shapelib
966 
Convert a null-terminated C string into a Fortran CHARACTER variable of the proper length.
Definition: fortranc.F90:174
Interface to SUBROUTINEs for reading dbf attributes.
Definition: shapelib.F90:138
Interface to FUNCTIONs for setting dbf attributes.
Definition: shapelib.F90:156
Utility module for supporting Fortran 2003 C language interface module.
Definition: fortranc.F90:103
Fortran 2003 interface to the shapelib http://shapelib.maptools.org/ library.
Definition: shapelib.F90:53
Object describing a shapefile dataset.
Definition: shapelib.F90:84
Object describing the geometrical properties of a shape.
Definition: shapelib.F90:95