FortranGIS  Version2.5
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
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)
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
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
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 INTEGER :: ier
690 
691 ier = shprewindobject_int(hshp%shpfile_orig, psobject%shpobject_orig, &
692  c_loc(psobject))
693 IF (ier == 0) THEN
694  shprewindobject = .false.
695 ELSE
696  shprewindobject = .true.
697 ENDIF
698 
699 END FUNCTION shprewindobject
700 
701 
708 FUNCTION dbfgetfieldindex(hshp, pszfieldname)
709 TYPE(shpfileobject),INTENT(in) :: hshp
710 CHARACTER(len=*),INTENT(in) :: pszfieldname
711 INTEGER :: dbfgetfieldindex
712 
713 IF (.NOT.dbffileisnull(hshp)) THEN
714  dbfgetfieldindex = dbfgetfieldindex_orig(hshp%dbffile_orig, fchartrimtostr(pszfieldname))
715 ELSE
716  dbfgetfieldindex = -1
717 ENDIF
718 
719 END FUNCTION dbfgetfieldindex
720 #endif
721 
722 
729 FUNCTION dbfgetfieldinfo(hshp, ifield, pszfieldname, pnwidth, pndecimals)
730 TYPE(shpfileobject),INTENT(inout) :: hshp
731 INTEGER,INTENT(in) :: ifield
732 CHARACTER(len=*),INTENT(out) :: pszfieldname
733 INTEGER,INTENT(out) :: pnwidth
734 INTEGER,INTENT(out) :: pndecimals
735 INTEGER :: dbfgetfieldinfo
736 
737 CHARACTER(len=11) :: lpszfieldname
738 
739 IF (.NOT.dbffileisnull(hshp)) THEN
740  dbfgetfieldinfo = dbfgetfieldinfo_orig(hshp%dbffile_orig, ifield, &
741  lpszfieldname, pnwidth, pndecimals)
742  pszfieldname = lpszfieldname ! must strip null here!
743 ELSE
744  dbfgetfieldinfo = -1
745 ENDIF
746 
747 END FUNCTION dbfgetfieldinfo
748 
749 
755 FUNCTION dbfaddfield(hshp, pszfieldname, etype, nwidth, ndecimals)
756 TYPE(shpfileobject),INTENT(inout) :: hshp
757 CHARACTER(len=*),INTENT(in) :: pszfieldname
758 INTEGER,INTENT(in) :: etype
759 INTEGER,INTENT(in) :: nwidth
760 INTEGER,INTENT(in) :: ndecimals
761 INTEGER :: dbfaddfield
762 
763 IF (.NOT.dbffileisnull(hshp)) THEN
764  dbfaddfield = dbfaddfield_orig(hshp%dbffile_orig, fchartrimtostr(pszfieldname), &
765  etype, nwidth, ndecimals)
766 ELSE
767  dbfaddfield = -1
768 ENDIF
769 
770 END FUNCTION dbfaddfield
771 
772 
773 SUBROUTINE dbfreadintegerattribute_f(hshp, ishape, ifield, attr)
774 TYPE(shpfileobject),INTENT(inout) :: hshp
775 INTEGER,INTENT(in) :: ishape, ifield
776 INTEGER,INTENT(out) :: attr
777 
778 IF (.NOT.dbffileisnull(hshp)) THEN
779  attr = dbfreadintegerattribute_orig(hshp%dbffile_orig, ishape, ifield)
780 ELSE
781  attr = 0
782 ENDIF
783 
784 END SUBROUTINE dbfreadintegerattribute_f
785 
786 
787 SUBROUTINE dbfreaddoubleattribute_f(hshp, ishape, ifield, attr)
788 TYPE(shpfileobject),INTENT(inout) :: hshp
789 INTEGER,INTENT(in) :: ishape, ifield
790 REAL(kind=c_double),INTENT(out) :: attr
791 
792 IF (.NOT.dbffileisnull(hshp)) THEN
793  attr = dbfreaddoubleattribute_orig(hshp%dbffile_orig, ishape, ifield)
794 ELSE
795  attr = 0.0_c_double
796 ENDIF
797 
798 END SUBROUTINE dbfreaddoubleattribute_f
799 
800 
801 SUBROUTINE dbfreadstringattribute_f(hshp, ishape, ifield, attr)
802 TYPE(shpfileobject),INTENT(inout) :: hshp
803 INTEGER,INTENT(in) :: ishape, ifield
804 CHARACTER(len=*),INTENT(out) :: attr
805 
806 IF (.NOT.dbffileisnull(hshp)) THEN
807  attr = strtofchar(dbfreadstringattribute_orig(hshp%dbffile_orig, ishape, ifield), len(attr))
808 ELSE
809  attr = ''
810 ENDIF
811 
812 END SUBROUTINE dbfreadstringattribute_f
813 
814 
815 #ifndef SHAPELIB_PRE10
816 
823 FUNCTION dbfisattributenull(hshp, ishape, ifield)
824 TYPE(shpfileobject),INTENT(inout) :: hshp
825 INTEGER,INTENT(in) :: ishape
826 INTEGER,INTENT(in) :: ifield
827 LOGICAL :: dbfisattributenull
828 
829 IF (.NOT.dbffileisnull(hshp)) THEN
830  dbfisattributenull = dbfisattributenull_orig(hshp%dbffile_orig, ishape, ifield) == 0
831 ELSE ! force to null
832  dbfisattributenull = .false.
833 ENDIF
834 
835 END FUNCTION dbfisattributenull
836 #endif
837 
838 
839 FUNCTION dbfwriteintegerattribute_f(hshp, ishape, ifield, attr) RESULT(dbfwriteattribute)
840 TYPE(shpfileobject),INTENT(inout) :: hshp
841 INTEGER,INTENT(in) :: ishape, ifield
842 INTEGER,INTENT(in) :: attr
843 INTEGER :: dbfwriteattribute
844 
845 IF (.NOT.dbffileisnull(hshp)) THEN
846  dbfwriteattribute = dbfwriteintegerattribute(hshp%dbffile_orig, ishape, ifield, attr)
847 ELSE
849 ENDIF
850 
851 END FUNCTION dbfwriteintegerattribute_f
852 
853 
854 FUNCTION dbfwritedoubleattribute_f(hshp, ishape, ifield, attr) RESULT(dbfwriteattribute)
855 TYPE(shpfileobject),INTENT(inout) :: hshp
856 INTEGER,INTENT(in) :: ishape, ifield
857 REAL(kind=c_double),INTENT(in) :: attr
858 INTEGER :: dbfwriteattribute
859 
860 IF (.NOT.dbffileisnull(hshp)) THEN
861  dbfwriteattribute = dbfwritedoubleattribute(hshp%dbffile_orig, ishape, ifield, attr)
862 ELSE
864 ENDIF
865 
866 END FUNCTION dbfwritedoubleattribute_f
867 
868 
869 FUNCTION dbfwritestringattribute_f(hshp, ishape, ifield, attr) RESULT(dbfwriteattribute)
870 TYPE(shpfileobject),INTENT(inout) :: hshp
871 INTEGER,INTENT(in) :: ishape, ifield
872 CHARACTER(len=*),INTENT(in) :: attr
873 INTEGER :: dbfwriteattribute
874 
875 IF (.NOT.dbffileisnull(hshp)) THEN
876  dbfwriteattribute = dbfwritestringattribute(hshp%dbffile_orig, ishape, ifield, fchartostr(attr))
877 ELSE
879 ENDIF
880 
881 END FUNCTION dbfwritestringattribute_f
882 
883 
884 FUNCTION dbfwritenullattribute_f(hshp, ishape, ifield) RESULT(dbfwriteattribute)
885 TYPE(shpfileobject),INTENT(inout) :: hshp
886 INTEGER,INTENT(in) :: ishape, ifield
887 INTEGER :: dbfwriteattribute
888 
889 IF (.NOT.dbffileisnull(hshp)) THEN
890  dbfwriteattribute = dbfwritenullattribute(hshp%dbffile_orig, ishape, ifield)
891 ELSE
893 ENDIF
894 
895 END FUNCTION dbfwritenullattribute_f
896 
897 
898 #ifndef SHAPELIB_PRE10
899 
913 FUNCTION dbfgetnativefieldtype(hshp, ifield)
914 TYPE(shpfileobject),INTENT(inout) :: hshp
915 INTEGER,INTENT(in) :: ifield
916 CHARACTER(len=1) :: dbfgetnativefieldtype
917 
918 IF (.NOT.dbffileisnull(hshp)) THEN
919  dbfgetnativefieldtype = char(dbfgetnativefieldtype_orig(hshp%dbffile_orig, ifield))
920 ELSE ! force to null
921  dbfgetnativefieldtype = ' '
922 ENDIF
923 
924 END FUNCTION dbfgetnativefieldtype
925 #endif
926 
927 
928 SUBROUTINE shpsetobjectfortran(ftnobject, cobject, nshptype, nshapeid, &
929  nparts, panpartstart, panparttype, &
930  nvertices, padfx, padfy, padfz, padfm, &
931  dfxmin, dfymin, dfzmin, dfmmin, dfxmax, dfymax, dfzmax, dfmmax) &
932  bind(c,name='SHPSetObjectFortran')
933 TYPE(c_ptr),VALUE :: ftnobject
934 TYPE(c_ptr),VALUE :: cobject
935 INTEGER(kind=c_int) :: nshptype ! Shape Type (SHPT_* - see list above)
936 INTEGER(kind=c_int) :: nshapeid ! Shape Number (-1 is unknown/unassigned)
937 INTEGER(kind=c_int) :: nparts ! # of Parts (0 implies single part with no info)
938 INTEGER(kind=c_int),TARGET :: panpartstart(nparts), & ! Start Vertex of part
939  panparttype(nparts) ! Part Type (SHPP_RING if not SHPT_MULTIPATCH)
940 INTEGER(kind=c_int) :: nvertices ! Vertex list
941 REAL(kind=c_double),TARGET :: padfx(nvertices), padfy(nvertices), &
942  padfz(nvertices), padfm(nvertices) ! (all zero if not provided)
943 REAL(kind=c_double) :: & ! Bounds in X, Y, Z and M dimensions
944  dfxmin, dfymin, dfzmin, dfmmin, dfxmax, dfymax, dfzmax, dfmmax
945 
946 TYPE(shpobject),POINTER :: obj
947 
948 CALL c_f_pointer(ftnobject, obj)
949 
950 obj%shpobject_orig = cobject
951 obj%nshptype = nshptype
952 obj%nshapeid = nshapeid
953 obj%nparts = nparts
954 obj%panpartstart => panpartstart
955 obj%panparttype => panparttype
956 obj%nvertices = nvertices
957 obj%padfx => padfx
958 obj%padfy => padfy
959 obj%padfz => padfz
960 obj%padfm => padfm
961 obj%dfxmin = dfxmin
962 obj%dfymin = dfymin
963 obj%dfzmin = dfzmin
964 obj%dfmmin = dfmmin
965 obj%dfxmax = dfxmax
966 obj%dfymax = dfymax
967 obj%dfzmax = dfzmax
968 obj%dfmmax = dfmmax
969 
970 END SUBROUTINE shpsetobjectfortran
971 
972 END MODULE shapelib
973 
Interface to FUNCTIONs for setting dbf attributes.
Definition: shapelib.F90:156
Interface to SUBROUTINEs for reading dbf attributes.
Definition: shapelib.F90:138
Object describing the geometrical properties of a shape.
Definition: shapelib.F90:95
Fortran 2003 interface to the shapelib http://shapelib.maptools.org/ library.
Definition: shapelib.F90:53
Object describing a shapefile dataset.
Definition: shapelib.F90:84
Utility module for supporting Fortran 2003 C language interface module.
Definition: fortranc.F90:100
Convert a null-terminated C string into a Fortran CHARACTER variable of the proper length...
Definition: fortranc.F90:165