mirror of https://gitlab.com/QEF/q-e.git
418 lines
12 KiB
Fortran
418 lines
12 KiB
Fortran
!
|
|
! Copyright (C) 2001-2004 Carlo Cavazzoni and PWSCF group
|
|
! This file is distributed under the terms of the
|
|
! GNU General Public License. See the file `License'
|
|
! in the root directory of the present distribution,
|
|
! or http://www.gnu.org/copyleft/gpl.txt .
|
|
!
|
|
!
|
|
! ... SUBROUTINE field_count: accepts two string (one of them is optional)
|
|
! and one integer and count the number of fields
|
|
! in the string separated by a blank or a tab
|
|
! character. If the optional string is specified
|
|
! (it has anyway len=1) it is assumed as the
|
|
! separator character.
|
|
! Ignores any character following the exclamation
|
|
! mark (fortran comment)
|
|
!
|
|
! ... SUBROUTINE con_cam: counts the number of fields in a string
|
|
! separated by the optional character
|
|
!
|
|
! ... SUBROUTINE field_compare: accepts two strings and one integer. Counts the
|
|
! fields contained in the first string and
|
|
! compares it with the integer.
|
|
! If they are less than the integer calls the
|
|
! routine error and show by the second string the
|
|
! name of the field where read-error occurred.
|
|
!
|
|
! ... SUBROUTINE version_parse: Determine the major, minor and patch numbers
|
|
! from a version string with the fmt "i.j.k"
|
|
!
|
|
! ... FUNCTION version_compare: Compare two version strings; the result can be
|
|
! "newer", "equal", "older", ""
|
|
!
|
|
!
|
|
!----------------------------------------------------------------------------
|
|
MODULE parser
|
|
!----------------------------------------------------------------------------
|
|
!
|
|
USE io_global, ONLY : stdout
|
|
USE kinds, ONLY : DP
|
|
!
|
|
PRIVATE
|
|
!
|
|
PUBLIC :: parse_unit, field_count, read_line, get_field
|
|
PUBLIC :: version_parse, version_compare
|
|
!
|
|
INTEGER :: parse_unit = 5 ! normally 5, but can be set otherwise
|
|
!
|
|
CONTAINS
|
|
!
|
|
!
|
|
!--------------------------------------------------------------------------
|
|
PURE SUBROUTINE field_count( num, line, car )
|
|
!--------------------------------------------------------------------------
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(OUT) :: num
|
|
CHARACTER(LEN=*), INTENT(IN) :: line
|
|
CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: car
|
|
#if defined (__XLF)
|
|
! ... with the IBM xlf compiler some combination of flags lead to
|
|
! ... variables being defined as static, hence giving a conflict
|
|
! ... with PURE function. We then force the variable to be AUTOMATIC
|
|
CHARACTER(LEN=1), AUTOMATIC :: sep1, sep2
|
|
INTEGER, AUTOMATIC :: j
|
|
#else
|
|
CHARACTER(LEN=1) :: sep1, sep2
|
|
INTEGER :: j
|
|
#endif
|
|
!
|
|
!
|
|
num = 0
|
|
!
|
|
IF ( .NOT. present(car) ) THEN
|
|
!
|
|
sep1 = char(32) ! ... blank character
|
|
sep2 = char(9) ! ... tab character
|
|
!
|
|
DO j = 2, MAX( LEN( line ), 256 )
|
|
!
|
|
IF ( line(j:j) == '!' .OR. line(j:j) == char(0) ) THEN
|
|
!
|
|
IF ( line(j-1:j-1) /= sep1 .AND. line(j-1:j-1) /= sep2 ) THEN
|
|
!
|
|
num = num + 1
|
|
!
|
|
END IF
|
|
!
|
|
EXIT
|
|
!
|
|
END IF
|
|
!
|
|
IF ( ( line(j:j) == sep1 .OR. line(j:j) == sep2 ) .AND. &
|
|
( line(j-1:j-1) /= sep1 .AND. line(j-1:j-1) /= sep2 ) ) THEN
|
|
!
|
|
num = num + 1
|
|
!
|
|
END IF
|
|
!
|
|
END DO
|
|
!
|
|
ELSE
|
|
!
|
|
sep1 = car
|
|
!
|
|
DO j = 2, MAX( LEN( line ), 256 )
|
|
!
|
|
IF ( line(j:j) == '!' .OR. &
|
|
line(j:j) == char(0) .OR. line(j:j) == char(32) ) THEN
|
|
!
|
|
IF ( line(j-1:j-1) /= sep1 ) num = num + 1
|
|
!
|
|
EXIT
|
|
!
|
|
END IF
|
|
!
|
|
IF ( line(j:j) == sep1 .AND. line(j-1:j-1) /= sep1 ) num = num + 1
|
|
!
|
|
END DO
|
|
!
|
|
END IF
|
|
!
|
|
RETURN
|
|
!
|
|
END SUBROUTINE field_count
|
|
!
|
|
!
|
|
!--------------------------------------------------------------------------
|
|
SUBROUTINE read_line( line, nfield, field, end_of_file, error )
|
|
!--------------------------------------------------------------------------
|
|
!
|
|
USE mp, ONLY : mp_bcast
|
|
USE mp_images, ONLY : intra_image_comm
|
|
USE io_global, ONLY : ionode, ionode_id
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
CHARACTER(LEN=*), INTENT(OUT) :: line
|
|
CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: field
|
|
INTEGER, OPTIONAL, INTENT(IN) :: nfield
|
|
LOGICAL, OPTIONAL, INTENT(OUT) :: end_of_file, error
|
|
LOGICAL :: tend, terr
|
|
!
|
|
!
|
|
IF( LEN( line ) < 256 ) THEN
|
|
CALL errore(' read_line ', ' input line too short ', MAX(LEN(line),1) )
|
|
END IF
|
|
!
|
|
tend = .FALSE.
|
|
terr = .FALSE.
|
|
IF ( ionode ) THEN
|
|
30 READ (parse_unit, fmt='(A256)', ERR=15, END=10) line
|
|
IF( line == ' ' .OR. line(1:1) == '#' ) GO TO 30
|
|
GO TO 20
|
|
10 tend = .TRUE.
|
|
GO TO 20
|
|
15 terr = .TRUE.
|
|
20 CONTINUE
|
|
END IF
|
|
!
|
|
CALL mp_bcast( tend, ionode_id, intra_image_comm )
|
|
CALL mp_bcast( terr, ionode_id, intra_image_comm )
|
|
CALL mp_bcast( line, ionode_id, intra_image_comm )
|
|
!
|
|
IF( PRESENT(end_of_file) ) THEN
|
|
end_of_file = tend
|
|
ELSE IF( tend ) THEN
|
|
CALL infomsg(' read_line ', ' end of file ' )
|
|
END IF
|
|
IF( PRESENT(error) ) THEN
|
|
error = terr
|
|
ELSE IF( terr ) THEN
|
|
CALL infomsg(' read_line ', ' read error ' )
|
|
END IF
|
|
IF( PRESENT(field) .and. .not.(tend.or.terr) ) &
|
|
&CALL field_compare( line, nfield, field )
|
|
!
|
|
END SUBROUTINE read_line
|
|
!
|
|
!
|
|
!--------------------------------------------------------------------------
|
|
SUBROUTINE field_compare( str, nf, var )
|
|
!--------------------------------------------------------------------------
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
CHARACTER(LEN=*), INTENT(IN) :: var
|
|
INTEGER, INTENT(IN) :: nf
|
|
CHARACTER(LEN=*), INTENT(IN) :: str
|
|
INTEGER :: nc
|
|
!
|
|
CALL field_count( nc, str )
|
|
!
|
|
IF( nc < nf ) &
|
|
CALL errore( ' field_compare ', &
|
|
& ' wrong number of fields: ' // TRIM( var ), 1 )
|
|
!
|
|
RETURN
|
|
!
|
|
END SUBROUTINE field_compare
|
|
!
|
|
!
|
|
!--------------------------------------------------------------------------
|
|
SUBROUTINE con_cam(num, line, car)
|
|
!--------------------------------------------------------------------------
|
|
CHARACTER(LEN=*) :: line
|
|
CHARACTER(LEN=1) :: sep
|
|
CHARACTER(LEN=1), OPTIONAL :: car
|
|
INTEGER :: num, j
|
|
|
|
num = 0
|
|
IF (len(line) .GT. 256 ) THEN
|
|
WRITE( stdout,*) 'riga ', line
|
|
WRITE( stdout,*) 'lunga ', len(line)
|
|
num = -1
|
|
RETURN
|
|
END IF
|
|
|
|
WRITE( stdout,*) '1riga ', line
|
|
WRITE( stdout,*) '1lunga ', len(line)
|
|
IF ( .NOT. present(car) ) THEN
|
|
sep=char(32) !char(32) is the blank character
|
|
ELSE
|
|
sep=car
|
|
END IF
|
|
|
|
DO j=2, MAX(len(line),256)
|
|
IF ( line(j:j) == '!' .OR. line(j:j) == char(0)) THEN
|
|
RETURN
|
|
END IF
|
|
IF ( (line(j:j) .EQ. sep) .AND. &
|
|
(line(j-1:j-1) .NE. sep) ) THEN
|
|
num = num + 1
|
|
END IF
|
|
END DO
|
|
RETURN
|
|
END SUBROUTINE con_cam
|
|
!
|
|
!--------------------------------------------------------------------------
|
|
SUBROUTINE version_parse(str, major, minor, patch, ierr)
|
|
!--------------------------------------------------------------------------
|
|
!
|
|
! Determine the major, minor and patch numbers from
|
|
! a version string with the fmt "i.j.k"
|
|
!
|
|
! The ierr variable assumes the following values
|
|
!
|
|
! ierr < 0 emtpy string
|
|
! ierr = 0 no problem
|
|
! ierr > 0 fatal error
|
|
!
|
|
IMPLICIT NONE
|
|
CHARACTER(*), INTENT(in) :: str
|
|
INTEGER, INTENT(out) :: major, minor, patch, ierr
|
|
!
|
|
INTEGER :: i1, i2, length
|
|
INTEGER :: ierrtot
|
|
CHARACTER(10) :: num(3)
|
|
|
|
!
|
|
major = 0
|
|
minor = 0
|
|
patch = 0
|
|
|
|
length = LEN_TRIM( str )
|
|
!
|
|
IF ( length == 0 ) THEN
|
|
!
|
|
ierr = -1
|
|
RETURN
|
|
!
|
|
ENDIF
|
|
|
|
i1 = SCAN( str, ".")
|
|
i2 = SCAN( str, ".", BACK=.TRUE.)
|
|
!
|
|
IF ( i1 == 0 .OR. i2 == 0 .OR. i1 == i2 ) THEN
|
|
!
|
|
ierr = 1
|
|
RETURN
|
|
!
|
|
ENDIF
|
|
!
|
|
num(1) = str( 1 : i1-1 )
|
|
num(2) = str( i1+1 : i2-1 )
|
|
num(3) = str( i2+1 : )
|
|
!
|
|
ierrtot = 0
|
|
!
|
|
READ( num(1), *, IOSTAT=ierr ) major
|
|
IF (ierr/=0) RETURN
|
|
!
|
|
READ( num(2), *, IOSTAT=ierr ) minor
|
|
IF (ierr/=0) RETURN
|
|
!
|
|
READ( num(3), *, IOSTAT=ierr ) patch
|
|
IF (ierr/=0) RETURN
|
|
!
|
|
END SUBROUTINE version_parse
|
|
!
|
|
!--------------------------------------------------------------------------
|
|
FUNCTION version_compare(str1, str2)
|
|
!--------------------------------------------------------------------------
|
|
!
|
|
! Compare two version strings; the result is
|
|
!
|
|
! "newer": str1 is newer that str2
|
|
! "equal": str1 is equal to str2
|
|
! "older": str1 is older than str2
|
|
! " ": str1 or str2 has a wrong format
|
|
!
|
|
IMPLICIT NONE
|
|
CHARACTER(*) :: str1, str2
|
|
CHARACTER(10) :: version_compare
|
|
!
|
|
INTEGER :: version1(3), version2(3)
|
|
INTEGER :: basis, icheck1, icheck2
|
|
INTEGER :: ierr
|
|
!
|
|
|
|
version_compare = " "
|
|
!
|
|
CALL version_parse( str1, version1(1), version1(2), version1(3), ierr)
|
|
IF ( ierr/=0 ) RETURN
|
|
!
|
|
CALL version_parse( str2, version2(1), version2(2), version2(3), ierr)
|
|
IF ( ierr/=0 ) RETURN
|
|
!
|
|
!
|
|
basis = 1000
|
|
!
|
|
icheck1 = version1(1) * basis**2 + version1(2)* basis + version1(3)
|
|
icheck2 = version2(1) * basis**2 + version2(2)* basis + version2(3)
|
|
!
|
|
IF ( icheck1 > icheck2 ) THEN
|
|
!
|
|
version_compare = 'newer'
|
|
!
|
|
ELSEIF( icheck1 == icheck2 ) THEN
|
|
!
|
|
version_compare = 'equal'
|
|
!
|
|
ELSE
|
|
!
|
|
version_compare = 'older'
|
|
!
|
|
ENDIF
|
|
!
|
|
END FUNCTION version_compare
|
|
!
|
|
!--------------------------------------------------------------------------
|
|
SUBROUTINE get_field(n, field, str, sep)
|
|
!--------------------------------------------------------------------------
|
|
! Extract whitespace-separated nth block from string
|
|
IMPLICIT NONE
|
|
INTEGER,INTENT(IN) :: n
|
|
CHARACTER(len=*),INTENT(OUT) :: field
|
|
CHARACTER(len=*),INTENT(IN) :: str
|
|
CHARACTER(len=1),OPTIONAL,INTENT(IN) :: sep
|
|
INTEGER :: i,j,z ! block start and end
|
|
INTEGER :: k ! block counter
|
|
CHARACTER(len=1) :: sep1, sep2
|
|
!print*, "------------- parser start -------------"
|
|
!print '(3a)', "string: -->", str,"<--"
|
|
IF(present(sep)) THEN
|
|
sep1 = sep
|
|
sep2 = sep ! redundant, but easy
|
|
ELSE
|
|
sep1 = char(32) ! ... blank character
|
|
sep2 = char(9) ! ... tab char
|
|
ENDIF
|
|
!
|
|
k = 1 ! counter for the required block
|
|
!
|
|
DO i = 1,len(str)
|
|
! look for the beginning of the required block
|
|
z = MAX(i-1,1)
|
|
!print '(2a1,3i4,2l)', str(i:i), str(z:z), i,z,k,n,&
|
|
! (str(i:i) == sep1 .or. str(i:i) == sep2), (str(z:z) /= sep1 .and. str(z:z) /= sep2)
|
|
IF( k == n) EXIT
|
|
IF( (str(i:i) == sep1 .or. str(i:i) == sep2) &
|
|
.and. &
|
|
(str(z:z) /= sep1 .and. str(z:z) /= sep2) &
|
|
) &
|
|
k = k+1
|
|
ENDDO
|
|
!
|
|
!print*, "i found: ",i
|
|
DO j = i,len(str)
|
|
! look for the beginning of the next block
|
|
z = MAX(j-1,1)
|
|
IF( (str(j:j) == sep1 .or. str(j:j) == sep2) &
|
|
.and. &
|
|
(str(z:z) /= sep1 .and. str(z:z) /= sep2) &
|
|
) &
|
|
k = k+1
|
|
IF( k >n) EXIT
|
|
ENDDO
|
|
!print*, "j found: ",j
|
|
!
|
|
IF (j <= len(str)) THEN
|
|
! if we are here, the reqired block was followed by a separator
|
|
! and another field, we have to trash one char (a separator)
|
|
field = TRIM(adjustl(str(i:j-1)))
|
|
!print*, "taking: ",i,j-2
|
|
ELSE
|
|
! if we are here, it was the last block in str, we have to take
|
|
! all the remaining chars
|
|
field = TRIM(adjustl(str(i:len(str))))
|
|
!print*, "taking from ",i
|
|
ENDIF
|
|
!print*, "------------- parser end -------------"
|
|
|
|
END SUBROUTINE get_field
|
|
|
|
END MODULE parser
|