On 01/08/2014 06:49 PM, Oleg Rubel wrote:
I tried to compile the FORTRAN code you attached. It has the include statement
use util, only: line_count
use structmod, only: struct, struct_read
use const, only: BUFSZ
I was able to find 'util.f' in the w2w package, but not 'structmod'
and 'const'. Would you please send me those too.
Sorry, I forgot about that. I attach ‘util.F’ (which contains all those
modules) and a header file it needs. The ‘util.f’ from the current
wien2wannier distribution will not work with this ‘vec2ascii.f90’.
When compiling remember that for the ‘.F’ file you have tell that
compiler that it is free-form, so
$ ifort -warn all -free util.F vec2ascii.f90 -o vec2ascii
or
$ gfortran -ffree-form -Wall util.F vec2ascii.f90 -o vec2ascii
(of course you need to use the same as for lapw1 …)
Elias
!!! wien2wannier/util/util.f90
!!!
!!! Collection of routines for the programs in util/ and woptic/
!!!
!!! Copyright 2010-2012 Philipp Wissgott
!!! Copyright 2013 Elias Assmann
!--------------- Constants mathematical and configurational ---------------
module const
use iso_fortran_env, only: int32
implicit none
public
integer, parameter :: BUFSZ = 256
!! Default kinds
integer, parameter :: DP = selected_real_kind(15,300) ! inherited from W90
integer, parameter :: IP = int32
!! Kinds for WIEN-compatibility
real*4, private :: four_real
real*8, private :: eight_real
complex*16, private :: sixteen_complex
integer, parameter :: R4 = kind(four_real)
integer, parameter :: R8 = kind(eight_real)
integer, parameter :: C16= kind(sixteen_complex)
real(DP), parameter :: PI = 3.1415926535897932d0
real(DP), parameter :: ORTHO_TEST = 1.d-12
real(DP), parameter :: SQ3 = sqrt(3d0)
end module const
!--------------- Assorted miscellanea ---------------
MODULE util
use const, only: DP, BUFSZ
implicit none
private
public :: string, inverse3x3, ptime, uppercase, lowercase, line_count
interface string
module procedure int2str, real2str
end interface string
contains
character(len=10) function int2str(n)
integer, intent(in) :: n
write(int2str,"(I5)") n
end function int2str
character(len=15) function real2str(r)
real(DP), intent(in) :: r
write(real2str,"(E16.9)") r
end function real2str
subroutine inverse3x3(a, ainv)
!inverse of th 3x3 matrix A
implicit none
real(DP), intent(in) :: a(3,3)
real(DP), intent(out) :: ainv(3,3)
real(DP) :: det
det = a(1,1)*a(2,2)*a(3,3) + a(1,2)*a(2,3)*a(3,1) &
+a(1,3)*a(2,1)*a(3,2) - a(3,1)*a(2,2)*a(1,3) &
-a(1,1)*a(3,2)*a(2,3) - a(2,1)*a(1,2)*a(3,3)
ainv(1,1) = ( a(2,2)*a(3,3) - a(2,3)*a(3,2) ) / det
ainv(2,1) = (- a(2,1)*a(3,3) + a(2,3)*a(3,1) ) / det
ainv(3,1) = ( a(2,1)*a(3,2) - a(2,2)*a(3,1) ) / det
ainv(1,2) = (- a(1,2)*a(3,3) + a(1,3)*a(3,2) ) / det
ainv(2,2) = ( a(1,1)*a(3,3) - a(1,3)*a(3,1) ) / det
ainv(3,2) = (- a(1,1)*a(3,2) + a(1,2)*a(3,1) ) / det
ainv(1,3) = ( a(1,2)*a(2,3) - a(1,3)*a(2,2) ) / det
ainv(2,3) = (- a(1,1)*a(2,3) + a(1,3)*a(2,1) ) / det
ainv(3,3) = ( a(1,1)*a(2,2) - a(1,2)*a(2,1) ) / det
end subroutine inverse3x3
subroutine ptime(descr, unit)
character(len=*), intent(in), optional :: descr
integer, intent(in), optional :: unit
character(len=*), parameter :: fmt = "('Times for ', A, T33, '(sec):', &
& F8.3, ' wall;', F9.3)"!, ' cpu =', F8.3, ' user +', F8.3, ' sys')"
real(DP), save :: cputime1, cputime2
integer, save :: walltime1, walltime2, count_rate
integer, save :: default_lun
integer :: lun
if (.not. present(descr)) then
call cpu_time(cputime1)
call system_clock(walltime1, count_rate)
if (present(unit)) default_lun=unit
return
end if
if (present(unit)) then
lun=unit
else
lun=default_lun
end if
call cpu_time(cputime2)
call system_clock(walltime2)
write(lun, fmt) descr, real(walltime2-walltime1)/count_rate, &
& (cputime2-cputime1)
walltime1 = walltime2
cputime1 = cputime2
end subroutine ptime
pure function uppercase(str)
character(*), intent(in) :: str
character(len(str)) :: uppercase
integer :: ic, i
character(26), parameter :: CAP = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
character(26), parameter :: low = 'abcdefghijklmnopqrstuvwxyz'
uppercase = str
do i = 1, len_trim(str)
ic = index(low, str(i:i))
if (ic > 0) uppercase(i:i) = CAP(ic:ic)
end do
end function uppercase
pure function lowercase(str)
character(*), intent(in) :: str
character(len(str)) :: lowercase
integer :: ic, i
character(26), parameter :: CAP = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
character(26), parameter :: low = 'abcdefghijklmnopqrstuvwxyz'
lowercase = str
do i = 1, len_trim(str)
ic = index(CAP, str(i:i))
if (ic > 0) lowercase(i:i) = low(ic:ic)
end do
end function lowercase
integer function line_count(fid)
!>Returns the number of lines in a file.
!>\param fname Name of the file
!>\return Number of lines in the file.
implicit none
!input parameters
!character(len=*) fname !filename of the file to count
integer, intent(in) :: fid
!local parameters
character(20) dummy
integer ioStat
logical ioEndFlag
ioEndFlag = .false.
line_count = 0
do while (.not. ioEndFlag )
read(fid,"(A20)", iostat=ioStat ) dummy
if( iostat .eq. 0) line_count = line_count + 1
if( iostat < 0 ) ioEndFlag = .TRUE.
end do
rewind(fid)
END FUNCTION line_count
end MODULE util
!--------------- Helper procedures for command line interface ---------------
module clio
#include "fetcharg.h"
use iso_fortran_env, only: ERROR_UNIT
use util, only: string
use const, only: BUFSZ
implicit none
private
public :: croak, carp, fetcharg_buf
#ifdef HAVE_VARLEN_STR
public :: fetcharg
#endif
argstr :: progname
logical :: got_progname = .false.
contains
subroutine get_progname()
integer s
call fetcharg(0, progname, status=s)
if (s /= 0) progname='WIEN2WANNIER'
got_progname = .true.
end subroutine get_progname
subroutine croak(message, status)
character(len=*), intent(in) :: message
integer, intent(in), optional :: status
integer :: s=1
if (present(status)) s=status
if (.not. got_progname) call get_progname()
write(ERROR_UNIT, '(A, ": ", A)') progname, message
call exit(s)
end subroutine croak
subroutine carp(message)
character(len=*), intent(in) :: message
if (.not. got_progname) call get_progname()
write(ERROR_UNIT, '(A, ": ", A)') progname, message
end subroutine carp
!! This elegant variable-length version of `fetcharg´ does not work
!! on pre-4.8 gcc
#ifdef HAVE_VARLEN_STR
subroutine fetcharg(i, str, message, status)
integer, intent(in) :: i
character(len=:), intent(out), allocatable :: str
character(len=*), intent(in), optional :: message
integer, intent(out), optional :: status
integer :: s, l
if (allocated(str)) deallocate(str)
call get_command_argument(i, length=l, status=s)
if (present(status)) then
status = s
elseif (s /= 0) then
if (present(message)) then
call croak(message)
else
call croak("FETCHARG: failed to get command argument #" // &
& trim(string(i)) // " length: " // trim(string(s)))
end if
end if
allocate(character(len=l) :: str)
!! zero-length arguments seem to need special treatment
!! (hooray Fortran!)
if (l==0) return
call get_command_argument(i, value=str, status=s)
if (present(status)) then
status = s
elseif (s /= 0) then
if (present(message)) then
call croak(message)
else
call croak("FETCHARG: failed to get command argument #" // &
& trim(string(i)) // ": " // trim(string(s)))
end if
end if
end subroutine fetcharg
#endif
subroutine fetcharg_buf(i, buf, message, status)
integer, intent(in) :: i
character(len=*), intent(out) :: buf
character(len=*), intent(in), optional :: message
integer, intent(out), optional :: status
integer :: s
!! here, a zero-length argument is okay
!! (probably because len(buf) /= 0)
call get_command_argument(i, value=buf, status=s)
if (present(status)) then
status = s
elseif (s /= 0) then
if (present(message)) then
call croak(message)
elseif (s < 0) then
call croak("FETCHARG_BUF: buffer too small for command argument #" &
& // trim(string(i)))
else
call croak("FETCHARG_BUF: failed to get command argument #" // &
& trim(string(i)) // ": " // trim(string(s)))
end if
end if
end subroutine fetcharg_buf
end module clio
!----------------- âstructâ type and associated procedures -----------------
module structmod
implicit none
private
public :: struct, struct_read
type intptr
integer, allocatable :: p(:)
end type intptr
type struct
!! Structure to represent a âstructâ file
!!
!! The conventions here follow mostly those of âstructeditorâ
character(len=80) :: title
character(len= 4) :: lattic ! lattice type
integer :: nat, nneq ! number of noneq. and total atoms
character(len= 4) :: mode ! âRELAâ or âNRELâ
real(8) :: a(3) ! lattice constants
real(8) :: alpha(3) ! angles
real(8) :: brlat(3,3) ! Bravais lattice (row is a vector)
real(8) :: lat2car(3,3) ! lattice to cartesian transformation
! (different from brlat in some cases)
logical :: ortho
real(8) :: vol ! u.c. volume
! positions (3 Ã nneq); local rotation matrices (3 Ã 3 Ã nat)
real(8), allocatable :: pos(:,:), locrot(:,:,:)
! neq2at(ineq) is the atom numer corresponding to ineq
integer, allocatable :: mult(:), isplit(:), npt(:), neq2at(:)
! at2neq(iat)%p is an array of the âineqâs corresponding to iat
type(intptr), allocatable :: at2neq(:)
character(len=10), allocatable :: aname(:)
real(8), allocatable :: r0(:), rmt(:), Z(:)
end type struct
contains
subroutine struct_read(lun, stru)
use const, only: PI, SQ3, ORTHO_TEST
use clio, only: croak
use util, only: inverse3x3
integer, intent(in) :: lun
type(struct), intent(out) :: stru
integer :: iat, ineq, N
! âBravais latticeâ and âlattice->cartesianâ transformation
! matrices [in some cases, the two are different], both for direct
! and reciprocal space
real(8) :: br1_dir(3,3), br1_rec(3,3), br2_dir(3,3), br2_rec(3,3)
! abbreviations
real(8) :: pia(3), alpha(3), cosab, cosac, cosbc, sinab, sinbc
real(8) :: rvfac, wurzel
read(lun, '(A)') stru%title
read(lun, '(A, 23X, I3)') stru%lattic, stru%nat
read(lun, '(13X, A)') stru%mode
read(lun, '(6F10.6)') stru%a, stru%alpha
where (abs(stru%alpha) < 1e-5) stru%alpha = 90
N = stru%nat
allocate(stru%mult(N), stru%isplit(N), stru%aname (N), &
& stru%npt (N), stru%at2neq(N), stru%Z (N), &
& stru%r0 (N), stru%rmt (N), stru%locrot(3,3,N))
countneq: do iat = 1, stru%nat
read(lun,*) ! first position
read(lun, '(15X, I2, 17X, I2)') stru%mult(iat), stru%isplit(iat)
! rest of positions
do ineq = 2, stru%mult(iat)
read(lun,*)
end do
read(lun, '(A, 5X, I5, 5X, F10.8, 5X, F10.5, 5X, F5.2)') &
stru%aname(iat), stru%npt(iat), stru%r0(iat), stru%rmt(iat), &
stru%Z(iat)
read(lun,'(20X, 3F10.7)') stru%locrot(1, :, iat)
read(lun,'(20X, 3F10.7)') stru%locrot(2, :, iat)
read(lun,'(20X, 3F10.7)') stru%locrot(3, :, iat)
end do countneq
stru%nneq = sum(stru%mult)
N = stru%nneq
allocate(stru%pos(3, N), stru%neq2at(N))
N=0
do iat = 1, stru%nat
stru%neq2at(N+1:N+stru%mult(iat)) = iat
allocate(stru%at2neq(iat)%p(stru%mult(iat)))
stru%at2neq(iat)%p = iat
N = N+stru%mult(iat)
end do
rewind(lun)
read(lun,*) ! title
read(lun,*) ! lattic
read(lun,*) ! mode
read(lun,*) ! uc
N=0
readpos: do iat = 1, stru%nat
N=N+1
read(lun, '(9X, 3(3X, F10.8))') stru%pos(:, N)
read(lun,*) ! mult
do ineq = 2, stru%mult(iat)
N=N+1
read(lun, '(9X, 3(3X, F10.8))') stru%pos(:, N)
end do
read(lun,*) ! aname
read(lun,*) ! locrot
read(lun,*) !
read(lun,*) !
end do readpos
!! Now compute lattice vectors. This is copied from
!! SRC_structeditor/module.f (subroutine latgen_struct)
pia = 2*PI/stru%a
alpha = stru%alpha*PI/180
cosab = cos(alpha(3)); sinab = sin(alpha(3))
cosac = cos(alpha(2))
cosbc = cos(alpha(1)); sinbc = sin(alpha(1))
br1_rec = 0; br1_dir = 0; br2_rec = 0; br2_dir = 0
lattic: select case (stru%lattic(1:1))
case ('H')
br1_rec(1,1) = pia(1)*2/SQ3
br1_rec(1,2) = pia(1) /SQ3
br1_rec(2,2) = pia(2)
br1_rec(3,3) = pia(3)
br2_rec = br1_rec
rvfac = 2/SQ3
stru%ortho = .false.
case ('S', 'P') ! what's âSâ??
wurzel = sinbc**2 - cosac**2 - cosab**2 + 2*cosbc*cosac*cosab
br1_rec(1,1) = pia(1) * sinbc/wurzel
br1_rec(1,2) = pia(2) * (-cosab + cosbc*cosac)/(sinbc*wurzel)
br1_rec(1,3) = pia(3) * (-cosac + cosbc*cosab)/(sinbc*wurzel)
br1_rec(2,2) = pia(2) / sinbc
br1_rec(2,3) =-pia(3) * cosbc/sinbc
br1_rec(3,3) = pia(3)
br2_rec = br1_rec
rvfac = 1/wurzel
stru%ortho = all(abs(alpha - PI/2) <= ortho_test)
case ('F')
br1_rec(1,1) = pia(1)
br1_rec(2,2) = pia(2)
br1_rec(3,3) = pia(3)
br2_rec(1,:) = pia(1) * (/-1, 1, 1 /)
br2_rec(2,:) = pia(2) * (/ 1,-1, 1 /)
br2_rec(3,:) = pia(3) * (/ 1, 1,-1 /)
rvfac = 4
stru%ortho = .true.
case ('B')
br1_rec(1,1) = pia(1)
br1_rec(2,2) = pia(2)
br1_rec(3,3) = pia(3)
br2_rec(1,:) = pia(1) * (/ 0, 1, 1 /)
br2_rec(2,:) = pia(2) * (/ 1, 0, 1 /)
br2_rec(3,:) = pia(3) * (/ 1, 1, 0 /)
rvfac = 2
stru%ortho = .true.
case ('R')
br1_rec(1, :) = pia(1) * (/ 1, 1, -2 /)/SQ3
br1_rec(2, :) = pia(2) * (/ -1, 1, 0 /)
br1_rec(3, :) = pia(3)
br2_rec = br1_rec
rvfac = 6/SQ3
stru%ortho = .false.
case ('C')
! âdefaultsâ, to be changed in nonorthogonal XZ-case
br1_rec(1,1) = pia(1)
br1_rec(2,2) = pia(2)
br1_rec(3,3) = pia(3)
rvfac = 2
stru%ortho = .true.
C: select case (stru%lattic(2:3))
case ('XY')
br2_rec(1,:) = pia(1) * (/ 1, 1, 0 /)
br2_rec(2,:) = pia(2) * (/-1, 1, 0 /)
br2_rec(3,:) = pia(3) * (/ 0, 0, 1 /)
case ('YZ')
br2_rec(1,:) = pia(1) * (/ 1, 0, 0 /)
br2_rec(2,:) = pia(2) * (/ 0, 1, 1 /)
br2_rec(3,:) = pia(3) * (/ 0,-1, 1 /)
case ('XZ')
ortho: if (abs(alpha(3) - PI/2) <= 0.0001) then
br2_rec(1,:) = pia(1) * (/ 1, 0, 1 /)
br2_rec(2,:) = pia(2) * (/ 0, 1, 0 /)
br2_rec(3,:) = pia(3) * (/-1, 0, 1 /)
else ! CXZ monoclinic case
br1_rec(1,1) = pia(1) / sinab
br1_rec(1,2) =-pia(2) / sinab * cosab
br2_rec(1,1) = pia(1) / sinab
br2_rec(1,2) =-pia(2) / sinab * cosab
br2_rec(1,3) = pia(1) / sinab
br2_rec(2,:) = pia(2) * (/ 0, 1, 0 /)
br2_rec(3,:) = pia(3) * (/-1, 0, 1 /)
rvfac = 2/sinab
stru%ortho = .false.
end if ortho
end select C
case default
rvfac = 0 ! silence warning
call croak('unknown lattice type `' // trim(stru%lattic) // "'")
end select lattic
call inverse3x3(br1_rec, br1_dir); br1_dir = br1_dir*2*PI
call inverse3x3(br2_rec, br2_dir); br2_dir = br2_dir*2*PI
stru%vol = product(stru%a) / rvfac
stru%lat2car = br1_dir
stru%brlat = br2_dir
end subroutine struct_read
end module structmod
!-------------------------- Reading âklistâ files --------------------------
module kpoints
use const, only: BUFSZ, DP
use structmod, only: struct
use util, only: string
use clio, only: croak
implicit none
contains
subroutine get_kmesh_klist(unit, kpoints, stru, mp_grid)
integer, intent(in) :: unit
real(DP), intent(out), allocatable :: kpoints(:, :)
type(struct), intent(in) :: stru
integer, intent(out), optional :: mp_grid(3)
integer :: nk=0, ik=0
character(BUFSZ) :: buf
integer :: kfrac(3), div
countk: do
read(unit, '(A)') buf
if (trim(buf) == "END") exit
nk = nk+1
end do countk
rewind(unit)
allocate(kpoints(nk, 3))
readk: do
read(unit, '(A)') buf
if (trim(buf) == "END") exit
ik = ik+1
if (ik == 1) then
read(buf, '(T86, 3I3)') mp_grid
end if
read(buf(11:), *) kfrac, div ! skip running number
kpoints(ik,:) = real(kfrac, 8)/real(div, 8)
if (stru%ortho) &
kpoints(ik,:) = matmul(stru%brlat, kpoints(ik,:)) / stru%a
end do readk
if (ik /= nk) &
call croak('get_kmesh_klist: numbers of k-points do not match' // &
& trim(string(ik)) // ' /= ' // trim(string(nk)))
END SUBROUTINE get_kmesh_klist
subroutine get_kmesh_band(unit, kpoints, stru, knames, nkp)
!!! Reading the band-structure klist gets its own subroutine because
!!! the required work (k-point labels, #points per segment) as well as
!!! the structure of the file (no running numbers, no mp_grid, ...)
!!! are sufficiently different.
integer, intent(in) :: unit
real(DP), allocatable, intent(out) :: kpoints(:, :)
type(struct), intent(in) :: stru
character, allocatable, intent(out) :: knames(:)
integer, intent(out) :: nkp
integer :: nk=0, ik=0
character(BUFSZ) :: buf
logical :: first_path = .true.
integer :: kfrac(3), div
countk: do
read(unit, '(A)') buf
if (trim(buf) == "END") exit
! we only count k-points with a label, assuming that these
! delimit "paths" that will be passed to wannier90
if (buf(1:6) /= "") nk = nk+1
end do countk
rewind(unit)
allocate(kpoints(nk, 3), knames(nk))
nkp = 0
readk: do
read(unit, '(A)') buf
if (trim(buf) == "END") exit
if (first_path) nkp = nkp+1
if (buf(1:6) == "") then
cycle
elseif (nkp > 1) then
first_path = .false.
end if
! we now have a k-vector we should save
ik = ik+1
knames(ik) = buf(1:1)
read(buf(7:), *) kfrac, div
kpoints(ik,:) = real(kfrac, 8)/real(div, 8)
if (stru%ortho) &
kpoints(ik,:) = matmul(stru%brlat, kpoints(ik,:)) / stru%a
end do readk
nkp = nkp-1
if (ik /= nk) &
call croak('get_kmesh_band: numbers of k-points do not match' // &
& trim(string(ik)) // ' /= ' // trim(string(nk)))
end subroutine get_kmesh_band
end module kpoints
!--------------- Procedures nicked from Wien2k ------------------------
module wien2k
private
public :: errflg, gtfnam
contains
SUBROUTINE ERRFLG(FNAME,MSG)
CHARACTER(*) FNAME, MSG
!
! ..................................................................
!
! 1. PROGRAM UNIT 'ERRFLG'
! Notify that an error has occured.
! FORTRAN 77 SUBROUTINE
!
! 2. PURPOSE
! Because there is no standard (or even semi-standard) way to
! generate exit codes in FORTRAN 77, this routine writes a
! non-empty file to the current subdirectory as an indication
! that some serious error has occured. Other programs can then
! check the contents of this file to determine whether an
! error has occured. The errorflag-file is left opened when
! returning from this routine to enable writing other
! errormessages to it.
!
! 3. USAGE
! CALL ERRFLG('lapw2.error','Error in OUTWIN')
!
! ARGUMENT-DESCRIPTION
! FNAME - CHARACTER*(*) string (input)
! The name of the file acting as error-flag.
! MSG - CHARACTER*(*) string (input)
! The (error) message which should be written to the
! errorflag-file.
!
! USED SUBROUTINES (DIRECTLY CALLED)
! none
!
! INDIRECTLY CALLED SUBROUTINES
! none
!
! UTILITY-SUBROUTINES (USE BEFOREHAND OR AFTERWARDS)
! ERRCLR - clears the contents of a file
!
! INPUT/OUTPUT (READ/WRITE)
! A message given as argument MSG is written to a the file
! given as argument FNAME. File FNAME is created if not
! existing and otherwise overwritten.
!
! MACHINENDEPENDENT PROGRAMPARTS
! none
!
! 4. REMARKS
! The best way to use this routine is to call ERRFLG at the
! start of a program writing some message to the errorflag-
! file and ERRCLR before a successful exit of the program. By
! checking the contents of the errorflag-file it is possible
! to determine if the program was successfully completed.
!
! This method has the advantage of working even if some
! runtime-error occurs which is not taken care of in the
! program.
!
! 5. METHOD
! - open errorflag-file
! - write some message to this errorflag-file
! - exit leaving the file opened
!
! 6. DATE
! 24. August 1993 Version 1.02
!
! INSTITUT FUER TECHNISCHE ELEKTROCHEMIE -- TU VIENNA
! ..................................................................
!
OPEN (99,FILE=FNAME,ERR=900)
WRITE (99,9000) MSG
CLOSE (99)
OPEN (99,FILE=FNAME,ERR=900)
!
RETURN
!
! Errors
!
900 STOP 'ERRFLG - couldn''t open errorflag-file.'
!
9000 FORMAT (A)
!
! End of 'ERRFLG'
!
END SUBROUTINE ERRFLG
!$HP9000_800 INTRINSICS ON
SUBROUTINE GTFNAM(DEFFN,ERRFN,IPROC)
implicit integer (a-n)
CHARACTER(*) DEFFN, ERRFN
INTEGER IPROC
!
! ..................................................................
!
! 1. PROGRAM UNIT 'GTFNAM'
! Provide names for definition- and error-files for LAPW.
! FORTRAN 77 SUBROUTINE
!
! 2. PURPOSE
! Read the commandline-argument
! specifying the name of the definition file ('lapw1.def')
! and generate the name of the error file by replacing the
! extension of the definition filename with '.error'. If no
! extension can be found '.error' is appended.
!
! For the parallel version in the second commandline parameter
! the number of parallel processes is specified
!
! 3. USAGE
! CHARACTER*80 DEFFN, ERRFN
! CALL GTFNAM(DEFFN,ERRFN)
!
! ARGUMENT-DESCRIPTION
! DEFFN - CHARACTER*(*) string (output)
! on exit contains the filename of the lapw2-
! definition file 'lapw2.def'.
! ERRFN - CHARACTER*(*) string (output)
! on exit contains the filename of the file where
! error messages are stored (derived from the file-
! name of the definition-file).
! IPROC - number of parallel processes (if specified)
!
!
! USED SUBROUTINES (DIRECTLY CALLED)
! none
!
! INDIRECTLY CALLED SUBROUTINES
! none
!
! UTILITY-SUBROUTINES (USE BEFOREHAND OR AFTERWARDS)
! none
!
! INPUT/OUTPUT (READ/WRITE)
! none
!
! MACHINENDEPENDENT PROGRAMPARTS
! - Subroutine GETARG for the extraction of command-line
! arguments is used (the index for referencing command-
! line argument starts with 0 on some machines and with
! 1 on other machines).
! - A compiler directive to enable the use of the extension
! subroutine GETARG is used (HP-Version)
!
! 4. REMARKS
! It is assumed that filename-extensions are separated by
! character '.'.
!
! 5. METHOD
! - get commandline-argument (taking into account that
! comandline-arguments are referenced starting with index
! 0 on some machines and starting with index 1 on others).
! - 'lapw1.def' := commandline-argument
! - look for the last occurence of character '.' in the
! commandline-argument
! - if found replace all characters after that '.' with
! 'error' giving the error filename
! - otherwise append '.error' giving the error filename
!
! 6. DATE
! 25. August 1993 Version 1.01
!
! INSTITUT FUER TECHNISCHE ELEKTROCHEMIE -- TU VIENNA
! ..................................................................
!
! Local Parameters
!
CHARACTER(5) ERREXT
PARAMETER (ERREXT = 'error')
!
! Local Scalars
!
INTEGER I, iarg
!
! extract the command-line argument
!
IPROC=0
iarg=command_argument_count()
if(iarg.eq.1) then
CALL get_command_argument(iarg,DEFFN)
else if(iarg.eq.2) then
CALL get_command_argument(2,DEFFN)
READ(DEFFN,*)IPROC
CALL get_command_argument(1,DEFFN)
else
STOP 'GTFNAM - One or two commandline arguments have to be given.'
endif
!
! generate a name for the error-message file
!
DO 10 I = LEN(DEFFN), 1, -1
IF (DEFFN(I:I) .EQ. '.') THEN
IF (LEN(ERRFN) .LT. (I+LEN(ERREXT))) GOTO 910
ERRFN(1:I) = DEFFN(1:I)
ERRFN(I+1:LEN(ERRFN)) = ERREXT
GOTO 30
ENDIF
10 CONTINUE
!
! the name of the definition file contains no '.', it is assumed
! that this name contains no extension - append the extension
! '.error' to get a name for the error file.
!
DO 20 I = LEN(DEFFN), 1, -1
IF (DEFFN(I:I) .NE. ' ') THEN
IF (LEN(ERRFN) .LT. (I+1+LEN(ERREXT))) GOTO 910
ERRFN(1:I) = DEFFN(1:I)
ERRFN(I+1:LEN(ERRFN)) = '.' // ERREXT
GOTO 30
ENDIF
20 CONTINUE
!
! filename contains only spaces
!
STOP 'GTFNAM - string ERRFN contains just spaces.'
30 CONTINUE
!
RETURN
!
! Errors
!
910 STOP 'GTFNAM - string ERRFN too short to hold filename.'
!
! End of 'GTFNAM'
!
END SUBROUTINE
END MODULE wien2k
! -*- mode: f90 -*-
#ifdef HAVE_VARLEN_STR
#define argstr character(len=:), allocatable
#else
#define fetcharg fetcharg_buf
#define argstr character(len=bufsz)
#endif
_______________________________________________
Wien mailing list
Wien@zeus.theochem.tuwien.ac.at
http://zeus.theochem.tuwien.ac.at/mailman/listinfo/wien
SEARCH the MAILING-LIST at:
http://www.mail-archive.com/wien@zeus.theochem.tuwien.ac.at/index.html
