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
26module plplot_double
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
29    use plplot_types, only: private_plflt, private_plint, private_plbool, private_double, PLcGrid, PLfGrid
30    use plplot_private_exposed
31    use plplot_private_utilities, only: character_array_to_c
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
42    private :: plmapformf2c, pllabelerf2c, pllabelerf2c_data, pltransformf2c, pltransformf2c_data
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
159    subroutine plslabelfunc_impl_null
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
180    subroutine plstransform_impl_null
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
269