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