Commit 0710e1bd authored by Daniel Wortmann's avatar Daniel Wortmann

Start of new inpgen

parent a66013c6
Subproject commit 3cb2231abf1d47fbd8b3e21c8478e9f26a73ce5f
Subproject commit ca6f7114b9fffe0964ca9e8d24e09ef15b300316
MODULE m_atompar
IMPLICIT NONE
USE m_judft
type t_atompar
integer :: id = -1
integer :: nucnumber = 0
real :: rmt = 0.0
real :: rmt_min=99.0
integer :: jri = 0
REAL :: dx = 0.0
REAL :: bmu = -9999.0
integer :: lmax = 0
integer :: lnonsph = 0
character(len=100)::lo=""
character(len=100)::econfig=""
character(len=100)::desc=""
contains
procedure :: add_defaults
end type t_atompar
type(t_atompar),allocatable :: atompar_list(:)
integer :: no_of_atompars
contains
subroutine add_defaults(ap)
class(t_atompar),intent(inout)::ap
TYPE(t_atompar):: ap_d
if (ap%rmt>0) then
ap_d=find_atompar(ap%nucnumber,ap%rmt)
else
call judft_error("Defaults ...")
endif
if (ap%jri==0) ap%jri=ap_d%jri
if (ap%dx==0) ap%jri=ap_d%dx
if (ap%lmax==0) ap%jri=ap_d%lmax
if (ap%lnonsph==0) ap%jri=ap_d%lnonsph
if (ap%lo=="") ap%lo=ap_d%lo
IF (ap%econfig=="") ap%econfig=ap_d%econfig
!now generate defaults for missing values
if(ap%jri==0) ap%jri = NINT(NINT(330*ap%rmt)*0.5)*2+1
if(ap%dx==0) ap%dx=LOG(3200*ap%nucnumber*ap%rmt)/(ap%jri-1)
if(ap%lmax==0) then
if (ap%rmt<1.8) then
ap%lmax=6
else if(ap%rmt<2.4) then
ap%lmax=8
else
ap%lmax=10
endif
endif
IF(ap%lnonsph==0) ap%lnonsph=MIN( MAX( (ap%lmax(:)-2),3 ), 8 )
IF (ap%lnonsph>ap%lmax) THEN
WRITE(*,*) "lnonsph had to be reduced for some atom"
ap%lnonsph=ap%lmax
ENDIF
!check of magnetism
IF (ap%bmu<-99.0) THEN
IF (ap_d%bmu>-99.0) THEN
ap%bmu=ap_d%bmu
ELSE
ap%bmu = 0.0
IF (ap%nucnumber.EQ.24) ap%bmu = 1.0 ! Cr - Ni
IF (ap%nucnumber.EQ.25) ap%bmu = 3.5
IF (ap%nucnumber.EQ.26) ap%bmu = 2.2
IF (ap%nucnumber.EQ.27) ap%bmu = 1.6
IF (ap%nucnumber.EQ.28) ap%bmu = 1.1
IF (ap%nucnumber.EQ.59) ap%bmu = 2.1 ! Pr - Tm
IF (ap%nucnumber.EQ.60) ap%bmu = 3.1
IF (ap%nucnumber.EQ.61) ap%bmu = 4.1
IF (ap%nucnumber.EQ.62) ap%bmu = 5.1
IF (ap%nucnumber.EQ.63) ap%bmu = 7.1
IF (ap%nucnumber.EQ.64) ap%bmu = 7.1
IF (ap%nucnumber.EQ.65) ap%bmu = 6.1
IF (ap%nucnumber.EQ.66) ap%bmu = 5.1
IF (ap%nucnumber.EQ.67) ap%bmu = 4.1
IF (ap%nucnumber.EQ.68) ap%bmu = 3.1
IF (ap%nucnumber.EQ.69) ap%bmu = 2.1
END IF
END IF
!make sure there are no blanks in lo
DO n=1,len_TRIM(lo)
IF (ad%lo(n:n)=' ') THEN
ad%lo(n:LEN(ad%lo)-n)=ad%lo(n+1:)
ad%lo(LEN(ad%lo):LEN(ad%lo))=' '
ENDDO
end subroutine add_defaults
subroutine add_atompar(ap)
TYPE(t_atompar),INTENT(in),OPTIONAL::ap
type(t_atompar),allocatable:: tmp_list(:)
IF (.NOT.ALLOCATED(atompar_list)) THEN
no_of_atompars=0
ALLOCATE(atompar_list(100))
!Try to read default parameter files
CALL read_params("default.econfig")
CALL read_params("fleur.econfig")
call read_params("my.econfig")
else
if (no_of_atompars==size(atompar_list)) then
!extend the list
call move_alloc(atompar_list,tmp_list)
allocate(atompar_list(no_of_atompars+50))
atompar_list(:no_of_atompars)=tmp_list
deallocate(tmp_list)
endif
END IF
IF (PRESENT(ap)) THEN
no_of_atompars=no_of_atompars+1
atompar_list(no_of_atompars)=ap
ENDIF
end subroutine add_atompar
function find_atompar(nucnumber,rmt_max,id)result(ap)
integer,intent(in) :: nucnumber
real,intent(in) :: rmt_max
integer,intent(in),optional :: id
type(t_atompar) :: ap
integer :: n
!check if there is an id given
if (present(id)) then
DO n=no_of_atompars,1,-1
ap=atompar_list(n)
IF (ap%nucnumber==nucnumber.AND.ap%id==id) THEN
RETURN
ENDIF
end DO
call judft_error("You specified a specific id for an atom but never defined that")
end if
!Else we search if the MT has been given for this atom
DO n=no_of_atompars,1,-1
ap=atompar_list(n)
if (ap%nucnumber==nucnumber) then
IF (ap%rmt>0.AND.ap%rmt<rmt_max) THEN
RETURN
ENDIF
endif
enddo
!Else we check if there is an atom definition available
DO n=no_of_atompars,1,-1
ap=atompar_list(n)
if (ap%nucnumber==nucnumber) then
if (ap%rmt_min<=rmt_max) then
ap%rmt=rmt_max
return
endif
endif
enddo
call judft_error("No possible atomic parameter-set found")
end function find_atompar
SUBROUTINE read_params(filename)
CHARACTER(len=*),INTENT(in)::filename
CHARACTER(len=5)::str
INTEGER :: id,z,jri,lmax,lnonsph,io_stat
REAL :: rmt,rmt_min,dx,bmu
CHARACTER(len=100)::desc,lo,econfig
LOGICAL :: l_exist
TYPE(t_atompar)::ap
NAMELIST /atom/desc,id,z,jri,lmax,lnonsph,rmt,rmt_min,dx,lo,econfig,bmu
INQUIRE(file=filename,exist=l_exist)
IF (.NOT.l_exist) RETURN
OPEN(99,file=filename)
DO
READ(99,*,err=100,END=100) str
IF (str=="&atom") THEN
BACKSPACE(99)
id=-1;z=0;rmt=0.0;rmt_min=99.0;jri=0;dx=0.0;lmax=0;bmu=-9999.0;lnonsph=0;lo='';econfig=''
READ(99,atom,iostat=io_stat)
IF (io_stat==0) THEN
ap=t_atompar(id=id,nucnumber=z,rmt=rmt,rmt_min=rmt_min,jri=jri,dx=dx,bmu=bmu,lmax=lmax,lnonsph=lnonsph,lo=lo,econfig=econfig,desc=desc)
ELSE
!try old namelist
CALL read_params_old(ap)
END IF
CALL add_atompar(ap)
ENDIF
ENDDO
100 CLOSE(99)
END SUBROUTINE read_params
SUBROUTINE read_params_old(ap)
!Try to read old namelist
TYPE(t_atompar),INTENT(out)::ap
REAL:: id,z,rmt,dx,bmu
INTEGER:: jri,lmax,lnonsph,ncst,nc,io_stat,nz
CHARACTER(len=100)::econfig,lo,element,name
NAMELIST /atom/ id,z,rmt,dx,jri,lmax,lnonsph,ncst,econfig,bmu,lo,element,name
id=-9999.9;z=-1.0;rmt=0.0;dx=0.0;jri=0;lmax=0;lnonsph=0;ncst=-1;lo='';econfig='';name='';bmu=-9999.0
BACKSPACE(99)
READ(99,atom,iostat=io_stat)
IF(io_stat.NE.0) THEN
BACKSPACE(99)
READ(99,*) name
WRITE(*,*) name
CALL judft_error("Found a &atom namelist in input that was incorrect")
END IF
!determine nz and id
nz=-1
IF (element.NE."") THEN
nz=element_to_z(element)
IF (z.NE.0.AND.nz.NE.FLOOR(z)) CALL judft_error("z and z of specified element differ")
ELSE
nz=FLOOR(z)
ENDIF
IF (id.NE.-9999.9) THEN
IF (nz==-1) nz=FLOOR(id)
id=(id-nz)*100
IF (id>=100.OR.id<0) CALL judft_error("ID and element (or nuclear number do not fit")
ELSE
id=-1.0
ENDIF
IF (nz==-1) CALL judft_error("Neither z nor element specified")
IF (ncst>-1) CALL judft_warn("ncst is no longer supported as input")
ap=t_atompar(id=INT(id),nucnumber=nz,rmt=rmt,dx=dx,jri=jri,lmax=lmax,lnonsph=lnonsph,lo=lo,bmu=bmu,econfig=econfig,desc=name)
CONTAINS
INTEGER FUNCTION element_to_z(element)
USE m_constants,ONLY: namat_const
IMPLICIT NONE
CHARACTER(len=*),INTENT(in):: element
CHARACTER(len=2) :: ele
INTEGER,parameter :: adiff=ICHAR('A')-ICHAR('a')
INTEGER :: n
ele=ADJUSTL(element)
IF (ele(1:1)>='A'.AND.ele(1:1)<='Z') ele(1:1)=CHAR(ICHAR(ele(1:1))-adiff)
IF (ele(2:2)>='A'.AND.ele(2:2)<='Z') ele(2:2)=CHAR(ICHAR(ele(2:2))-adiff)
element_to_z = -1
DO n = 0, SIZE(namat_const)-1
IF (TRIM(ele) == TRIM(ADJUSTL(namat_const(n)))) THEN
element_to_z = n
EXIT
ENDIF
ENDDO
END FUNCTION element_to_z
END SUBROUTINE read_params_old
SUBROUTINE dump_list()
INTEGER::n
INTEGER :: id,z,jri,lmax,lnonsph
REAL :: rmt,rmt_min,dx
CHARACTER(len=100)::desc,lo,econfig
type(t_atompar)::ap
NAMELIST /atom/desc,id,z,jri,lmax,lnonsph,rmt,rmt_min,dx,lo,econfig
WRITE(6,*) "List of defined atomic parameters"
DO n=1,no_of_atompars
ap=atompar_list(n)
id=ap%id
z=ap%nucnumber
jri=ap%jri
lmax=ap%lmax
lnonsph=ap%lnonsph
rmt=ap%rmt
rmt_min=ap%rmt_min
dx=ap%dx
lo=ap%lo
econfig=ap%econfig
desc=ap%desc
WRITE(6,atom)
ENDDO
END SUBROUTINE dump_list
END MODULE m_atompar
MODULE m_bravaissymm
use m_juDFT
!********************************************************************
! determines the point group of the bravais lattice given the
! lattice vectors. the idea is to determine all the lattice
! vectors that have the same length as a_{1,2,3}, and then use
! these to determine the possible rotation matrices.
! these rotation matrices are in lattice coordinates. mw 12-99
!********************************************************************
CONTAINS
SUBROUTINE bravais_symm(cell,nops,mrot)
IMPLICIT NONE
!==> Arguments
TYPE(t_cell),INTENT(in) :: cell
INTEGER, INTENT(OUT) :: nops, mrot(:,:,:) ! point group operations
!==> Locals
REAL amet(3,3),b1,b2,b3,d1,d2,d3,dmax,dt
INTEGER i,k,k1,k2,k3,m1,m2,m3,n1,n2,n3
INTEGER irot(3,3)
INTEGER,PARAMETER::neig12=12! max. number of lattice vectors with same length
! (max occurs for close-packed fcc: 12)
INTEGER lv1(3,neig12),lv2(3,neig12),lv3(3,neig12)
REAL, PARAMETER :: eps=1.0e-9
!---> distances for the lattice vectors
d1 = cell%aamat(1,1)
d2 = cell%aamat(2,2)
d3 = cell%aamat(3,3)
b1 = ( cell%bmat(1,1)/scale(1) )**2 + ( cell%bmat(1,2)/scale(2) )**2 + ( cell%bmat(1,3)/scale(3) )**2
b2 = ( cell%bmat(2,1)/scale(1) )**2 + ( cell%bmat(2,2)/scale(2) )**2 + ( cell%bmat(2,3)/scale(3) )**2
b3 = ( cell%bmat(3,1)/scale(1) )**2 + ( cell%bmat(3,2)/scale(2) )**2 + ( cell%bmat(3,3)/scale(3) )**2
!---> determine the cutoffs along each direction a_i:
dmax = max( d1,d2,d3)
m1 = nint( dmax * b1 )
m2 = nint( dmax * b2 )
m3 = nint( dmax * b3 )
!---->loop over all possible lattice vectors to find those with the
!---->length, i.e., ones that could be rotations
n1 = 1
n2 = 1
n3 = 1
lv1(1:3,1) = (/ 1,0,0 /)
lv2(1:3,1) = (/ 0,1,0 /)
lv3(1:3,1) = (/ 0,0,1 /)
DO k3=-m3,m3
DO k2=-m2,m2
DO k1=-m1,m1
dt = distance2(k1,k2,k3)
!----> check if the same length
IF ( abs( dt - d1 ) < eps ) THEN
IF (.not.( k1==1 .and. k2==0 .and. k3==0 ) ) THEN
n1 = n1+1
IF(n1>neig12) CALL juDFT_error("n1>neig12", calledby ="bravais_symm")
lv1(1,n1) = k1
lv1(2,n1) = k2
lv1(3,n1) = k3
ENDIF
ENDIF
IF ( abs( dt - d2 ) < eps ) THEN
IF (.not.( k1==0 .and. k2==1 .and. k3==0 ) ) THEN
n2 = n2+1
IF(n2>neig12) CALL juDFT_error("n2>neig12",calledby="bravais_symm")
lv2(1,n2) = k1
lv2(2,n2) = k2
lv2(3,n2) = k3
ENDIF
ENDIF
IF ( abs( dt - d3 ) < eps ) THEN
IF (.not.( k1==0 .and. k2==0 .and. k3==1 ) ) THEN
n3 = n3+1
IF(n3>neig12) CALL juDFT_error("n3>neig12",calledby="bravais_symm")
lv3(1,n3) = k1
lv3(2,n3) = k2
lv3(3,n3) = k3
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
!---> the possible rotation matrices are given by the matrix of
!---> column vectors of lv_{1,2,3}
nops = 0
DO k3 = 1,n3
DO k2 = 1,n2
DO k1 = 1,n1
!---> check whether determinant is +/-1 (needs to be for rotation)
IF ( abs(mdet(k1,k2,k3)) .NE. 1 ) CYCLE
!---> check whether this maintains lengths correctly
!---> if M is the metric, then must have R^T M R = M
irot = reshape( (/ lv1(:,k1),lv2(:,k2),lv3(:,k3) /) , (/ 3,3 /) )
IF ( any( abs(matmul( transpose(irot), matmul(cell%aamat,irot) ) - cell%aamat) > eps ) ) CYCLE
nops = nops + 1
IF ( nops > SIZE(mrot,3) ) CALL juDFT_error("nop > size(mrot)", calledby="bravais_symm")
mrot(:,:,nops) = irot
ENDDO
ENDDO
ENDDO
WRITE (6,'(//," Point group of the Bravais lattice has ",i2," operations")') nops
RETURN
CONTAINS ! INTERNAL routines
REAL FUNCTION distance2(l1,l2,l3)
!*********************************************************************
! calculates the magnitude square for a vector (l1,l2,l3) given in
! lattice units
!*********************************************************************
IMPLICIT NONE
INTEGER, INTENT(IN) :: l1,l2,l3
distance2 = l1*(l1*cell%aamat(1,1) + 2*l2*cell%aamat(2,1)) + l2*(l2*cell%aamat(2,2) + 2*l3*cell%aamat(3,2)) + l3*(l3*cell%aamat(3,3) + 2*l1*cell%aamat(1,3))
RETURN
END FUNCTION distance2
INTEGER FUNCTION mdet(k1,k2,k3)
!*********************************************************************
! determines the determinant for possible rotation matrix
! ( lv1(:,k1) ; lv2(:,k2) ; lv3(:,k3) )
!*********************************************************************
IMPLICIT NONE
INTEGER, INTENT(IN) :: k1,k2,k3
mdet = lv1(1,k1)*( lv2(2,k2)*lv3(3,k3) - lv2(3,k2)*lv3(2,k3) ) + lv1(2,k1)*( lv2(3,k2)*lv3(1,k3) - lv2(1,k2)*lv3(3,k3) ) + lv1(3,k1)*( lv2(1,k2)*lv3(2,k3) - lv2(2,k2)*lv3(1,k3) )
RETURN
END FUNCTION mdet
END SUBROUTINE bravais_symm
END MODULE m_bravaissymm
This diff is collapsed.
This diff is collapsed.
/*--------------------------------------------------------------------------------
* Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
* This file is part of FLEUR and available as free software under the conditions
* of the MIT license as expressed in the LICENSE file in more detail.
*--------------------------------------------------------------------------------
*/
#include <stdio.h>
#include "default_econfig.h"
/*
* This method together with the variables defined in default_econfig.h
* writes out the file default.econfig.
*/
int dropDefaultEconfig()
{
int errorCode = 0;
FILE *file;
file = fopen("default.econfig", "w");
errorCode = fprintf(file,"%.*s",default_econfig_len, default_econfig);
fclose(file);
if(errorCode < 0) return 1;
return 0;
}
/*
void main(){
dropDefaultEconfig();
}
*/
MODULE m_film_sym
IMPLICIT NONE
USE m_juDFT
CONTAINS
SUBROUTINE film_sym(nop,mrot,error)
INTEGER,INTENT(in)::nop,mrot(:,:,:)
LOGICAL,INTENT(inout)::error(:)
INTEGER:: n
DO n=1,nop
IF (ANY(mrot(1:2,3).NE.0).OR.ANY(mrot(3,1:2).NE.0)) error(n)=.TRUE.
END DO
END SUBROUTINE film_sym
END MODULE m_film_sym
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
PROGRAM inpgen
!----------------------------------------------------------------------------+
! Set up a FLEUR inp-file from basic input data; for use and docu please !
! refer to inpgen.html (or see http://www.flapw.de/docs/inpgen.html) !
! |
! The program is based on the input conventions of the FLAIR-code, so that !
! some compatibility is ensured. The symmetry generator was written by !
! M.Weinert and implemented in the FLAIR-code by G.Schneider. !
! gb`02 |
!----------------------------------------------------------------------------+
use m_juDFT
USE m_structinput
USE m_crystal
USE m_socorssdw
USE m_rwsymfile
USE m_setinp
USE m_writestruct
USE m_xsf_io, ONLY : xsf_write_atoms
USE m_types
USE m_inpgen_help
USE m_constants
IMPLICIT NONE
INTEGER natmax,nop48,nline,natin,ngen,i,j,bfh
INTEGER nops,no3,no2,na,numSpecies,i_c,element
INTEGER infh,errfh,warnfh,symfh,dbgfh,outfh,dispfh
LOGICAL cal_symm,checkinp,newSpecies
LOGICAL cartesian,oldfleur,l_hyb ,inistop
REAL aa
REAL a1(3),a2(3),a3(3),scale(3),factor(3)
INTEGER :: elementNumSpecies(0:104)
INTEGER, ALLOCATABLE :: mmrot(:,:,:)
REAL, ALLOCATABLE :: ttr(:, :),atompos(:, :),atomid(:)
REAL, ALLOCATABLE :: idlist(:)
INTEGER, ALLOCATABLE :: ntyrep(:) ! these variables are allocated with
INTEGER, ALLOCATABLE :: natype(:),natrep(:),natmap(:) ! or 'nat'
INTEGER, ALLOCATABLE :: speciesRepAtomType(:),atomTypeSpecies(:)
INTEGER, PARAMETER :: xl_buffer=16384 ! maximum length of read record
CHARACTER(len=xl_buffer) :: buffer
CHARACTER(len=80):: title
CHARACTER(len=7) :: symfn
CHARACTER(len=4) :: dispfn
CHARACTER(LEN=8) :: tempNumberString
CHARACTER(len=20), ALLOCATABLE :: atomLabel(:)
TYPE(t_input) :: input
TYPE(t_atoms) :: atoms
TYPE(t_cell) :: cell
TYPE(t_sym) :: sym
TYPE(t_noco) :: noco
TYPE(t_vacuum) :: vacuum
CALL inpgen_help()
CALL read_input()
CALL make_crystal(film, symor,atomid,atompos,atomlabel,amat,dvac,noco,&
cell,sym,atoms)
CALL make_atomic_defaults(cell,atoms)
!Now the IO-section
CALL w_inpxml()
CALL write_sym()
!
! --> Structure in xsf-format
!
OPEN (55,file="struct.xsf")
CALL xsf_WRITE_atoms(55,atoms,input%film,.FALSE.,cell%amat)
CLOSE (55)
CALL juDFT_end("All done",1)
END PROGRAM inpgen
MODULE m_make_atom_groups
USE m_juDFT
!********************************************************************
! calculates the space group operations given the lattice vectors
! and the atomic positions. mw 12-99
! Modified by GM (2016)
!********************************************************************
CONTAINS
SUBROUTINE make_atom_groups(sym,atompos,atomid,atomlabel,atoms)
!Use the symmetry to generate correct mapping of atoms into types
IMPLICIT NONE
TYPE(t_sym),INTENT(in) :: sym
REAL,INTENT(in) :: atompos(:,:)
REAL,INTENT(in) :: atomid(:,:)
CHARACTER(len=*),INTENT(in):: atomlabel(:)
TYPE(t_atoms),INTENT(out) :: atoms
INTEGER, ALLOCATABLE :: natype(:),natrep(:),ity(:) ! or 'nat'
INTEGER :: ntypm,n,i,j
LOGICAL :: lnew
ALLOCATE(natype(SIZE(atomid)),natrep(SIZE(atomid)),ity(SIZE(atomid)))
ntypm = 1
ity(1) = 1
DO n=2, SIZE(atomid)
lnew = .TRUE.
DO i=1,n-1
IF ( ABS( atomid(i)-atomid(n) ) < eps7 ) THEN
ity(n) = ity(i)
lnew = .FALSE.
EXIT
ENDIF
ENDDO
IF (lnew) THEN
ntypm = ntypm + 1
ity(n) = ntypm
ENDIF
ENDDO
natype(1:nat) = 0
ntype = 0
DO i =1,SIZE(atomid)
IF ( natype(i) .NE. 0 ) CYCLE
ntype = ntype + 1 ! new atom type
natype(i) = ntype ! atom type
natrep(i) = i ! this is the representative
!---> rotate representative and get symmetry equavalent atoms
DO n=1,sym%nop
tr(:) = MATMUL( sym%mrot(:,:,n) , atompos(:,i) ) + sym%tau(:,n)
tr(:) = tr(:) - ANINT( tr(:) -eps7 )
!---> this (rotated) atom done already? (correct symmetry assumed)
DO j=i+1,SIZE(atomid)
IF ( natype(j) .NE. 0 ) CYCLE
IF ( ity(j) .NE. ity(i) ) CYCLE
IF ( ANY( ABS( tr(:) - atompos(:,j) ) > eps7 ) ) CYCLE
natrep(j) = i ! representative atom
natype(j) = ntype ! atom type
EXIT
ENDDO
ENDDO
ENDDO
atoms%ntype=ntype
atoms%nat=SIZE(atomid)
ALLOCATE(atoms%neq(ntype),atoms%taual(3,atoms%nat),atoms%pos(3,atoms%nat),atoms%zatom(ntype),atoms%label(atoms%nat))
atoms%neq(1:ntype) = 0
DO n=1,nat
atoms%neq( natype(n) ) = atoms%neq( natype(n) ) + 1
atoms%zatom( natype(n) ) = atom_id(n)
ENDDO
atoms%taual=atompos(:,:atoms%nat)
atoms%label=atomlabel
WHERE ( ABS( atoms%taual ) < eps12 ) atoms%taual = 0.00