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