1!! Copyright (C) 2002-2006 M. Marques, A. Castro, A. Rubio, G. Bertsch 2!! 3!! This program is free software; you can redistribute it and/or modify 4!! it under the terms of the GNU General Public License as published by 5!! the Free Software Foundation; either version 2, or (at your option) 6!! any later version. 7!! 8!! This program is distributed in the hope that it will be useful, 9!! but WITHOUT ANY WARRANTY; without even the implied warranty of 10!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11!! GNU General Public License for more details. 12!! 13!! You should have received a copy of the GNU General Public License 14!! along with this program; if not, write to the Free Software 15!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 16!! 02110-1301, USA. 17!! 18 19#include "global.h" 20 21module string_oct_m 22 use iso_c_binding 23 use loct_oct_m 24 25 implicit none 26 27 private 28 public :: & 29 compact, & 30 add_last_slash, & 31 str_trim, & 32 str_center, & 33 print_C_string, & 34 conv_to_C_string, & 35 string_f_to_c, & 36 string_c_to_f, & 37 string_c_ptr_to_f 38 39contains 40 41 ! --------------------------------------------------------- 42 !> Removes all spaces from a string 43 !! \date 15-OCT-2000: First version 44 !! \author Fernando Nogueira 45 subroutine compact(str) 46 character(len=*), intent(inout) :: str 47 48 integer :: i, j 49 50 j = 1 51 do i = 1, len(str) 52 if(str(i:i) /= ' ') then 53 str(j:j) = str(i:i) 54 j = j + 1 55 end if 56 end do 57 do i = j, len(str) 58 str(i:i) = ' ' 59 end do 60 61 end subroutine compact 62 63 ! --------------------------------------------------------- 64 !> Adds a '/' in the end of the string, only if it missing. 65 !! Useful for directories 66 subroutine add_last_slash(str) 67 character(len=*), intent(inout) :: str 68 69 character(64) :: tmp_str 70 71 if (index(str, '/', .true.) /= len_trim(str)) then 72 tmp_str = str 73 write(str,'(a,a1)') trim(tmp_str), '/' 74 end if 75 end subroutine add_last_slash 76 77 78 ! --------------------------------------------------------- 79 !> removes leading spaces from string 80 subroutine str_trim(str) 81 character (len=*), intent(inout) :: str 82 integer :: i, j, l 83 84 l = len(str) 85 do i = 1, l 86 if(str(i:i) /= ' ') exit 87 end do 88 89 do j = 1, l - i + 1 90 str(j:j) = str(i:i) 91 i = i + 1 92 end do 93 94 do i = j, l 95 str(j:j) = ' ' 96 end do 97 98 end subroutine str_trim 99 100 ! --------------------------------------------------------- 101 !> puts space around string, so that it is centered 102 character(len=80) function str_center(s_in, l_in) result(s_out) 103 character(len=*), intent(in) :: s_in 104 integer, intent(in) :: l_in 105 106 integer :: pad, i, li, l 107 108 l = min(80, l_in) 109 li = len(s_in) 110 if(l < li) then 111 s_out(1:l) = s_in(1:l) 112 return 113 end if 114 115 pad = (l - li)/2 116 117 s_out = "" 118 do i = 1, pad 119 s_out(i:i) = " " 120 end do 121 s_out(pad + 1:pad + li) = s_in(1:li) 122 do i = pad + li + 1, l 123 s_out(i:i) = " " 124 end do 125 126 end function str_center 127 128 ! --------------------------------------------------------- 129 !> prints the C string given by the pointer str 130 subroutine print_C_string(iunit, str, pre, advance) 131 integer, intent(in) :: iunit 132 type(c_ptr), intent(in) :: str 133 character(len=*), optional, intent(in) :: pre 134 character(len=*), optional, intent(in) :: advance 135 136 type(c_ptr) :: s 137 character(len=256) :: line 138 character(len=5) :: advance_ 139 140 advance_ = "yes" 141 if(present(advance)) advance_ = advance 142 143 s = c_null_ptr 144 do 145 call loct_break_C_string(str, s, line) 146 if (.not. c_associated(s)) exit 147 if(present(pre)) then 148 write(iunit, '(a,a)', advance=advance_) pre, trim(line) 149 else 150 write(iunit, '(a)', advance=advance_) trim(line) 151 end if 152 end do 153 end subroutine print_C_string 154 155 ! --------------------------------------------------------- 156 !> converts to c string 157 subroutine conv_to_C_string(str) 158 character(len=*), intent(out) :: str 159 160 integer :: j 161 162 j = len(trim(str)) 163 str(j+1:j+1) = achar(0) 164 end subroutine conv_to_C_string 165 166 ! Helper functions to convert between C and Fortran strings 167 ! Based on the routines by Joseph M. Krahn 168 169 ! --------------------------------------------------------- 170 function string_f_to_c(f_string) result(c_string) 171 character(len=*), intent(in) :: f_string 172 character(kind=c_char,len=1) :: c_string(len_trim(f_string)+1) 173 174 integer :: i, strlen 175 176 strlen = len_trim(f_string) 177 178 do i = 1, strlen 179 c_string(i) = f_string(i:i) 180 end do 181 c_string(strlen+1) = C_NULL_CHAR 182 183 end function string_f_to_c 184 185 ! --------------------------------------------------------- 186 subroutine string_c_to_f(c_string, f_string) 187 character(kind=c_char,len=1), intent(in) :: c_string(*) 188 character(len=*), intent(out) :: f_string 189 190 integer :: i 191 192 i = 1 193 do while(c_string(i) /= C_NULL_CHAR .and. i <= len(f_string)) 194 f_string(i:i) = c_string(i) 195 i = i + 1 196 end do 197 if (i < len(f_string)) f_string(i:) = ' ' 198 199 end subroutine string_c_to_f 200 201 ! --------------------------------------------------------- 202 subroutine string_c_ptr_to_f(c_string, f_string) 203 type(c_ptr), intent(in) :: c_string 204 character(len=*), intent(out) :: f_string 205 206 character(len=1, kind=c_char), pointer :: p_chars(:) 207 integer :: i 208 209 if (.not. c_associated(c_string)) then 210 f_string = ' ' 211 else 212 call c_f_pointer(c_string, p_chars, [huge(0)]) 213 i = 1 214 do while(p_chars(i) /= C_NULL_CHAR .and. i <= len(f_string)) 215 f_string(i:i) = p_chars(i) 216 i = i + 1 217 end do 218 if (i < len(f_string)) f_string(i:) = ' ' 219 end if 220 221 end subroutine string_c_ptr_to_f 222 223end module string_oct_m 224 225!! Local Variables: 226!! mode: f90 227!! coding: utf-8 228!! End: 229