1
2module fdf_extra
3
4  ! Module which extends the fdf routines
5  ! by a little...
6  use fdf
7  use m_region
8
9  implicit none
10
11  private
12
13  public :: fdf_bnext
14  public :: fdf_brange
15  public :: fdf_bregions
16
17contains
18
19  function fdf_bnext(bfdf,pline) result(has)
20    type(block_fdf), intent(inout) :: bfdf
21    type(parsed_line), pointer :: pline
22    logical :: has
23    do
24      has = fdf_bline(bfdf,pline)
25      if ( .not. has ) return
26      if ( fdf_bntokens(pline) > 0 ) return
27    end do
28
29  end function fdf_bnext
30
31  !> Read a range of integers from a parsed line
32  !!
33  !! It returns the list of integers in a `tRng` object.
34  subroutine fdf_brange(pline,r, low, high)
35    type(parsed_line), pointer :: pline
36    type(tRgn), intent(out) :: r
37    ! Practically min/max for the region
38    ! in question, however, it allows for
39    ! specifying negative numbers.
40    integer, intent(in) :: low, high
41
42    integer :: j, n, i, i1, i2, il, nl, step
43    integer, allocatable :: list(:)
44    character(len=32) :: g
45
46    ! We allocate a temporary list
47    allocate(list(high-low+1))
48
49    ! Number of read elements
50    n = 0
51
52    ! If lists exists, we use those
53    if ( fdf_bnnames(pline) == 1 ) then
54
55      ! Get number of lists on current line
56      nl = fdf_bnlists(pline)
57
58      if ( nl == 0 ) then
59
60        ! The input line is a simple list of integers
61        do j = 1 , fdf_bnintegers(pline)
62          i = fdf_bintegers(pline,j)
63          n = n + 1
64          list(n) = correct(i,low,high)
65        end do
66
67      else
68
69        do il = 1, nl
70
71          ! Read in number of items
72          i1 = -1
73          call fdf_blists(pline,il,i1,list(n+1:))
74          if ( i1 + n > size(list) ) then
75            print *,'Parsed line: ',trim(pline%line)
76            call die('fdf_brange: number of elements in block list &
77                &is too many to fit the maximal range of the &
78                &list. Please correct.')
79          end if
80          if ( i1 == 0 ) then
81            print *,'Parsed line: ',trim(pline%line)
82            call die('fdf_brange: a block list with zero elements is not &
83                &allowed, please correct input.')
84          end if
85
86          ! Read in actual list
87          call fdf_blists(pline,il,i1,list(n+1:n+i1))
88
89          do i = 1 , i1
90            list(n+i) = correct(list(n+i),low,high)
91          end do
92
93          ! update n
94          n = n + i1
95
96        end do
97
98      end if
99
100    else if ( fdf_bnnames(pline) == 3 ) then
101
102      g = fdf_bnames(pline,2)
103      if ( .not. leqi(g,'from') ) then
104        print *,'Parsed line: ',trim(pline%line)
105        call die('fdf_brange: error in range block: &
106            &from <int> to/plus/minus <int> is ill formatted')
107      end if
108
109      g = fdf_bnames(pline,3)
110      if ( fdf_bnintegers(pline) < 2 ) then
111        print *,'Parsed line: ',trim(pline%line)
112        call die('fdf_brange: error in range block &
113            &from <int> to/plus/minus <int> is ill formatted')
114      end if
115
116      ! Read in arguments
117      i1 = fdf_bintegers(pline,1)
118      i2 = fdf_bintegers(pline,2)
119      if ( fdf_bnintegers(pline) > 2 ) then
120        step = fdf_bnintegers(pline,3)
121        if ( step == 0 ) &
122            call die('fdf_extra: stepping MUST be different from 0')
123      else
124        step = 0
125      end if
126
127      ! Check how the arguments are read
128      if ( leqi(g,'to') ) then
129        ! do nothing....
130      else if ( leqi(g,'plus') ) then
131        i2 = i1 + i2 - 1
132      else if ( leqi(g,'minus') ) then
133        ! possibly correct step
134        if ( step > 0 ) step = - step
135        i2 = i1 - i2 + 1
136      else
137        print *,'Parsed line: ',trim(pline%line)
138        call die('fdf_brange: unrecognized designator of ending range, &
139            &[to, plus, minus] accepted.')
140      end if
141
142      ! Figure out the step-level
143      if ( step == 0 ) then
144        if ( i1 <= i2 ) then
145          step = 1
146        else
147          step = -1
148        end if
149      end if
150
151      ! Check input for list creation
152      if ( (i1 < i2 .and. step < 0) .or. &
153          (i1 > i2 .and. step > 0) ) then
154        print *,'Parsed line: ',trim(pline%line)
155        print *,i1,i2,step
156        call die('fdf_brange: block range is not consecutive')
157      end if
158
159      ! Create list
160      do i = i1 , i2 , step
161        n = n + 1
162        ! correct for wrap-arounds
163        list(n) = correct(i,low,high)
164      end do
165
166    else
167
168      print *,'Parsed line: ',trim(pline%line)
169      call die('fdf_brange: error in range block, input not recognized')
170
171    end if
172
173    do j = 1 , n
174      if ( list(j) < low .or. high < list(j) ) then
175        print *,'Parsed line: ',trim(pline%line)
176        call die('fdf_brange: error in range block. Input is beyond range')
177      end if
178    end do
179
180    call rgn_list(r,n,list)
181    deallocate(list)
182
183  contains
184
185    pure function correct(in,low,high) result(out)
186      integer, intent(in) :: in, low, high
187      integer :: out
188      if ( low == 1 .and. high >= low ) then
189        ! Special case, we use wrap-arounds
190        out = in
191        if ( out == 0 ) then
192          ! this is not allowed
193          return
194        end if
195        if ( out < 0 ) then
196          ! correct for the zero-base
197          out = out + 1
198          do while ( out < 1 )
199            out = out + high
200          end do
201        end if
202        if ( out > high ) then
203          do while ( high < out )
204            out = out - high
205          end do
206        end if
207      else
208        if ( in < low ) then
209          out = high + in + 1
210        else if ( high < in ) then
211          out = in - high + low - 1
212        else
213          out = in
214        end if
215      end if
216
217    end function correct
218
219  end subroutine fdf_brange
220
221  subroutine fdf_bregions(bName, n, n_r, rgns)
222
223    ! Name of block
224    character(len=*), intent(in) :: bName
225    ! Wrapper counter
226    integer, intent(in) :: n
227    ! Number of regions found
228    integer, intent(out) :: n_r
229    type(tRgn), intent(inout), allocatable :: rgns(:)
230
231    ! ** local variables
232    type(block_fdf) :: bfdf
233    type(parsed_line), pointer :: pline => null()
234    type(tRgn) :: r1
235    integer :: i, il, ic
236    character(len=64) :: g
237    character(len=64), allocatable :: rlist(:)
238    logical :: found
239
240    n_r = 0
241    if ( allocated(rgns) ) deallocate(rgns)
242
243    ! Get number of regions
244    il = fdf_block_linecount(bName)
245    if ( il == 0 ) return
246
247    if ( .not. fdf_block(bName,bfdf) ) then
248      call die('fdf_bregions: failed implementation.')
249    end if
250
251    ! allocate
252    allocate(rlist(il))
253
254    ! first count number of differently named regions
255    do while ( fdf_bnext(bfdf,pline) )
256
257      found = .false.
258      if ( n_r > 0 ) then
259        g = fdf_bnames(pline,1)
260        do i = 1 , n_r
261          if ( leqi(g,rlist(i)) ) then
262            found = .true.
263            exit
264          end if
265        end do
266      end if
267      if ( .not. found ) then
268        n_r = n_r + 1
269        rlist(n_r) = g
270      end if
271
272    end do
273
274    ! Clean-up
275    deallocate(rlist)
276    call fdf_brewind(bfdf)
277
278    allocate(rgns(0:n_r))
279
280    il = 0
281    do while ( fdf_bnext(bfdf,pline) )
282
283      g = fdf_bnames(pline,1)
284
285      ! Check if the name already has been read (then
286      ! we accumulate the atoms)
287      found = .false.
288      ic = il + 1
289      if ( il > 0 ) then
290        do i = 1 , il
291          if ( leqi(g,rgns(i)%name) ) then
292            ic = i
293            exit
294          end if
295        end do
296      end if
297      if ( ic == il + 1 ) then
298        ! we have a new name
299        il = ic
300
301        ! We can read in a range
302        call fdf_brange(pline,r1,1,n)
303        if ( r1%n == 0 ) then
304          print *,'Region: ',trim(g)
305          call die('fdf_bregions: Could not read in anything in region!')
306        end if
307        call rgn_union(rgns(il),r1,rgns(il))
308        rgns(il)%name = trim(g)
309
310      else
311
312        call fdf_brange(pline,r1,1,n)
313        if ( r1%n == 0 ) then
314          print *,'Region: ',trim(g)
315          call die('fdf_bregions: Could not read in anything in region!')
316        end if
317        call rgn_union(rgns(ic),r1,rgns(ic))
318        rgns(ic)%name = trim(g)
319
320      end if
321
322    end do
323
324    call rgn_delete(r1)
325
326  end subroutine fdf_bregions
327
328end module fdf_extra
329