PLplot 5.15.0
plplot_double.f90
Go to the documentation of this file.
1!***********************************************************************
2! plplot_double.f90
3!
4! Copyright (C) 2005-2016 Arjen Markus
5! Copyright (C) 2006-2016 Alan W. Irwin
6!
7! This file is part of PLplot.
8!
9! PLplot is free software; you can redistribute it and/or modify
10! it under the terms of the GNU Library General Public License as published
11! by the Free Software Foundation; either version 2 of the License, or
12! (at your option) any later version.
13!
14! PLplot is distributed in the hope that it will be useful,
15! but WITHOUT ANY WARRANTY; without even the implied warranty of
16! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17! GNU Library General Public License for more details.
18!
19! You should have received a copy of the GNU Library General Public License
20! along with PLplot; if not, write to the Free Software
21! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
22!
23!
24!***********************************************************************
25
27 use iso_c_binding, only: c_ptr, c_char, c_null_char, c_null_ptr, c_loc, c_funptr, c_null_funptr, c_funloc, c_associated
28 use iso_fortran_env, only: error_unit
32 implicit none
33
34 integer, parameter :: wp = private_double
35 private :: c_ptr, c_char, c_null_char, c_null_ptr, c_loc, c_funptr, c_null_funptr, c_funloc
36 private :: error_unit
37 private :: private_plflt, private_plint, private_plbool, private_double, plcgrid, plfgrid
38 private :: character_array_to_c
39 private :: wp
40
41 ! Private interfaces for wp-precision callbacks
43
44 ! Normally interface blocks describing the C routines that are
45 ! called by this Fortran binding are embedded as part of module
46 ! procedures, but when more than one module procedure uses such
47 ! interface blocks there is a requirement (enforced at least by
48 ! the nagfor compiler) that those interface blocks be consistent.
49 ! We could comply with that requirement by embedding such multiply
50 ! used interface blocks as part of module procedures using
51 ! duplicated code, but that is inefficient (in terms of the number
52 ! of lines of code to be compiled) and implies a maintenance issue
53 ! (to keep that code duplicated whenever there are changes on the
54 ! C side). To deal with those two potential issues we collect
55 ! here in alphabetical order all interface blocks describing C
56 ! routines that are called directly by more than one module
57 ! procedure.
58
59 interface
60 subroutine interface_plslabelfunc( proc, data ) bind(c, name = 'c_plslabelfunc' )
61 import :: c_funptr, c_ptr
62 type(c_funptr), value, intent(in) :: proc
63 type(c_ptr), value, intent(in) :: data
64 end subroutine interface_plslabelfunc
65 end interface
66 private :: interface_plslabelfunc
67
68 interface
69 subroutine interface_plstransform( proc, data ) bind(c, name = 'c_plstransform' )
70 import :: c_funptr, c_ptr
71 type(c_funptr), value, intent(in) :: proc
72 type(c_ptr), value, intent(in) :: data
73 end subroutine interface_plstransform
74 end interface
75 private :: interface_plstransform
76
77 ! Routines that have floating-point attributes that nevertheless
78 ! cannot be disambiguated so we only provide them for the
79 ! double-precision case (rather than using a separate naming
80 ! convention for these routines or some other complexity for users
81 ! to distinguish the double- and single-precision cases).
82
83 interface plrandd
84 ! Only provide double-precison version because of
85 ! disambiguation problems with the corresponding
86 ! single-precision versions.
87 module procedure plrandd_impl
88 end interface plrandd
89 private :: plrandd_impl
90
91 interface plslabelfunc
92 ! Only provide double-precison versions because of
93 ! disambiguation problems with the corresponding
94 ! single-precision versions.
95 module procedure plslabelfunc_impl_data
96 module procedure plslabelfunc_impl
97 module procedure plslabelfunc_impl_null
98 end interface plslabelfunc
99 private :: plslabelfunc_impl_data
100 private :: plslabelfunc_impl
101 private :: plslabelfunc_impl_null
102
103 interface plstransform
104 ! Only provide double-precison versions because of
105 ! disambiguation problems with the corresponding
106 ! single-precision versions.
107 module procedure plstransform_impl_data
108 module procedure plstransform_impl
109 module procedure plstransform_impl_null
110 end interface plstransform
111 private :: plstransform_impl_data
112 private :: plstransform_impl
113 private :: plstransform_impl_null
114
115 ! Routines that have floating-point attributes that can
116 ! be disambiguated.
117 include 'included_plplot_real_interfaces.f90'
118
119 ! Routines that have floating-point attributes that nevertheless
120 ! cannot be disambiguated so we only provide them for the
121 ! double-precision case (rather than using a separate naming
122 ! convention for these routines or some other complexity for users
123 ! to distinguish the double- and single-precision cases).
124
125 ! Return type is not part of the disambiguation so we provide
126 ! one explicit double-precision version rather than both types.
127 function plrandd_impl()
128
129 real(kind=wp) :: plrandd_impl !function type
130
131 interface
132 function interface_plrandd() bind(c,name='c_plrandd')
133 import :: private_plflt
134 implicit none
135 real(kind=private_plflt) :: interface_plrandd !function type
136 end function interface_plrandd
137 end interface
138
139 plrandd_impl = real(interface_plrandd(), kind=wp)
140 end function plrandd_impl
141
142 ! Only provide double-precison version because of disambiguation
143 ! problems with the corresponding single-precision version.
144 subroutine plslabelfunc_impl_data( proc, data )
145 procedure(pllabeler_proc_data) :: proc
146 type(c_ptr), value, intent(in) :: data
147 pllabeler_data => proc
148 call interface_plslabelfunc( c_funloc(pllabelerf2c_data), data )
149 end subroutine plslabelfunc_impl_data
150
151 ! Only provide double-precison version because of disambiguation
152 ! problems with the corresponding single-precision version.
153 subroutine plslabelfunc_impl( proc )
154 procedure(pllabeler_proc) :: proc
155 pllabeler => proc
156 call interface_plslabelfunc( c_funloc(pllabelerf2c), c_null_ptr )
157 end subroutine plslabelfunc_impl
158
160 call interface_plslabelfunc( c_null_funptr, c_null_ptr )
161 end subroutine plslabelfunc_impl_null
162
163 ! Only provide double-precison version because of disambiguation
164 ! problems with the corresponding single-precision version.
165 subroutine plstransform_impl_data( proc, data )
166 procedure(pltransform_proc_data) :: proc
167 type(c_ptr), value, intent(in) :: data
168 pltransform_data => proc
169 call interface_plstransform( c_funloc(pltransformf2c_data), data )
170 end subroutine plstransform_impl_data
171
172 ! Only provide double-precison version because of disambiguation
173 ! problems with the corresponding single-precision version.
174 subroutine plstransform_impl( proc )
175 procedure(pltransform_proc) :: proc
176 pltransform => proc
177 call interface_plstransform( c_funloc(pltransformf2c), c_null_ptr )
178 end subroutine plstransform_impl
179
181 call interface_plstransform( c_null_funptr, c_null_ptr )
182 end subroutine plstransform_impl_null
183
184 ! plflt-precision callback routines that are called from C and which wrap a call to wp-precision Fortran routines.
185
186 subroutine plmapformf2c( n, x, y ) bind(c, name = 'plplot_double_private_plmapformf2c')
187 integer(kind=private_plint), value, intent(in) :: n
188 real(kind=private_plflt), dimension(n), intent(inout) :: x, y
189
190 real(kind=wp), dimension(:), allocatable :: x_inout, y_inout
191
192 allocate(x_inout(n), y_inout(n))
193
194 x_inout = real(x, kind=wp)
195 y_inout = real(y, kind=wp)
196
197 call plmapform( x_inout, y_inout )
198 x = real(x_inout, kind=private_plflt)
199 y = real(y_inout, kind=private_plflt)
200 end subroutine plmapformf2c
201
202 subroutine pllabelerf2c( axis, value, label, length, data ) bind(c, name = 'plplot_double_private_pllabelerf2c')
203 integer(kind=private_plint), value, intent(in) :: axis, length
204 real(kind=private_plflt), value, intent(in) :: value
205 character(len=1), dimension(*), intent(out) :: label
206 type(c_ptr), value, intent(in) :: data
207
208 character(len=:), allocatable :: label_out
209 integer :: trimmed_length
210
211 if ( c_associated(data) ) then
212 write(*,*) 'PLPlot: error in pllabelerf2c - data argument should be NULL'
213 stop
214 endif
215
216 allocate(character(length) :: label_out)
217 call pllabeler( int(axis), real(value,kind=wp), label_out )
218 trimmed_length = min(length,len_trim(label_out) + 1)
219 label(1:trimmed_length) = transfer(trim(label_out(1:length))//c_null_char, " ", trimmed_length)
220 deallocate(label_out)
221 end subroutine pllabelerf2c
222
223 subroutine pllabelerf2c_data( axis, value, label, length, data ) bind(c, name = 'plplot_double_private_pllabelerf2c_data')
224 integer(kind=private_plint), value, intent(in) :: axis, length
225 real(kind=private_plflt), value, intent(in) :: value
226 character(len=1), dimension(*), intent(out) :: label
227 type(c_ptr), value, intent(in) :: data
228
229 character(len=:), allocatable :: label_out
230 integer :: trimmed_length
231
232 allocate(character(length) :: label_out)
233 call pllabeler_data( int(axis), real(value,kind=wp), label_out, data )
234 trimmed_length = min(length,len_trim(label_out) + 1)
235 label(1:trimmed_length) = transfer(trim(label_out(1:length))//c_null_char, " ", trimmed_length)
236 deallocate(label_out)
237 end subroutine pllabelerf2c_data
238
239 subroutine pltransformf2c( x, y, tx, ty, data ) bind(c, name = 'plplot_double_private_pltransformf2c')
240 real(kind=private_plflt), value, intent(in) :: x, y
241 real(kind=private_plflt), intent(out) :: tx, ty
242 type(c_ptr), value, intent(in) :: data
243
244 real(kind=wp) :: tx_out, ty_out
245
246 if ( c_associated(data) ) then
247 write(*,*) 'PLPlot: error in pltransfrom2c - data argument should be NULL'
248 stop
249 endif
250
251 call pltransform( real(x,kind=wp), real(y,kind=wp), tx_out, ty_out )
252 tx = tx_out
253 ty = ty_out
254 end subroutine pltransformf2c
255
256 subroutine pltransformf2c_data( x, y, tx, ty, data ) bind(c, name = 'plplot_double_private_pltransformf2c_data')
257 real(kind=private_plflt), value, intent(in) :: x, y
258 real(kind=private_plflt), intent(out) :: tx, ty
259 type(c_ptr), value, intent(in) :: data
260
261 real(kind=wp) :: tx_out, ty_out
262
263 call pltransform_data( real(x,kind=wp), real(y,kind=wp), tx_out, ty_out, data )
264 tx = tx_out
265 ty = ty_out
266 end subroutine pltransformf2c_data
267
268end module plplot_double
subroutine, private pllabelerf2c_data(axis, value, label, length, data)
integer, parameter, private wp
subroutine, private pllabelerf2c(axis, value, label, length, data)
subroutine, private plslabelfunc_impl_null
subroutine, private plstransform_impl_data(proc, data)
subroutine, private plslabelfunc_impl_data(proc, data)
subroutine, private pltransformf2c_data(x, y, tx, ty, data)
subroutine, private plstransform_impl(proc)
real(kind=wp) function, private plrandd_impl()
subroutine, private plstransform_impl_null
subroutine, private pltransformf2c(x, y, tx, ty, data)
subroutine, private plmapformf2c(n, x, y)
subroutine, private plslabelfunc_impl(proc)
subroutine character_array_to_c(cstring_array, cstring_address, character_array)
integer, parameter private_double
integer, parameter private_plbool
integer, parameter private_plint
#define min(x, y)
Definition: nnpi.c:87