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