source: LMDZ5/branches/IPSLCM6.0.10/libf/phymar/strhandler.F90 @ 3172

Last change on this file since 3172 was 2160, checked in by Laurent Fairhead, 10 years ago

Merged trunk changes -r2070:2158 into testing branch. Compilation problems introduced by revision r2155 have been corrected by hand

File size: 3.9 KB
Line 
1!OPTIONS NOOPT
2MODULE strhandler
3
4#include "tsmbkind.h"
5
6IMPLICIT NONE
7
8PRIVATE
9
10PUBLIC :: tolower, toupper, expand_string
11PUBLIC :: sadjustl, sadjustr
12
13CONTAINS
14
15FUNCTION sadjustl(s) RESULT(c)
16
17character(len=*), intent(in) :: s
18character(len=max(1,len(s))) c
19c = ' '
20if (len(s) > 0) then
21  if (s /= ' ') c = adjustl(s)
22endif
23END FUNCTION sadjustl
24
25FUNCTION sadjustr(s) RESULT(c)
26
27character(len=*), intent(in) :: s
28character(len=max(1,len(s))) c
29c = ' '
30if (len(s) > 0) then
31  if (s /= ' ') c = adjustr(s)
32endif
33END FUNCTION sadjustr
34
35SUBROUTINE tolower(cds)
36
37character(len=*), intent(inout) :: cds
38INTEGER_M, parameter :: ich_a = ichar('a')
39INTEGER_M, parameter :: ichA  = ichar('A')
40INTEGER_M, parameter :: ichZ  = ichar('Z')
41INTEGER_M :: i, ich, new_ich
42character(len=1) ch
43do i=1,len(cds)
44  ch = cds(i:i)
45  ich = ichar(ch)
46  if ( ich >= ichA .and. ich <= ichZ ) then
47    new_ich = ich + (ich_a - ichA)
48    ch = char(new_ich)
49    cds(i:i) = ch
50  endif
51enddo
52END SUBROUTINE tolower
53
54
55SUBROUTINE toupper(cds)
56
57character(len=*), intent(inout) :: cds
58INTEGER_M, parameter :: ich_A = ichar('A')
59INTEGER_M, parameter :: icha  = ichar('a')
60INTEGER_M, parameter :: ichz  = ichar('z')
61INTEGER_M :: i, ich, new_ich
62character(len=1) ch
63do i=1,len(cds)
64  ch = cds(i:i)
65  ich = ichar(ch)
66  if ( ich >= icha .and. ich <= ichz ) then
67    new_ich = ich + (ich_A - icha)
68    ch = char(new_ich)
69    cds(i:i) = ch
70  endif
71enddo
72END SUBROUTINE toupper
73
74
75SUBROUTINE expand_string(&
76     &myproc,               &! %p
77     &nproc,                &! %n
78     &timestep,             &! %t
79     &max_timestep,&
80     &s)                   ! %s
81
82INTEGER_M, intent(in)          :: myproc, nproc
83INTEGER_M, intent(in)          :: timestep, max_timestep
84character(len=*), intent(inout) :: s(:)
85character(len=2*len(s))  t
86character(len=2*len(s)) tt
87INTEGER_M :: i, j, jj, loc_p, len_t, n
88INTEGER_M :: ndigs(4), num(4)
89character(len=6) fmt(4)
90
91n = size(s)
92
93if (n < 1) return
94
95!*    Setup output formats
96num(1) = myproc
97num(2) = max(nproc,myproc)
98num(3) = n
99num(4) = max(max_timestep,timestep)
100
101!*    Count number of digits in each integer
102do j=1,4
103  ndigs(j) = 1
104  if (num(j) /= 0) then
105    ndigs(j) = 1 + log10(dble(abs(num(j))))
106    if (num(j) < 0) ndigs(j) = ndigs(j) + 1 ! Room for minus sign
107  endif
108  ndigs(j) = min(int(ndigs(j)),9)   ! Max 9 digits supported; i.e. '999999999'
109  write(fmt(j),'("(i",i1,")")') ndigs(j)
110enddo
111
112
113!*    Expand fields '%s', '%p', '%n' and '%t' with their values
114
115
116!*    A special treatment with the sequence numbering
117if (n>1) then
118  loc_p = index(s(1),'%s')
119  if (loc_p > 0) then
120    s(2:) = s(1)
121  endif
122endif
123
124do i=1,n
125  t = adjustl(s(i))//' '
126  loc_p = index(t,'%')
127
128  if (loc_p > 0) then
129    len_t = len_trim(t)
130    j = loc_p
131    tt(:j-1) = t(:j-1)
132    tt(j:) = ' '
133    jj = j-1
134
135    do while (j <= len_t)
136      if (t(j:j) == '%') then
137        j = j + 1
138        if (j <= len_t) then
139          select case ( t(j:j) )
140          case ( 'p' )   ! myproc
141          write(tt(jj+1:jj+ndigs(1)),fmt(1)) myproc
142          jj = jj + ndigs(1)
143          case ( 'n' )   ! nproc
144          write(tt(jj+1:jj+ndigs(2)),fmt(2)) nproc
145          jj = jj + ndigs(2)
146          case ( 's' )   ! sequence number i=[1..n]
147          write(tt(jj+1:jj+ndigs(3)),fmt(3)) i
148          jj = jj + ndigs(3)
149          case ( 't' )   ! timestep
150          write(tt(jj+1:jj+ndigs(4)),fmt(4)) timestep
151          jj = jj + ndigs(4)
152          case default
153          tt(jj+1:jj+2) = '%'//t(j:j)
154          jj = jj + 2
155          end select
156        else
157          tt(jj+1:jj+1) = '%'
158          jj = jj + 1
159        endif
160      else
161        tt(jj+1:jj+1) = t(j:j)
162        jj = jj + 1
163      endif
164      j = j + 1
165    enddo
166
167    t = adjustl(tt)
168
169!*   Get also rid of any blanks in the middle of the string
170
171    len_t = len_trim(t)
172    j = 1
173    do while (j < len_t)
174      if (t(j:j) == ' ') then
175        t(j:) = t(j+1:)
176        len_t = len_trim(t)
177      else
178        j = j + 1
179      endif
180    enddo
181
182  endif
183
184  s(i) = t
185enddo
186
187END SUBROUTINE expand_string
188
189END MODULE strhandler
Note: See TracBrowser for help on using the repository browser.