From e221094355ff1c01ba1bdb4b15df76439b445440 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=BCrg=20Hutter?= Date: Tue, 26 Jun 2001 17:51:54 +0000 Subject: [PATCH] update to version 01/12/2000 svn-origin-rev: 9 --- src/MACHINEDEFS.DEC | 1 + src/MACHINEDEFS.IBM | 1 + src/MACHINEDEFS.PGI | 1 + src/MACHINEDEFS.SGI | 9 +- src/MACHINEDEFS.T3E | 1 + src/Makefile | 11 +- src/OBJECTDEFS | 16 +- src/band.F | 318 ++++ src/brillouin.F | 203 +++ src/cntl_input.F | 178 +++ src/control_module.F | 413 ++++++ src/cp2k.F | 22 +- src/dgs.F | 106 +- src/environment.F | 4 + src/ewalds.F | 67 +- src/fermi.F | 176 +++ src/fft_tools.F | 992 ++----------- src/fftsg_lib.F | 155 ++ src/fftw_lib.F | 313 ++++ src/fist_debug.F | 225 +-- src/fist_force.F | 52 +- src/fist_force_numer.F | 293 ++-- src/fist_intra_force.F | 7 +- src/force_control.F | 19 +- src/integrator.F | 91 +- src/k290.F | 2773 +++++++++++++++++++++++++++++++++++ src/kpoint_initialization.F | 64 + src/kpoints.F | 15 + src/lib/Makefile | 25 + src/lib/ctrig.F | 111 ++ src/lib/fftpre.F | 1051 +++++++++++++ src/lib/fftrot.F | 1051 +++++++++++++ src/lib/fftstp.F | 1051 +++++++++++++ src/lib/mltfftsg.F | 133 ++ src/library_tests.F | 352 +++++ src/linklist_control.F | 7 +- src/linklists.F | 1 + src/machine.F | 12 + src/nose.F | 31 +- src/pw_grids.F | 10 +- src/pws.F | 2 +- src/structure_types.F | 20 +- src/tbmd_debug.F | 221 +-- src/tbmd_force.F | 9 +- src/tbmd_initialize.F | 129 ++ src/tbmd_input.F | 123 +- 46 files changed, 9341 insertions(+), 1524 deletions(-) create mode 100644 src/band.F create mode 100644 src/brillouin.F create mode 100644 src/cntl_input.F create mode 100644 src/control_module.F create mode 100644 src/fermi.F create mode 100644 src/fftsg_lib.F create mode 100644 src/fftw_lib.F create mode 100644 src/k290.F create mode 100644 src/kpoint_initialization.F create mode 100644 src/kpoints.F create mode 100644 src/lib/Makefile create mode 100644 src/lib/ctrig.F create mode 100644 src/lib/fftpre.F create mode 100644 src/lib/fftrot.F create mode 100644 src/lib/fftstp.F create mode 100644 src/lib/mltfftsg.F create mode 100644 src/library_tests.F create mode 100644 src/tbmd_initialize.F diff --git a/src/MACHINEDEFS.DEC b/src/MACHINEDEFS.DEC index bd49873f8d..568c0fb624 100644 --- a/src/MACHINEDEFS.DEC +++ b/src/MACHINEDEFS.DEC @@ -6,6 +6,7 @@ CPP = cpp FC = f95 -free FCfixed = f95 -fixed LDR = f95 +AR = ar -r CDEFS = -D__DEC -D__FFTW diff --git a/src/MACHINEDEFS.IBM b/src/MACHINEDEFS.IBM index e942b5473b..103019fe9f 100644 --- a/src/MACHINEDEFS.IBM +++ b/src/MACHINEDEFS.IBM @@ -6,6 +6,7 @@ CPP = cpp FC = xlf90 FCfixed = xlf90 -qfixed LDR = xlf90 +AR = ar -r CDEFS = -D__AIX -D__FFTW diff --git a/src/MACHINEDEFS.PGI b/src/MACHINEDEFS.PGI index 87746669f0..f6b2da97ae 100644 --- a/src/MACHINEDEFS.PGI +++ b/src/MACHINEDEFS.PGI @@ -6,6 +6,7 @@ CPP = cpp FC = pgf90 -Mfree FCfixed = pgf90 -Mfixed LDR = pgf90 +AR = ar -r CDEFS = -D__PGI -D__FFTW diff --git a/src/MACHINEDEFS.SGI b/src/MACHINEDEFS.SGI index eac7da6cde..66ee435442 100644 --- a/src/MACHINEDEFS.SGI +++ b/src/MACHINEDEFS.SGI @@ -6,15 +6,16 @@ CPP = /usr/lib/cpp FC = f90 -freeform FCfixed = f90 -fixedform LDR = f90 +AR = ar -r -CDEFS = -D__IRIX -D__FFTW +CDEFS = -D__IRIX -D__FFTSG -D__FFTW DEBUG = -g -C -OPT = -O3 -Ofast -BFLAGS = -u $(CDEFS) -automatic -64 +OPT = -O3 +BFLAGS = -u $(CDEFS) -automatic FFLAGS = $(BFLAGS) $(OPT) -macro_expand LFLAGS = $(BFLAGS) $(OPT) -LIBS = -L${HOME}/lib -lfftw -lcomplib.sgimath +LIBS = -L/usr/local/lib -lfftw -lcomplib.sgimath OBJECTS_ARCHITECTURE = machine_irix.o diff --git a/src/MACHINEDEFS.T3E b/src/MACHINEDEFS.T3E index 47a2e7faee..e970201111 100644 --- a/src/MACHINEDEFS.T3E +++ b/src/MACHINEDEFS.T3E @@ -6,6 +6,7 @@ CPP = cpp FC = f90 -f free FCfixed = f90 -f fixed LDR = f90 +AR = ar -r CDEFS = -D__T3E -D__FFTW diff --git a/src/Makefile b/src/Makefile index 60e821cba9..44800f0a40 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,7 +1,8 @@ .SUFFIXES: .o .F .d -CP2KHOME= ${HOME}/CP2K +CP2KHOME= ${HOME}/CP2K/ FORPAR = $(CP2KHOME)/tools/forpar.x -chkint +SFMAKEDEPEND = $(CP2KHOME)/tools/sfmakedepend -m int -s -f include OBJECTDEFS @@ -9,6 +10,8 @@ include MACHINEDEFS OBJECTS = $(OBJECTS_GENERIC) $(OBJECTS_ARCHITECTURE) +LIBRARIES = $(LIBS) -L./lib -lfftsg + ################################# PROG = cp2k.x @@ -16,7 +19,7 @@ PROG = cp2k.x all: $(PROG) $(PROG): $(OBJECTS) - $(LDR) $(LFLAGS) -o $(PROG) $(OBJECTS) $(LIBS) + $(LDR) $(LFLAGS) -o $(PROG) $(OBJECTS) $(LIBRARIES) %.o : %.F $(FC) -c $(FFLAGS) $*.F @@ -26,13 +29,13 @@ $(PROG): $(OBJECTS) parallel_include.o : parallel_include.F $(FCfixed) -c $(FFLAGS) $*.F - $(CPP) -P $(CDEFS) -U__parallel $*.F $*.f + $(CPP) -P $(CDEFS) $*.F $*.f -$(FORPAR) -fix $*.f rm -f $*.f %.d : %.F $(CPP) -P $(CDEFS) $*.F $*.f - $(PERL) $(CP2KHOME)/tools/sfmakedepend -m int -s -f $*.d $*.f + $(PERL) $(SFMAKEDEPEND) $*.d $*.f rm -f $*.f $*.d.old depend: diff --git a/src/OBJECTDEFS b/src/OBJECTDEFS index 053cb6d96c..8e1aa74669 100644 --- a/src/OBJECTDEFS +++ b/src/OBJECTDEFS @@ -1,16 +1,20 @@ OBJECTS_GENERIC = \ -atoms_input.o coefficients.o coefficient_types.o \ -constraint.o convert_units.o dgs.o dg_rho0s.o dg_types.o \ +atoms_input.o band.o brillouin.o cntl_input.o \ +coefficients.o coefficient_types.o \ +constraint.o control_module.o convert_units.o \ +dgs.o dg_rho0s.o dg_types.o \ dump.o cp2k.o cp2k_input.o environment.o \ eigenvalueproblems.o erf_fn.o global_types.o header.o \ ewalds.o ewald_parameters_types.o \ -fft_tools.o fist.o fist_debug.o fist_global.o fist_input.o \ +fermi.o fft_tools.o fftsg_lib.o fftw_lib.o \ +fist_debug.o fist_global.o \ fist_force.o fist_force_numer.o \ fist_intra_force.o fist_nonbond_force.o force_control.o \ force_fields.o integrator.o input_types.o \ initialize_particle_types.o initialize_molecule_types.o \ initialize_extended_types.o io_parameters.o lapack.o \ -kinds.o linklists.o linklist_control.o \ +k290.o kinds.o kpoint_initialization.o kpoints.o \ +library_tests.o linklists.o linklist_control.o \ linklist_cell_types.o linklist_cell_list.o \ linklist_utilities.o linklist_verlet_list.o machine.o \ mathconstants.o mol_force.o molecule_types.o \ @@ -21,5 +25,5 @@ physcon.o pme.o pws.o pw_types.o pw_grids.o \ pw_grid_types.o simulation_cell.o splines.o \ stop_program.o string_utilities.o structure_factors.o \ structure_factor_types.o structure_types.o timesl.o \ -tbmd.o tbmd_debug.o tbmd_force.o tbmd_global.o tbmd_input.o \ -tbmd_types.o timings.o unit.o util.o +tbmd_debug.o tbmd_force.o tbmd_global.o tbmd_initialize.o \ +tbmd_input.o tbmd_types.o timings.o unit.o util.o diff --git a/src/band.F b/src/band.F new file mode 100644 index 0000000000..baf256bbce --- /dev/null +++ b/src/band.F @@ -0,0 +1,318 @@ +!------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!------------------------------------------------------------------------------! +! + MODULE band +! +!------------------------------------------------------------------------------! + USE kinds, ONLY : dbl + USE stop_program, ONLY : stop_prg, stop_memory + USE brillouin, ONLY : kpoint_type + USE fermi, ONLY : fermi_distribution_type +! + IMPLICIT NONE +! + PRIVATE +! + PUBLIC :: band_structure_type, init_band_structure, band_structure_info, & + adjust_mu, occupation +! + TYPE band_structure_type + TYPE (fermi_distribution_type), POINTER :: fd + TYPE (kpoint_type), POINTER :: kpt + REAL (dbl), DIMENSION (:,:,:), POINTER :: ev + REAL (dbl), DIMENSION (:,:,:), POINTER :: oc + END TYPE band_structure_type +! + REAL (dbl), PARAMETER :: precpar = 1.E-10_dbl, & + delta = 1.E-6_dbl/27.212_dbl + REAL (dbl), PARAMETER :: toll = 1.E-13_dbl +!------------------------------------------------------------------------------! +! + CONTAINS +! +!------------------------------------------------------------------------------! + SUBROUTINE init_band_structure(bs,fd,kp) + IMPLICIT NONE + TYPE (band_structure_type), INTENT (INOUT) :: bs + TYPE (fermi_distribution_type), INTENT (IN), TARGET :: fd + TYPE (kpoint_type), INTENT (IN), TARGET :: kp + + INTEGER :: nspin, ns, nk, isos + + bs%fd => fd + bs%kpt => kp + + nspin = fd%spin_polarization + 1 + ns = max(fd%na,fd%nb) + nk = kp%nkpt + + IF (associated(bs%ev)) NULLIFY (bs%ev) + IF (associated(bs%oc)) NULLIFY (bs%oc) + ALLOCATE (bs%ev(ns,nk,nspin),STAT=isos) + IF (isos/=0) CALL stop_memory('init_band_structure', & + 'bs%ev',ns*nk*nspin) + ALLOCATE (bs%oc(ns,nk,nspin),STAT=isos) + IF (isos/=0) CALL stop_memory('init_band_structure', & + 'bs%oc',ns*nk*nspin) + + END SUBROUTINE init_band_structure +!------------------------------------------------------------------------------! + SUBROUTINE band_structure_info(bs,punit) + IMPLICIT NONE + TYPE (band_structure_type), INTENT (IN) :: bs + INTEGER, INTENT (IN) :: punit + INTEGER :: i, ik, left, nm, nk + LOGICAL :: nokp + + WRITE (punit,'(/,1x,79("-"))') + WRITE (punit,'(" -",77x,"-")') + WRITE (punit,'(" -",25x,a,24x,"-")') ' B A N D S T R U C T U R E ' + WRITE (punit,'(" -",77x,"-")') + WRITE (punit,'(1x,79("-"))') + WRITE (punit,'(" -",T23,a,f8.3,T80,"-")') & + ' Chemical Potential [a.u.] = ', bs%fd%mu + WRITE (punit,'(1x,79("-"))') + nokp = bs%kpt%scheme=='GAMMA' .OR. bs%kpt%scheme=='NULL' + IF (nokp) THEN + nk = 1 + ELSE + nk = bs%kpt%nkpt + END IF + DO ik = 1, nk + IF (nokp) THEN + WRITE (punit,'(1x,79("."))') + WRITE (punit, & + '(" .",a,i5,6x,a,f8.3,a,f8.3,a,f8.3,4x,a,f8.5,T80,".")') & + ' K-point:', ik, ' x=', bs%kpt%xk(1,ik), ' y=', bs%kpt%xk(2,ik), & + ' z=', bs%kpt%xk(3,ik), ' weight=', bs%kpt%weight(ik) + WRITE (punit,'(1x,79("."))') + END IF + IF (bs%fd%spin_polarization==0) THEN + WRITE (punit,'(A,A)') ' State Occupation Eigenvalue[au] ', & + ' State Occupation Eigenvalue[au] ' + DO i = 1, bs%fd%nstate, 2 + left = bs%fd%nstate - i + 1 + IF (left>1) THEN + WRITE (punit,'(I5,5x,F10.3,6x,F13.6,T42,I5,5x,F10.3,6x,F13.6)' & + ) i, bs%oc(i,ik,1), bs%ev(i,ik,1), i + 1, bs%oc(i+1,ik,1), & + bs%ev(i+1,ik,1) + ELSE + WRITE (punit,'(I5,5x,F10.3,6x,F13.6)') i, bs%oc(i,ik,1), & + bs%ev(i,ik,1) + END IF + END DO + ELSE + WRITE (punit,'(T12,A,T54,A)') ' Alpha Electrons ', & + ' Beta Electrons' + WRITE (punit,'(A,A)') ' State Occupation Eigenvalue[au] ', & + ' State Occupation Eigenvalue[au] ' + nm = min(bs%fd%na,bs%fd%nb) + DO i = 1, nm + WRITE (punit,'(I5,5x,F10.3,6x,F13.6,T42,I5,5x,F10.3,6x,F13.6)') & + i, bs%oc(i,ik,1), bs%ev(i,ik,1), i, bs%oc(i,ik,2), & + bs%ev(i,ik,2) + END DO + DO i = nm + 1, bs%fd%na + WRITE (punit,'(I5,5x,F10.3,6x,F13.6)') i, bs%oc(i,ik,1), & + bs%ev(i,ik,1) + END DO + DO i = nm + 1, bs%fd%nb + WRITE (punit,'(T40,I5,5x,F10.3,6x,F13.6)') i, bs%oc(i,ik,2), & + bs%ev(i,ik,2) + END DO + END IF + END DO + WRITE (punit,'(1x,79("-"),/)') + + END SUBROUTINE band_structure_info +!------------------------------------------------------------------------------! + SUBROUTINE adjust_mu(bs) +! +! adjust the chemical potential with the bisection method +! eigenvalues do not have to be sorted +! routine adapted from CPMD +! + IMPLICIT NONE + TYPE (band_structure_type), INTENT (INOUT) :: bs + REAL (dbl) :: amu, amu1, amu2, damu, sdeg + REAL (dbl) :: rhint, rhint1, rhint2, precision + INTEGER, PARAMETER :: it_max = 200 + INTEGER :: nk, it + +! + precision = precpar*log(float(bs%fd%nel+1)) +!..min and max eigenvalue + amu1 = minval(bs%ev) + amu2 = maxval(bs%ev) +! + DO + rhint1 = rhoint(bs,amu1) + IF (rhint1<0._dbl) EXIT + amu1 = -2._dbl*abs(amu1) + END DO + rhint2 = rhoint(bs,amu2) + IF (rhint2<0._dbl) CALL stop_prg('ADJUST_MU', & + 'failed to find chem. potential','number of states is too small') + damu = amu2 - amu1 + amu = amu1 +! + DO it = 1, it_max + amu = amu1 + 0.5_dbl*damu + rhint = rhoint(bs,amu) + IF (damudelta) THEN + CALL stop_prg('ADJUST_MU','failed to find chem. potential') + END IF + bs%fd%mu = amu +! + END SUBROUTINE adjust_mu +!------------------------------------------------------------------------------! + FUNCTION rhoint(bs,mu) + IMPLICIT NONE + TYPE (band_structure_type), INTENT (IN) :: bs + REAL (dbl), INTENT (IN) :: mu + REAL (dbl) :: rhoint, xlm, arg, argmin, argmax, sdeg, remain + REAL (dbl) :: dramu, drwe, wbigwe + INTEGER :: is, ik, i, n + + argmin = log(toll) + argmax = -argmin + IF (bs%fd%spin_polarization==0) THEN + sdeg = 2._dbl + ELSE + sdeg = 1._dbl + END IF + dramu = dround(mu,delta) + rhoint = 0._dbl + wbigwe = 0._dbl + DO is = 1, size(bs%ev(1,1,:)) + DO ik = 1, size(bs%ev(1,:,1)) + IF (is==1) n = bs%fd%na + IF (is==2) n = bs%fd%nb + DO i = 1, n + arg = -bs%fd%betael*(bs%ev(i,ik,is)-mu) + IF (arg>argmax) THEN + xlm = 1._dbl + ELSE IF (arg0._dbl) THEN + remain = remain/wbigwe + remain = min(remain,sdeg) + DO is = 1, size(bs%ev(1,1,:)) + DO ik = 1, size(bs%ev(1,:,1)) + IF (is==1) n = bs%fd%na + IF (is==2) n = bs%fd%nb + DO i = 1, n + drwe = dround(bs%ev(i,ik,is),delta) + IF (abs(drwe-dramu)argmax) THEN + xlm = 1._dbl + ELSE IF (arg0._dbl) THEN + remain = remain/wbigwe + remain = min(remain,sdeg) + DO is = 1, size(bs%ev(1,1,:)) + DO ik = 1, size(bs%ev(1,:,1)) + IF (is==1) n = bs%fd%na + IF (is==2) n = bs%fd%nb + DO i = 1, n + drwe = dround(bs%ev(i,ik,is),delta) + IF (abs(drwe-dramu)----------------------------------------------------------------------------! +!! SECTION: &kpoint... &end ! +!! ! +!! scheme [Gamma, Monkhorst-Pack, MacDonald, General] ! +!! { nx ny nz } ! +!! { nx ny nz sx sy sz } ! +!! { nkpt x1 y1 z1 w1 ... xn yn zn wn } ! +!! symmetry [on, off] ! +!! wavefunction [real, complex] ! +!! ! +!!<----------------------------------------------------------------------------! + SUBROUTINE kpoint_input(kp,inpar) + + IMPLICIT NONE + + TYPE (kpoint_type), INTENT (OUT) :: kp + TYPE (global_environment_type), INTENT (IN) :: inpar + + CHARACTER (len=20) :: string, str2 + CHARACTER (len=6) :: label + INTEGER :: iw, ierror, ilen, isos, i, source, group + +!..defaults + kp%scheme = 'NULL' + kp%symmetry = .FALSE. + kp%wfn_type = 0 + kp%nkpt = 0 + kp%nk = 0 + kp%shift = 0._dbl + iw = inpar%scr +!..parse the input section + label = '&KPOINT' + CALL parser_init(inpar%input_file_name,label,ierror,inpar) + IF (ierror/=0) THEN + IF (inpar%ionode) & + WRITE (iw,'(a,a)') ' No input section &KPOINT found on file ', & + adjustl(inpar%input_file_name) + ELSE + CALL read_line + DO WHILE (test_next()/='X') + ilen = 8 + CALL cfield(string,ilen) + CALL uppercase(string) + SELECT CASE (string) + CASE DEFAULT + CALL p_error() + CALL stop_parser('kpoint_input','unknown option') + CASE ('SCHEME') + ilen = 20 + CALL cfield(str2,ilen) + CALL uppercase(str2) + SELECT CASE (str2) + CASE DEFAULT + CALL p_error() + CALL stop_prg('kpoint_input','Scheme: unknown option') + CASE ('GAMMA') + kp%scheme = str2 + CASE ('MONKHORST-PACK') + kp%scheme = str2 + kp%nk(1) = get_int() + kp%nk(2) = get_int() + kp%nk(3) = get_int() + CASE ('MACDONALD') + kp%scheme = str2 + kp%nk(1) = get_int() + kp%nk(2) = get_int() + kp%nk(3) = get_int() + kp%shift(1) = get_real() + kp%shift(2) = get_real() + kp%shift(3) = get_real() + CASE ('GENERAL') + kp%scheme = str2 + kp%nkpt = get_int() + ALLOCATE (kp%xk(3,kp%nkpt),STAT=isos) + IF (isos/=0) CALL stop_memory('kpoint_input', & + 'kp%xk',3*kp%nkpt) + ALLOCATE (kp%weight(kp%nkpt),STAT=isos) + IF (isos/=0) CALL stop_memory('kpoint_input', & + 'kp%weight',kp%nkpt) + DO i = 1, kp%nkpt + kp%xk(1,i) = get_real() + kp%xk(2,i) = get_real() + kp%xk(3,i) = get_real() + kp%weight(i) = get_real() + END DO + END SELECT + CASE ('SYMMETRY') + ilen = 3 + CALL cfield(str2,ilen) + CALL uppercase(str2) + IF (str2=='OFF') kp%symmetry = .FALSE. + IF (str2=='ON') kp%symmetry = .TRUE. + CASE ('WAVEFUNC') + ilen = 4 + CALL cfield(str2,ilen) + CALL uppercase(str2) + SELECT CASE (str2) + CASE DEFAULT + CALL p_error() + CALL stop_parser('kpoint_input',& + 'Wavefunctions: unknown option') + CASE ('REAL') + kp%wfn_type = 0 + CASE ('COMP') + kp%wfn_type = 1 + END SELECT + END SELECT + END DO + END IF + CALL parser_end +!..update defaults + IF (kp%scheme=='NULL' .OR. kp%scheme=='GAMMA') THEN + kp%nkpt = 1 + ALLOCATE (kp%xk(3,1),STAT=isos) + IF (isos/=0) CALL stop_memory('kpoint_input','kp%xk',3) + ALLOCATE (kp%weight(1),STAT=isos) + IF (isos/=0) CALL stop_memory('kpoint_input','kp%weight',1) + kp%xk(:,:) = 0._dbl + kp%weight(1) = 1._dbl + kp%scheme = 'GAMMA' + END IF + END SUBROUTINE kpoint_input +!------------------------------------------------------------------------------! + SUBROUTINE brillouin_info(kp,punit) + IMPLICIT NONE + TYPE (kpoint_type), INTENT (IN) :: kp + INTEGER, INTENT (IN) :: punit + INTEGER :: i + + IF (kp%scheme=='GAMMA') THEN + WRITE (punit,*) + WRITE (punit,'(A,T57,A)') ' BRILLOUIN|', ' Gamma-point calculation' + WRITE (punit,'(A,T76,A)') ' BRILLOUIN| Wavefunction type', ' REAL' + ELSE + WRITE (punit,*) + WRITE (punit,'(A,T61,A)') ' BRILLOUIN| K-point scheme ', & + adjustr(kp%scheme) + IF (kp%scheme=='MONKHORST-PACK') THEN + WRITE (punit,'(A,T66,3I5)') ' BRILLOUIN| K-Point grid', kp%nk + ELSE IF (kp%scheme=='MACDONALD') THEN + WRITE (punit,'(A,T66,3I5)') ' BRILLOUIN| K-Point grid', kp%nk + WRITE (punit,'(A,T51,3F10.4)') ' BRILLOUIN| K-Point shift', & + kp%shift + END IF + IF (kp%symmetry) THEN + WRITE (punit,'(A,T76,A)') ' BRILLOUIN| K-Point symmetry', ' ON' + ELSE + WRITE (punit,'(A,T76,A)') ' BRILLOUIN| K-Point symmetry', ' OFF' + END IF + IF (kp%wfn_type==0) THEN + WRITE (punit,'(A,T76,A)') ' BRILLOUIN| Wavefunction type', ' REAL' + ELSE + WRITE (punit,'(A,T73,A)') ' BRILLOUIN| Wavefunction type', & + ' COMPLEX' + END IF + WRITE (punit,'(A,T71,I10)') ' BRILLOUIN| Number of K-points ', & + kp%nkpt + WRITE (punit,'(A,T30,A,T48,A,T63,A,T78,A)') ' BRILLOUIN| Number ', & + 'Weight', 'X', 'Y', 'Z' + DO i = 1, kp%nkpt + WRITE (punit,'(A,I5,3X,4F15.5)') ' BRILLOUIN| ', i, kp%weight(i), & + kp%xk(1,i), kp%xk(2,i), kp%xk(3,i) + END DO + END IF + END SUBROUTINE brillouin_info +!------------------------------------------------------------------------------! + END MODULE brillouin +!------------------------------------------------------------------------------! diff --git a/src/cntl_input.F b/src/cntl_input.F new file mode 100644 index 0000000000..61f133de62 --- /dev/null +++ b/src/cntl_input.F @@ -0,0 +1,178 @@ +!-----------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!-----------------------------------------------------------------------------! + +MODULE cntl_input + + USE ewald_parameters_types, ONLY : ewald_parameters_type + USE global_types, ONLY : global_environment_type + USE input_types, ONLY : setup_parameters_type + USE kinds, ONLY : dbl + USE parser, ONLY : parser_init, parser_end, read_line, test_next, & + cfield, p_error, get_real, get_int, stop_parser + USE string_utilities, ONLY : uppercase, xstring + + PRIVATE + PUBLIC :: read_cntl_section + +CONTAINS + +!!>---------------------------------------------------------------------------! +!! SECTION: &cntl ... &end ! +!! ! +!! simulation [md,debug] ! +!! printlevel globenv%print_level ! +!! units [kelvin,atomic] ! +!! periodic [0,1][0,1][0,1] ! +!! Ewald_type [pme_gauss,ewald_gauss] ! +!! Ewald_param alpha,[gmax,ns_max,epsilon] ! +!! set_file "filename" ! +!! input_file "filename" ! +!! symmetry [on,off] +!! ! +!!<---------------------------------------------------------------------------! + +SUBROUTINE read_cntl_section ( setup, ewald_param, globenv ) + + IMPLICIT NONE + +! Arguments + TYPE ( setup_parameters_type ), INTENT ( INOUT ) :: setup + TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param + TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv + +! Locals + INTEGER :: ierror, ilen, ia, ie, i, j, n, iw, source, group + CHARACTER ( LEN = 20 ) :: string, str2 + CHARACTER ( LEN = 5 ) :: label + CHARACTER ( LEN = 3 ), PARAMETER :: yn ( 0:1 ) = (/ ' NO', 'YES' /) + +!------------------------------------------------------------------------------ + +!..defaults + setup % run_type = 'MD' + setup % unit_type = 'KELVIN' + setup % perd = 1 + setup % symmetry = .false. + ewald_param % alpha = 0.4_dbl + ewald_param % gmax = 10 + ewald_param % ns_max = 10 + ewald_param % epsilon = 1.e-6_dbl + ewald_param % ewald_type = 'NONE' + CALL xstring(globenv % project_name,ia,ie) + setup % set_file_name = globenv % project_name(ia:ie) // '.set' + setup % input_file_name = globenv % project_name(ia:ie) // '.dat' + + iw = globenv % scr + +!..parse the input section + label = '&CNTL' + CALL parser_init(globenv % input_file_name,label,ierror,globenv) + IF (ierror /= 0 ) THEN + IF (globenv % ionode) & + WRITE ( iw, '( a )' ) ' No input section &CNTL found ' + ELSE + CALL read_line + DO WHILE (test_next()/='X') + ilen = 8 + CALL cfield ( string, ilen ) + CALL uppercase ( string ) + SELECT CASE ( string ) + CASE DEFAULT + CALL p_error() + CALL stop_parser( 'read_cntl_section','unknown option') + CASE ( 'SIMULATI') + ilen = 20 + CALL cfield(setup % run_type,ilen) + CALL uppercase(setup % run_type ) + CASE ( 'PRINTLEV') + globenv % print_level = get_int() + CASE ( 'UNITS') + ilen = 20 + CALL cfield(setup % unit_type,ilen) + CALL uppercase(setup % unit_type ) + CASE ( 'PERIODIC') + setup % perd(1) = get_int() + setup % perd(2) = get_int() + setup % perd(3) = get_int() + CASE ( 'EWALD_TY') + ilen=20 + CALL cfield(string,ILEN) + CALL uppercase ( string ) + SELECT CASE(string) + CASE( 'EWALD_GAUSS') + ewald_param % ewald_type = 'ewald_gauss' + CALL uppercase(ewald_param % ewald_type ) + CASE( 'PME_GAUSS') + ewald_param % ewald_type = 'pme_gauss' + CALL uppercase(ewald_param % ewald_type ) + END SELECT + +! if no type specified, assume ewald_gauss + CASE ( 'EWALD_PA') + ewald_param % alpha = get_real() + SELECT CASE (ewald_param % ewald_TYPE ( 1:3)) + CASE DEFAULT + ewald_param % gmax = get_int() + CASE ( 'PME') + ewald_param % ns_max = get_int() + IF ( test_next() == 'N' ) THEN + ewald_param % epsilon = get_real() + END IF + END SELECT + CASE ('SYMMETRY') + ilen = 3 + CALL cfield(str2,ilen) + CALL uppercase(str2) + IF ( str2(1:2) == "ON" ) setup%symmetry=.true. + IF ( str2(1:3) == "OFF" ) setup%symmetry=.false. + CASE ( 'SET_FILE') + ilen = 20 + CALL cfield(setup % set_file_name,ilen) + CASE ( 'INPUT_FI') + ilen = 20 + CALL cfield(setup % input_file_name,ilen) + END SELECT + +! check for trailing rubbish + CALL read_line + END DO + + END IF + CALL parser_end +!..end of parsing the input section + +!..write some information to output + IF (globenv % ionode) THEN + IF ( globenv % print_level >= 0 ) THEN + WRITE ( iw, '( A, T71, A )' ) & + ' CONTROL| Run type ', ADJUSTR ( setup % run_type ) + WRITE ( iw, '( A, T71, A )' ) & + ' CONTROL| Unit type ', ADJUSTR ( setup % unit_type ) + WRITE ( iw, '( A, T78, A )' ) ' CONTROL| Periodic in X direction ', & + yn(setup % perd(1)) + WRITE ( iw, '( A, T78, A )' ) ' CONTROL| Periodic in Y direction ', & + yn(setup % perd(2)) + WRITE ( iw, '( A, T78, A )' ) ' CONTROL| Periodic in Z direction ', & + yn(setup % perd(3)) + IF ( setup%symmetry ) THEN + WRITE (iw,'(A,T78,A)') ' CONTROL| Use of symmetry ','Yes' + ELSE + WRITE (iw,'(A,T78,A)') ' CONTROL| Use of symmetry ',' No' + END IF + WRITE ( iw, '( A, T61, A )' ) ' CONTROL| Set file name', & + ADJUSTR ( setup % set_file_name ) + WRITE ( iw, '( A, T61, A )' ) ' CONTROL| Input file name', & + ADJUSTR ( setup % input_file_name ) + WRITE ( iw, '( A, T76, I5 )' ) & + ' CONTROL| Print level ', globenv % print_level + WRITE ( iw, '( )' ) + END IF + END IF + +END SUBROUTINE read_cntl_section + +!****************************************************************************** + +END MODULE cntl_input diff --git a/src/control_module.F b/src/control_module.F new file mode 100644 index 0000000000..027ecdb54a --- /dev/null +++ b/src/control_module.F @@ -0,0 +1,413 @@ +!-----------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!-----------------------------------------------------------------------------! + +MODULE control_module + + USE atoms_input, ONLY : read_coord_vel, system_type + USE convert_units, ONLY : convert + USE global_types, ONLY : global_environment_type + USE dump, ONLY : dump_variables + USE ewalds, ONLY : ewald_print, ewald_correction + USE ewald_parameters_types, ONLY : ewald_parameters_type + USE header, ONLY : fist_header, tbmd_header + USE kinds, ONLY : dbl + USE band, ONLY : band_structure_type, init_band_structure + USE brillouin, ONLY : kpoint_type, brillouin_info, kpoint_input + USE kpoint_initialization, ONLY : initialize_kpoints + USE fermi, ONLY : fermi_distribution_type, init_fermi_dist, fermi_info + USE fist_debug, ONLY : fist_debug_control => debug_control + USE tbmd_debug, ONLY : tbmd_debug_control => debug_control + USE tbmd_initialize, ONLY : tbmd_init, tb_get_numel + USE tbmd_global, ONLY : tbatom, tbhop + USE tbmd_input, ONLY : read_tb_hamiltonian, read_tb_hopping_elements + USE cntl_input, ONLY : read_cntl_section + USE force_fields, ONLY : read_force_field_section, ATOMNAMESLENGTH + USE initialize_extended_types, ONLY : initialize_extended_type + USE initialize_molecule_types, ONLY : initialize_molecule_type + USE initialize_particle_types, ONLY : initialize_particle_type + USE integrator, ONLY : velocity_verlet, force, set_energy_parm, energy, & + set_integrator + USE input_types, ONLY : setup_parameters_type + USE linklist_control, ONLY : set_ll_parm + USE mathconstants, ONLY : zero + USE md, ONLY : read_md_section, simulation_parameters_type, & + initialize_velocities, thermodynamic_type, mdio_parameters_type + USE molecule_input, ONLY : read_molecule_section, read_setup_section, & + charge + USE molecule_types, ONLY : molecule_type, intra_parameters_type + USE nose, ONLY : extended_parameters_type + USE pair_potential, ONLY : spline_nonbond_control + USE particle_types, ONLY : particle_prop_type, particle_type + USE simulation_cell, ONLY : cell_type, get_hinv + USE stop_program, ONLY : stop_prg, stop_memory + USE structure_types, ONLY : structure_type, interaction_type + USE timings, ONLY : timeset, timestop, trace_debug + USE unit, ONLY : unit_convert_type, set_units + USE util, ONLY : close_unit, get_share + + IMPLICIT NONE + + PRIVATE + PUBLIC :: control + + TYPE ( mdio_parameters_type ) :: mdio + +CONTAINS + +!-----------------------------------------------------------------------------! +! CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL ! +!-----------------------------------------------------------------------------! + +SUBROUTINE control ( globenv ) + + IMPLICIT NONE + + TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv + +! Locals + REAL ( dbl ) :: cons, ecut, qi, qj + REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rcut + INTEGER :: handle1, handle2, handle3 , itimes, isos, para_comm_cart + INTEGER :: iat, jat, nel + CHARACTER ( LEN = ATOMNAMESLENGTH ), DIMENSION ( : ), POINTER :: atom_names + CHARACTER ( LEN = 20 ) :: set_fn + LOGICAL :: tbmd, fist + + TYPE ( particle_prop_type ), DIMENSION ( : ), POINTER :: pstat + TYPE ( molecule_type ), DIMENSION ( : ), POINTER :: mol_setup + TYPE ( unit_convert_type ) :: units + TYPE ( simulation_parameters_type ) :: simpar + TYPE ( structure_type ) :: struc + TYPE ( interaction_type ) :: inter + TYPE ( extended_parameters_type ) :: nhcp + TYPE ( thermodynamic_type ) :: thermo + TYPE ( system_type ) :: ainp + TYPE ( ewald_parameters_type ) :: ewald_param + TYPE ( setup_parameters_type ) :: setup + TYPE ( intra_parameters_type ) :: intra_param + TYPE ( kpoint_type ) :: kp + TYPE ( fermi_distribution_type ) :: fd + TYPE ( band_structure_type ) :: bs + +!------------------------------------------------------------------------------ + +! IF( globenv % ionode ) CALL trace_debug ( "START" ) + + CALL timeset ( 'CONTROL', 'I', ' ', handle1 ) + CALL timeset ( 'CNTL_INIT', 'I', ' ', handle2 ) + + IF ( globenv % program_name == 'FIST' ) THEN + fist = .true. + tbmd = .false. + ELSE IF ( globenv % program_name == 'TBMD' ) THEN + tbmd = .true. + fist = .false. + ELSE + call stop_prg ( ' control ',' program_name not specified' ) + ENDIF + + IF ( globenv % ionode ) THEN + IF ( fist ) CALL fist_header ( globenv % scr ) + IF ( tbmd ) CALL tbmd_header ( globenv % scr ) + END IF + +!..read cntl section + + CALL read_cntl_section ( setup, ewald_param, globenv ) + +! read from the setup and molecule section of *.set + + set_fn = setup % set_file_name + + CALL read_setup_section ( mol_setup, set_fn, globenv ) + + CALL read_molecule_section ( mol_setup, set_fn, globenv ) + +! read force_field information for classical MD +! read pair potential information for TB + + CALL read_force_field_section ( setup, mol_setup, set_fn, & + intra_param, inter%potparm, atom_names, pstat, globenv ) + +!..read Hamiltonian section + + IF ( tbmd ) THEN + CALL read_tb_hamiltonian ( setup, atom_names, inter%tbatom, globenv ) + CALL read_tb_hopping_elements ( setup, atom_names, & + inter%tbatom, inter%tbhop, globenv ) + END IF + +!..read the input of the molecular dynamics section + + CALL read_md_section ( simpar, globenv, mdio ) + simpar % program = globenv % program_name + +!..read atomic coordinates, velocities (optional) and the simulation box + ainp % rtype = simpar % read_type + CALL read_coord_vel ( ainp, setup % input_file_name, globenv ) + +!..initialize box, perd + struc % box % hmat = ainp % box + struc % box % perd = setup % perd + +!..K-Points + IF ( SUM ( struc % box % perd ) == 0 ) THEN + kp%scheme = "NULL" + ELSE IF ( tbmd ) THEN + CALL kpoint_input ( kp, globenv ) + ELSE + kp%scheme = "NULL" + END IF + +!..initialize working units + CALL set_units ( setup % unit_type, units ) + + CALL set_energy_parm ( units % pconv, units % econv, units % l_label, & + units % vol_label, units % e_label, units % pres_label, & + units % temp_label, units % angl_label ) + +!..allocate memory for atoms and molecules + CALL allocmem ( ainp, mol_setup, struc, globenv ) + +!..initialize particle_type + CALL initialize_particle_type ( atom_names, simpar, mol_setup, & + ainp, pstat, struc % part ) + +!..convert the units + CALL convert ( units = units, simpar = simpar, & + part = struc % part, pstat = pstat, box = struc % box, & + potparm = inter%potparm, intra_param = intra_param, & + ewald_param = ewald_param ) + +!..calculate the inverse box matrix now after the unit conversion, +! so it also has the right units + CALL get_hinv ( struc % box ) + +!..initialize molecule_type + CALL initialize_molecule_type ( mol_setup, intra_param, struc % pnode, & + struc % part, struc % molecule, globenv ) + +!..initialize extended_parameters_type and get number of degrees of freedom + CALL initialize_extended_type ( struc % box, simpar, & + struc % molecule, mol_setup, nhcp, globenv ) + +! initialize velocities if needed + IF ( simpar % read_type == 'POS' ) THEN + CALL initialize_velocities ( simpar, struc % part, globenv ) + END IF + +!...initialize splines + + inter%potparm ( :, : ) % energy_cutoff = 0.0_dbl + inter%potparm ( :, : ) % e_cutoff_coul = 0.0_dbl + CALL spline_nonbond_control ( inter%potparm, pstat, 5000, ewald_param ) + +!..set linklist control parameters + ALLOCATE ( rcut ( setup % natom_type, setup % natom_type ), STAT = isos ) + IF ( isos /=0 ) CALL stop_memory ( 'control', 'rcut', 0 ) + + rcut ( :, : ) = inter%potparm ( :, : ) % rcutsq + + CALL set_ll_parm ( globenv, simpar % verlet_skin, & + setup % natom_type, rcut, simpar % n_cell ) + + CALL set_ll_parm ( globenv, printlevel = globenv % print_level, & + ltype = 'NONBOND' ) + + DEALLOCATE ( rcut, STAT = isos ) + IF ( isos /= 0 ) CALL stop_memory ( 'control', 'rcut' ) + +!..deallocate arrays needed for atom input + IF ( ASSOCIATED ( ainp % c ) ) THEN + DEALLOCATE ( ainp % c, STAT = isos ) + IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%c' ) + END IF + + IF ( ASSOCIATED ( ainp % v ) ) THEN + DEALLOCATE ( ainp % v, STAT = isos ) + IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%v' ) + END IF +! +!..initialize the on-site terms for TB + IF ( tbmd ) CALL tbmd_init ( struc % part, tbatom, tbhop ) +! +!..Symmetry and K-points +! + IF ( SUM ( struc % box % perd ) == 0 ) THEN +!!!!!! symmetry setup for molecules + ELSE IF ( tbmd ) THEN + CALL initialize_kpoints ( globenv, kp, setup % symmetry, & + struc % box % hmat, struc % part ) + IF ( globenv%ionode .AND. globenv%print_level > 0) & + CALL brillouin_info ( kp, globenv%scr ) + END IF +!..nota bene: we use the defaults for the elctron temperature and +! spin polarisation + IF ( tbmd ) then + nel = tb_get_numel ( tbatom, charge ) + CALL init_fermi_dist(fd,nel) + IF (globenv%ionode) CALL fermi_info(fd,globenv%print_level,globenv%scr) + CALL init_band_structure(bs,fd,kp) + ENDIF + + CALL timestop ( zero, handle2 ) + CALL timeset ( 'CNTL_WORK', 'I', ' ', handle3 ) + IF ( setup % run_type == 'DEBUG' ) THEN +!..debug the forces + +!..initialize integrator + CALL set_integrator ( globenv, mdio ) + + IF ( fist ) then + CALL fist_debug_control( globenv, ewald_param, struc%part, struc%pnode, & + struc%molecule, struc%box, thermo, inter%potparm, simpar % ensemble ) + ELSE IF ( tbmd ) THEN + CALL tbmd_debug_control( globenv, ewald_param, struc%part, struc%pnode, & + struc%molecule, struc%box, thermo, inter%potparm, simpar % ensemble ) + ENDIF + + ELSE + +!..initialize integrator + CALL set_integrator ( globenv, mdio ) + +!..MD + itimes = 0 + + CALL force ( struc, inter, thermo, simpar, ewald_param, globenv ) + IF ( globenv % ionode .AND. ewald_param % ewald_type /= 'NONE' ) & + CALL ewald_print ( globenv % scr, thermo, struc % box, & + units % e_label ) + CALL energy ( itimes, cons, simpar, struc, thermo, nhcp ) + + DO itimes = 1, simpar % nsteps + CALL velocity_verlet ( itimes, cons, simpar, inter, thermo, & + struc, ewald_param, nhcp ) + + IF ( MOD ( itimes, mdio % idump ) == 0 ) & + CALL dump_variables ( struc, mdio % dump_file_name, globenv ) + END DO + + CALL dump_variables ( struc, mdio % dump_file_name, globenv ) + + IF ( globenv % ionode ) CALL close_unit ( 10, 99 ) + END IF + +!..deallocate memory for atoms and molecules + CALL deallocmem ( struc ) + + CALL timestop ( zero, handle3 ) + CALL timestop ( zero, handle1 ) + +END SUBROUTINE control + +!-----------------------------------------------------------------------------! +! CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL CNTL ! +!-----------------------------------------------------------------------------! + +SUBROUTINE allocmem ( ainp, mol_setup, struc, globenv ) + + IMPLICIT NONE + +! Arguments + TYPE ( molecule_type ), DIMENSION ( : ), INTENT ( IN ) :: mol_setup + TYPE ( structure_type ), INTENT ( INOUT ) :: struc + TYPE ( system_type ), INTENT ( IN ) :: ainp + TYPE ( global_environment_type ), INTENT ( IN ) :: globenv + +! Locals + INTEGER :: iw, natoms, nnodes, nmol, nmoltype, ios, iat, i, nsh + +!------------------------------------------------------------------------------ + + struc % name = globenv % program_name // ' MOLECULAR SYSTEM' + IF ( globenv % num_pe == 1 ) THEN + natoms = SIZE ( ainp % c ( 1, : ) ) + ALLOCATE ( struc % part ( 1:natoms ), STAT = ios ) + IF ( ios /= 0 ) CALL stop_memory ( 'control', 'part', natoms ) + ALLOCATE ( struc % pnode ( 1:natoms ), STAT = ios ) + IF ( ios /= 0 ) CALL stop_memory ( 'control', 'pnode', natoms ) + nmol = SUM ( mol_setup ( : ) % num_mol ) + + ALLOCATE ( struc % molecule ( 1:nmol ), STAT = ios ) + IF ( ios /= 0 ) CALL stop_memory ( 'control', 'molecule', nmol ) + + IF ( globenv % ionode .AND. globenv % print_level > 3 ) THEN + iw = globenv % scr + + WRITE ( iw, '( A )' ) + WRITE ( iw, '( A, T71, I10 )' ) & + ' CONTROL| Number of allocated particles ', natoms + WRITE ( iw,'( A, T71, I10 )' ) & + ' CONTROL| Number of allocated particle nodes ', natoms + WRITE ( iw, '( A, T71, I10 )' ) & + ' CONTROL| Number of allocated molecules ', nmol + WRITE ( iw, '( A )' ) + END IF + ELSE + +!..replicated data + natoms = SIZE ( ainp % c ( 1, : ) ) + ALLOCATE ( struc % part ( 1:natoms ), STAT = ios ) + IF ( ios /= 0 ) CALL stop_memory ( 'control', 'part', natoms ) + nmoltype = SIZE ( mol_setup ) + nmol = 0 + nnodes = 0 + DO i = 1, nmoltype + nsh = get_share ( mol_setup ( i ) % num_mol, & + globenv % num_pe, globenv % mepos ) + nmol = nmol + nsh + nnodes = nnodes + nsh * mol_setup ( i ) % molpar % natom + END DO + + ALLOCATE ( struc % molecule ( 1:nmol ), STAT = ios ) + IF ( ios /= 0 ) CALL stop_memory ( 'control', 'molecule' , nmol ) + ALLOCATE ( struc % pnode ( 1:nnodes ), STAT = ios ) + IF ( ios /= 0 ) CALL stop_memory ( 'control', 'pnode', nnodes ) + + IF ( globenv % ionode .AND. globenv % print_level > 3 ) THEN + iw = globenv % scr + WRITE ( iw, '( A )' ) + WRITE ( iw, '( A, T71, I10 )' ) & + ' CONTROL| Number of allocated particles ', natoms + WRITE ( iw, '( A, T71, I10 )' ) & + ' CONTROL| Number of allocated particle nodes ', nnodes + WRITE ( iw, '( A, I5, T71, I10 )' ) & + ' CONTROL| Number of allocated molecules on processor ', & + globenv % mepos, nmol + WRITE ( iw, '( A )' ) + END IF + + END IF + +END SUBROUTINE allocmem + +!****************************************************************************** + +SUBROUTINE deallocmem ( struc ) + IMPLICIT NONE + +! Arguments + TYPE ( structure_type ), INTENT ( INOUT ) :: struc + +! Locals + INTEGER :: ios + +!------------------------------------------------------------------------------ + + DEALLOCATE ( struc % part, STAT = ios ) + IF ( ios /= 0 ) CALL stop_memory ( 'control', 'part' ) + + DEALLOCATE ( struc % pnode, STAT = ios ) + IF ( ios /= 0 ) CALL stop_memory ( 'control', 'pnode' ) + + DEALLOCATE ( struc % molecule, STAT = ios ) + IF ( ios /= 0 ) CALL stop_memory ( 'control', 'molecule' ) + +END SUBROUTINE deallocmem + +!****************************************************************************** + +END MODULE control_module diff --git a/src/cp2k.F b/src/cp2k.F index 3da5b09cd7..690b6797cc 100644 --- a/src/cp2k.F +++ b/src/cp2k.F @@ -27,14 +27,12 @@ PROGRAM cp2k USE cp2k_input, ONLY : read_cp2k_section USE environment, ONLY : initialisation, trailer - USE fist, ONLY : fist_main - USE fist_global, ONLY : set_fist_global + USE control_module, ONLY : control USE global_types, ONLY : global_environment_type + USE library_tests,ONLY : lib_test USE kinds, ONLY : dbl, print_kind_info USE parallel, ONLY : start_parallel, end_parallel USE physcon, ONLY : print_physcon - USE tbmd, ONLY : tbmd_main - USE tbmd_global, ONLY : set_tbmd_global IMPLICIT NONE @@ -53,17 +51,19 @@ PROGRAM cp2k IF ( globenv % ionode .AND. globenv % print_level > 4 ) & CALL print_physcon ( globenv % scr ) - IF ( globenv % program_name == 'FIST' ) THEN - CALL set_fist_global ( globenv ) - CALL fist_main() + IF ( globenv % program_name == 'FIST' .OR. & + globenv % program_name == 'TBMD' ) THEN + + CALL control ( globenv ) - ELSE IF ( globenv % program_name == 'TBMD' ) THEN - CALL set_tbmd_global ( globenv ) - CALL tbmd_main() + ELSE IF ( globenv % program_name == 'TEST' ) THEN + + CALL lib_test ( globenv ) + END IF CALL trailer ( globenv ) - CALL end_parallel() + CALL end_parallel ( ) END PROGRAM cp2k diff --git a/src/dgs.F b/src/dgs.F index 7c579d8d5e..1946fae7e4 100644 --- a/src/dgs.F +++ b/src/dgs.F @@ -6,12 +6,12 @@ MODULE dgs USE coefficient_types, ONLY : coeff_type - USE fft_tools, ONLY : fft_radix_operations, & - FFT_RADIX_ALLOWED, FFT_RADIX_DISALLOWED, BWFFT, FWFFT, & - fft3d => fft_wrap + USE fft_tools, ONLY : fft_radix_operations, fft3d, & + FFT_RADIX_ALLOWED, FFT_RADIX_DISALLOWED, FFT_RADIX_NEXT, & + FFT_RADIX_CLOSEST, BWFFT, FWFFT USE kinds, ONLY : dbl, sgl USE mathconstants, ONLY : twopi, pi - USE pw_grid_types, ONLY : pw_grid_type + USE pw_grid_types, ONLY : pw_grid_type, HALFSPACE USE pw_grids, ONLY : pw_grid_setup, pw_find_cutoff USE pw_types, ONLY : COMPLEXDATA3D USE pws, ONLY : fft_wrap @@ -38,46 +38,43 @@ SUBROUTINE dg_grid_setup ( box_b, npts_s, epsilon, alpha, grid_s, grid_b, & ! Arguments INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts_s - REAL ( dbl ), INTENT ( IN ) :: epsilon, alpha + REAL ( dbl ), INTENT ( INOUT ) :: epsilon + REAL ( dbl ), INTENT ( IN ) :: alpha TYPE ( cell_type ), INTENT ( IN ) :: box_b CHARACTER( LEN = * ), INTENT ( IN ) :: dg_gaussian_type TYPE ( pw_grid_type ), INTENT ( INOUT ) :: grid_s, grid_b ! Locals - INTEGER :: check + INTEGER :: nout ( 3 ) REAL ( dbl ) :: dr ( 3 ), cutoff REAL ( dbl ) :: cell_lengths ( 3 ) TYPE ( cell_type ) :: unit_box, box_s - INTEGER :: foo ( 3 ) !*apsi !------------------------------------------------------------------------------ - - CALL fft_radix_operations ( npts_s ( 1 ), check, & - operation = FFT_RADIX_ALLOWED ) - IF ( check /= FFT_RADIX_ALLOWED ) THEN - CALL stop_prg ( "dg_grid_setup", "disallowed small FFT length #1" ) - END IF - CALL fft_radix_operations ( npts_s ( 2 ), check, & - operation = FFT_RADIX_ALLOWED ) - IF ( check /= FFT_RADIX_ALLOWED ) THEN - CALL stop_prg ( "dg_grid_setup", "disallowed small FFT length #2" ) - END IF - CALL fft_radix_operations ( npts_s ( 3 ), check, & - operation = FFT_RADIX_ALLOWED ) - IF ( check /= FFT_RADIX_ALLOWED ) THEN - CALL stop_prg ( "dg_grid_setup", "disallowed small FFT length #3" ) - END IF + + CALL fft_radix_operations ( npts_s ( 1 ), nout ( 1 ), & + operation = FFT_RADIX_NEXT ) + CALL fft_radix_operations ( npts_s ( 1 ), nout ( 2 ), & + operation = FFT_RADIX_NEXT ) + CALL fft_radix_operations ( npts_s ( 1 ), nout ( 3 ), & + operation = FFT_RADIX_NEXT ) CALL get_cell_param ( box_b, cell_lengths ) - CALL dg_get_spacing ( npts_s, epsilon, alpha, dg_gaussian_type, dr ) + CALL dg_get_spacing ( nout, epsilon, alpha, dg_gaussian_type, dr ) CALL dg_find_radix ( dr, cell_lengths, grid_b % npts ) + CALL dg_get_epsilon ( nout, epsilon, alpha, dg_gaussian_type, dr ) + grid_b % bounds ( 1, : ) = - grid_b % npts / 2 grid_b % bounds ( 2, : ) = + ( grid_b % npts - 1 ) / 2 - grid_s % npts ( : ) = grid_s % bounds ( 2, : ) - grid_s % bounds ( 1, : ) + 1 + grid_b % grid_span = HALFSPACE + grid_s % bounds ( 1, : ) = -nout ( : ) / 2 + grid_s % bounds ( 2, : ) = ( +nout ( : ) - 1 ) / 2 + grid_s % grid_span = HALFSPACE + grid_s % npts = nout CALL pw_find_cutoff ( grid_b % npts, box_b, cutoff ) @@ -109,8 +106,6 @@ SUBROUTINE dg_get_spacing ( npts, epsilon, alpha, dg_gaussian_type, dr ) !------------------------------------------------------------------------------ - write(6,*) "dg_get_spacing, please check n/2 vs REAL(n)/2.0 !!!" - SELECT CASE ( dg_gaussian_type ) CASE ( "PME_GAUSS" ) ! use a Gaussian of form N exp(-2*alpha^2*r^2) @@ -137,18 +132,71 @@ END SUBROUTINE dg_get_spacing !****************************************************************************** +SUBROUTINE dg_get_epsilon ( npts, epsilon, alpha, dg_gaussian_type, dr ) + + IMPLICIT NONE + +! Arguments + INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts + REAL ( dbl ), INTENT ( OUT ) :: epsilon + REAL ( dbl ), INTENT ( IN ) :: alpha + CHARACTER ( LEN = * ), INTENT ( IN ) :: dg_gaussian_type + + REAL ( dbl ), DIMENSION ( : ), INTENT ( OUT ) :: dr + +! Locals + REAL ( dbl ) :: alphasq, norm, rlen + +!------------------------------------------------------------------------------ + + SELECT CASE ( dg_gaussian_type ) + + CASE ( "PME_GAUSS" ) ! use a Gaussian of form N exp(-2*alpha^2*r^2) + rlen = MAXVAL ( REAL ( npts, dbl ) * dr ) * 0.5_dbl + alphasq = alpha ** 2 + norm = ( 2.0_dbl * alphasq / pi ) ** ( 1.5_dbl ) + epsilon = norm * exp ( - 2._dbl * alphasq * rlen * rlen ) + + CASE ( "S" ) ! use a Gaussian of form N exp(-2*alpha^2*r^2) + rlen = MAXVAL ( REAL ( npts, dbl ) * dr ) * 0.5_dbl + alphasq = alpha ** 2 + norm = ( 2.0_dbl * alphasq / pi ) ** ( 1.5_dbl ) + epsilon = norm * exp ( - 2._dbl * alphasq * rlen * rlen ) + + CASE ( "P" ) + CALL stop_prg ( "dg_get_spacing", "'P; gaussian type not defined" ) + + CASE DEFAULT + CALL stop_prg ( "dg_get_spacing", "no suitable gaussian type specified" ) + + END SELECT + +END SUBROUTINE dg_get_epsilon + +!****************************************************************************** + SUBROUTINE dg_find_radix ( dr, cell_lengths, npts ) IMPLICIT NONE ! Arguments - REAL ( dbl ), INTENT ( IN ) :: dr ( 3 ) + REAL ( dbl ), INTENT ( INOUT ) :: dr ( 3 ) REAL ( dbl ), INTENT ( IN ) :: cell_lengths ( 3 ) INTEGER, DIMENSION ( : ), INTENT ( OUT ) :: npts + +! Locals + INTEGER, DIMENSION ( 3 ) :: nin !------------------------------------------------------------------------------ - npts ( : ) = NINT ( cell_lengths ( : ) / dr ( : ) ) + nin ( : ) = NINT ( cell_lengths ( : ) / dr ( : ) ) + CALL fft_radix_operations ( nin ( 1 ), npts ( 1 ), & + operation = FFT_RADIX_CLOSEST ) + CALL fft_radix_operations ( nin ( 2 ), npts ( 2 ), & + operation = FFT_RADIX_CLOSEST ) + CALL fft_radix_operations ( nin ( 3 ), npts ( 3 ), & + operation = FFT_RADIX_CLOSEST ) + dr ( : ) = cell_lengths ( : ) / REAL ( npts ( : ), dbl ) END SUBROUTINE dg_find_radix diff --git a/src/environment.F b/src/environment.F index 2019d94261..a9c8114e2d 100644 --- a/src/environment.F +++ b/src/environment.F @@ -15,6 +15,7 @@ MODULE environment USE timesl, ONLY : walltime, cputime, datum USE timings, ONLY : timeprint, timeset, timestop USE util, ONLY : ran2 + USE fft_tools, ONLY : init_fft IMPLICIT NONE @@ -86,6 +87,9 @@ SUBROUTINE initialisation ( globenv ) ! initialize physical constants CALL init_physcon() + +! initialize FFT library + CALL init_fft ( ) END SUBROUTINE initialisation diff --git a/src/ewalds.F b/src/ewalds.F index 9b6d737d75..c3b7df718d 100644 --- a/src/ewalds.F +++ b/src/ewalds.F @@ -9,6 +9,7 @@ MODULE ewalds USE dgs, ONLY : dg_grid_setup USE dg_types, ONLY : dg_type USE ewald_parameters_types, ONLY : ewald_parameters_type + USE global_types, ONLY : global_environment_type USE kinds, ONLY : dbl USE mathconstants, ONLY : pi, zero USE md, ONLY : thermodynamic_type @@ -317,19 +318,18 @@ END SUBROUTINE ewald_print !****************************************************************************** SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, & - thermo, iounit, ewald_grid, pme_small_grid, pme_big_grid ) + thermo, ewald_grid, pme_small_grid, pme_big_grid ) IMPLICIT NONE ! Arguments TYPE ( dg_type ), INTENT ( OUT ) :: dg - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param + TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - INTEGER, INTENT ( IN ) :: pnode_grp + TYPE ( global_environment_type ), INTENT ( IN ) :: pnode_grp TYPE ( cell_type ), INTENT ( IN ) :: box TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - INTEGER, INTENT ( IN ) :: iounit TYPE ( pw_grid_type ), INTENT ( OUT ), OPTIONAL :: ewald_grid TYPE ( pw_grid_type ), INTENT ( OUT ), OPTIONAL :: pme_small_grid TYPE ( pw_grid_type ), INTENT ( OUT ), OPTIONAL :: pme_big_grid @@ -342,34 +342,36 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, & ! parallelisation is over atoms (pnodes), so the group of processors ! has to be the same as the group for the pnodes - ewald_grp = pnode_grp + ewald_grp = pnode_grp % group ! writing output to unit iounit - iw = iounit + iw = pnode_grp % scr natoms = SIZE ( part ) - IF ( ewald_param % ewald_type /= 'NONE' ) THEN + IF ( pnode_grp % ionode ) THEN + IF ( ewald_param % ewald_type /= 'NONE' ) THEN - WRITE ( iw, '( A,T71,A )' ) ' Ewald summation is done by:', & - ewald_param % ewald_type - WRITE ( iw, '( A,T71,F10.4 )' ) ' Ewald alpha parameter [A]', & - ewald_param % alpha - SELECT CASE ( ewald_param % ewald_type ( 1:3 ) ) - CASE DEFAULT - WRITE ( iw, '( A,T71,I10 )' ) & - ' Ewald G-space max. Miller index', ewald_param % gmax - CASE ( 'PME') - WRITE ( iw, '( A,T71,I10 )' ) & - ' PME max small-grid points ', ewald_param % ns_max - WRITE ( iw, '( A,T71,F10.4 )' ) & - ' PME gaussian tolerance ', ewald_param % epsilon - END SELECT + WRITE ( iw, '( A,T67,A14 )' ) ' Ewald| Summation is done by:', & + ADJUSTR(ewald_param % ewald_type) + WRITE ( iw, '( A,T71,F10.4 )' ) ' Ewald| Alpha parameter [A]', & + ewald_param % alpha + SELECT CASE ( ewald_param % ewald_type ( 1:3 ) ) + CASE DEFAULT + WRITE ( iw, '( A,T71,I10 )' ) & + ' Ewald| G-space max. Miller index', ewald_param % gmax + CASE ( 'PME') + WRITE ( iw, '( A,T71,I10 )' ) & + ' PME| Max small-grid points (input) ', ewald_param % ns_max + WRITE ( iw, '( A,T71,E10.4 )' ) & + ' PME| Gaussian tolerance (input) ', ewald_param % epsilon + END SELECT - ELSE + ELSE - WRITE ( iw, '( A )' ) ' No Ewald summation is performed' + WRITE ( iw, '( A, T73, A )' ) ' Ewald| ','not used' + END IF END IF ! fire up the reciprocal space and compute self interaction and @@ -383,7 +385,8 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, & IF ( PRESENT ( ewald_grid ) ) THEN gmax = ewald_param % gmax IF ( gmax == 2 * ( gmax / 2 ) ) THEN - CALL stop_prg ( "initialize_ewalds", "gmax has to be odd" ) + IF ( pnode_grp % ionode ) & + CALL stop_prg ( "initialize_ewalds", "gmax has to be odd" ) END IF ewald_grid % bounds ( 1, : ) = -gmax / 2 ewald_grid % bounds ( 2, : ) = +gmax / 2 @@ -401,16 +404,22 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, & IF ( PRESENT ( pme_small_grid ) .AND. PRESENT ( pme_big_grid ) ) THEN npts_s ( : ) = ewald_param % ns_max - pme_small_grid % bounds ( 1, : ) = -npts_s ( : ) / 2 - pme_small_grid % bounds ( 2, : ) = ( +npts_s ( : ) - 1 ) / 2 - pme_small_grid % grid_span = HALFSPACE - pme_big_grid % grid_span = HALFSPACE CALL dg_grid_setup ( box, npts_s, ewald_param % epsilon, & ewald_param % alpha, pme_small_grid, & pme_big_grid, ewald_param % ewald_type ) CALL pme_setup (pnode, pme_small_grid, ewald_param, dg ) + + IF ( pnode_grp % ionode ) THEN + WRITE ( iw, '( A,T71,E10.4 )' ) & + ' PME| Gaussian tolerance (effective) ', ewald_param % epsilon + WRITE ( iw, '( A,T63,3I6 )' ) & + ' PME| Small box grid ', pme_small_grid % npts + WRITE ( iw, '( A,T63,3I6 )' ) & + ' PME| Full box grid ', pme_big_grid % npts + END IF + END IF END IF @@ -420,3 +429,5 @@ END SUBROUTINE ewald_initialize !****************************************************************************** END MODULE ewalds + +!****************************************************************************** diff --git a/src/fermi.F b/src/fermi.F new file mode 100644 index 0000000000..736b98dcda --- /dev/null +++ b/src/fermi.F @@ -0,0 +1,176 @@ +!------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!------------------------------------------------------------------------------! +! + MODULE fermi +! +!------------------------------------------------------------------------------! + USE kinds, ONLY : dbl + USE stop_program, ONLY : stop_prg + USE physcon, ONLY : boltzmann, joule +! + IMPLICIT NONE +! + PRIVATE + + PUBLIC :: fermi_distribution_type, init_fermi_dist, fermi_info +! + TYPE fermi_distribution_type + REAL (dbl) :: electronic_temp + REAL (dbl) :: betael + REAL (dbl) :: mu + INTEGER :: nel, nalpha, nbeta + INTEGER :: spin_polarization + INTEGER :: multiplicity + INTEGER :: nstate, na, nb + END TYPE fermi_distribution_type +!------------------------------------------------------------------------------! +! + CONTAINS +! +!------------------------------------------------------------------------------! + SUBROUTINE init_fermi_dist(fdist,nel,etemp,lsd,mult,nstate) + IMPLICIT NONE + TYPE (fermi_distribution_type), INTENT (INOUT) :: fdist + INTEGER, OPTIONAL, INTENT (IN) :: nel + REAL (dbl), OPTIONAL, INTENT (IN) :: etemp + LOGICAL, OPTIONAL, INTENT (IN) :: lsd + INTEGER, OPTIONAL, INTENT (IN) :: mult + INTEGER, OPTIONAL, INTENT (IN) :: nstate + + INTEGER :: m, isos + + fdist%nel = 0 + fdist%electronic_temp = 0._dbl + fdist%spin_polarization = 0 + fdist%multiplicity = 1 + fdist%nstate = 0 + fdist%mu = 0._dbl +!..total number of electrons + IF (present(nel)) THEN + fdist%nel = nel + END IF +!..electronic temperature + IF (present(etemp)) THEN + fdist%electronic_temp = etemp + END IF + IF (fdist%electronic_temp>0._dbl) THEN + fdist%betael = joule/(boltzmann*fdist%electronic_temp) + ELSE + fdist%betael = 1.E33_dbl + END IF +!..spin polarization + IF (present(lsd)) THEN + IF (lsd) fdist%spin_polarization = 1 + END IF +!..multiplicity + IF (present(mult)) THEN + IF (lsd) fdist%multiplicity = mult + END IF +!..number of electronic states + IF (present(nstate)) THEN + fdist%nstate = nstate + ELSE + fdist%nstate = 0 + END IF +!..test the current setting and adjust defaults +!..number of electrons at least 1 + IF (fdist%nel<1) THEN + CALL stop_prg('INIT_FERMI_DIST','Number of electrons < 1') + END IF +!..if lda only singlet states + IF (fdist%spin_polarization==0 .AND. fdist%multiplicity/=1) THEN + CALL stop_prg('INIT_FERMI_DIST','LDA: multiplicity has to be 1') + END IF +!..set number of alpha and beta electrons + IF (fdist%spin_polarization==1) THEN + m = fdist%multiplicity + IF (mod(nel+m-1,2)/=0) THEN + CALL stop_prg('INIT_FERMI_DIST','NEL incons. with multiplicity') + END IF + fdist%nalpha = (nel+m-1)/2 + fdist%nbeta = nel - fdist%nalpha + ELSE + fdist%nalpha = nel + fdist%nbeta = 0 + END IF +!..set number of states + IF (fdist%nstate/=0) THEN + IF (fdist%spin_polarization==1) THEN + fdist%na = fdist%nalpha + fdist%nb = fdist%nbeta + m = fdist%nstate - (fdist%na+fdist%nb) + IF (m<0) THEN + CALL stop_prg('INIT_FERMI_DIST','Not enough states') + END IF + fdist%na = fdist%na + (m+1)/2 + fdist%nb = fdist%nb + m/2 + ELSE + fdist%na = fdist%nstate + fdist%nb = 0 + IF (fdist%nstate<(fdist%nel+1)/2) THEN + CALL stop_prg('INIT_FERMI_DIST','Not enough states') + END IF + END IF + ELSE + IF (fdist%electronic_temp==0._dbl) THEN + IF (fdist%spin_polarization==1) THEN + fdist%na = fdist%nalpha + fdist%nb = fdist%nbeta + fdist%nstate = fdist%na + fdist%nb + ELSE + fdist%nstate = (fdist%nel+1)/2 + fdist%na = fdist%nstate + fdist%nb = 0 + END IF + ELSE + CALL stop_prg('INIT_FERMI_DIST','If etemp /= 0', & + ' number of states has to be specified') + END IF + END IF + END SUBROUTINE init_fermi_dist +!------------------------------------------------------------------------------! + SUBROUTINE fermi_info(fdist,plevel,punit) + IMPLICIT NONE + TYPE (fermi_distribution_type), INTENT (IN) :: fdist + INTEGER :: plevel, punit + CHARACTER (len=10) :: mul(1:8) + + mul = ' ' + mul(1) = 'singlet' + mul(2) = 'doublet' + mul(3) = 'triplet' + mul(4) = 'quartet' + mul(5) = 'quintet' + mul(6) = 'sextet' + mul(7) = 'septet' + mul(8) = 'octet' + + IF (plevel>0) THEN + WRITE (punit,*) + WRITE (punit,'(A,T71,I10)') ' FERMI| Total number of electrons ', & + fdist%nel + IF (fdist%spin_polarization==1) THEN + WRITE (punit,'(A,T71,I10)') ' FERMI| Number of alpha electrons ', & + fdist%nalpha + WRITE (punit,'(A,T71,I10)') ' FERMI| Number of beta electrons ', & + fdist%nbeta + END IF + WRITE (punit,'(A,T71,A)') ' FERMI| Multiplicity', & + adjustr(mul(fdist%multiplicity)) + WRITE (punit,'(A,T71,F10.2)') ' FERMI| Electronic temperature [K]', & + fdist%electronic_temp + WRITE (punit,'(A,T71,I10)') & + ' FERMI| Total number of electronic states ', fdist%nstate + IF (fdist%spin_polarization==1) THEN + WRITE (punit,'(A,T71,I10)') & + ' FERMI| Number of alpha electronic states ', fdist%na + WRITE (punit,'(A,T71,I10)') & + ' FERMI| Number of beta electronic states ', fdist%nb + END IF + END IF + END SUBROUTINE fermi_info +!------------------------------------------------------------------------------! + END MODULE fermi +!------------------------------------------------------------------------------! diff --git a/src/fft_tools.F b/src/fft_tools.F index 47580523cd..c2fb0f6d54 100644 --- a/src/fft_tools.F +++ b/src/fft_tools.F @@ -3,167 +3,105 @@ ! Copyright (C) 2000 CP2K developers group ! !-----------------------------------------------------------------------------! +! +! How to add a new FFT library: +! - create a new interface library : fftXX_lib with the entries +! fft3d and fft_get_lengths, see fftw_lib for a template +! - add in this file the entries to the new library; in each +! subroutine there will be an additional CASE +! + MODULE fft_tools USE kinds, ONLY: dbl, sgl -!TMPTMPTMP USE timings, ONLY: timeset, timestop USE stop_program, ONLY : stop_prg - USE util, ONLY: sort + USE fftw_lib, ONLY : w_fft3d => fft3d, & + w_fft_get_lengths => fft_get_lengths + USE fftsg_lib, ONLY : sg_fft3d => fft3d, & + sg_fft_get_lengths => fft_get_lengths IMPLICIT NONE PRIVATE - PUBLIC :: fft_wrap, FWFFT, BWFFT + PUBLIC :: init_fft, get_fft_library, fft3d + PUBLIC :: fft_radix_operations + PUBLIC :: FWFFT, BWFFT PUBLIC :: FFT_RADIX_CLOSEST, FFT_RADIX_NEXT, FFT_RADIX_ALLOWED PUBLIC :: FFT_RADIX_DISALLOWED - PUBLIC :: fft_radix_operations INTEGER, PARAMETER :: FWFFT = +1, BWFFT = -1 INTEGER, PARAMETER :: FFT_RADIX_CLOSEST = 493, FFT_RADIX_NEXT = 494 INTEGER, PARAMETER :: FFT_RADIX_ALLOWED = 495, FFT_RADIX_DISALLOWED = 496 - INTERFACE fft_wrap - MODULE PROCEDURE fft_wrap_dbl, fft_wrap_sgl - END INTERFACE - -#if defined ( __FFTW ) -!*apsi 220500 This is actually the file fftw_f77.i ... -! This file contains PARAMETER statements for various constants -! that can be passed to FFTW routines. You should include -! this file in any FORTRAN program that calls the fftw_f77 -! routines (either directly or with an #include statement -! if you use the C preprocessor). + INTEGER :: fft_type = 0 - integer FFTW_FORWARD,FFTW_BACKWARD - parameter (FFTW_FORWARD=-1,FFTW_BACKWARD=1) - - integer FFTW_REAL_TO_COMPLEX,FFTW_COMPLEX_TO_REAL - parameter (FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1) - - integer FFTW_ESTIMATE,FFTW_MEASURE - parameter (FFTW_ESTIMATE=0,FFTW_MEASURE=1) - - integer FFTW_OUT_OF_PLACE,FFTW_IN_PLACE,FFTW_USE_WISDOM - parameter (FFTW_OUT_OF_PLACE=0) - parameter (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16) - - integer FFTW_THREADSAFE - parameter (FFTW_THREADSAFE=128) - -! Constants for the MPI wrappers: - integer FFTW_TRANSPOSED_ORDER, FFTW_NORMAL_ORDER - integer FFTW_SCRAMBLED_INPUT, FFTW_SCRAMBLED_OUTPUT - parameter(FFTW_TRANSPOSED_ORDER=1, FFTW_NORMAL_ORDER=0) - parameter(FFTW_SCRAMBLED_INPUT=8192) - parameter(FFTW_SCRAMBLED_OUTPUT=16384) -#endif +!****************************************************************************** CONTAINS !****************************************************************************** -!! Give the allowed lengths of FFT's ''' +SUBROUTINE init_fft ( fftlib, fftnum ) -SUBROUTINE fft_get_lengths ( data, max_length ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: max_length - INTEGER, DIMENSION ( : ), POINTER :: data - -! Locals - INTEGER :: iloc - INTEGER, DIMENSION ( : ), ALLOCATABLE :: idx - INTEGER :: h, i, j, k, m, number, ndata, nmax, allocstat, maxn - INTEGER :: maxn_twos, maxn_threes, maxn_fives - INTEGER :: maxn_sevens, maxn_elevens, maxn_thirteens - -!------------------------------------------------------------------------------ - -! compute ndata -!! FFTW can do arbitrary(?) lenghts, maybe you want to limit them to some -!! powers of small prime numbers though... - -#if defined ( __FFTW ) - maxn_twos = 15 - maxn_threes = 3 - maxn_fives = 2 - maxn_sevens = 1 - maxn_elevens = 1 - maxn_thirteens = 0 - maxn = MIN ( max_length, 37748736 ) - -#elif defined ( __AIX ) - maxn_twos = 15 - maxn_threes = 2 - maxn_fives = 1 - maxn_sevens = 1 - maxn_elevens = 1 - maxn_thirteens = 0 - maxn = MIN ( max_length, 37748736 ) - -#else - CALL stop_prg ( "fft_get_lengths", "no fft basis defined" ) -#endif - - ndata = 0 - DO h = 0, maxn_twos - nmax = HUGE(0) / 2**h - DO i = 0, maxn_threes - DO j = 0, maxn_fives - DO k = 0, maxn_sevens - DO m = 0, maxn_elevens - number = (3**i) * (5**j) * (7**k) * (11**m) - - IF ( number > nmax ) CYCLE - - number = number * 2 ** h - IF ( number >= maxn ) CYCLE - - ndata = ndata + 1 - END DO - END DO - END DO - END DO - END DO - - ALLOCATE ( data ( ndata ), idx ( ndata ), STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_prg ( "fft_get_lengths", "error allocating data, idx" ) + CHARACTER ( LEN = * ), INTENT ( IN ), OPTIONAL :: fftlib + INTEGER, INTENT ( IN ), OPTIONAL :: fftnum + + INTEGER :: n(3) = 4 + COMPLEX ( dbl ) :: zz ( 4, 4, 4 ) + INTEGER :: stat, i + + IF ( PRESENT ( fftlib ) ) THEN + SELECT CASE ( fftlib ) + CASE DEFAULT + CALL stop_prg ("init_fft","Unknown FFT library") + CASE ( "FFTSG" ) + fft_type = 1 + CASE ( "FFTW" ) + fft_type = 2 + END SELECT + ELSE IF ( PRESENT ( fftnum ) ) THEN + fft_type = fftnum + zz = 0.1_dbl + CALL fft3d ( 1, n, zz, status=stat ) + IF ( stat /= 0 ) call stop_prg ("init_fft","FFT library not available") + ELSE + zz = 0.1_dbl + DO i = 1, 100 + fft_type = i + CALL fft3d ( 1, n, zz, status=stat ) + IF ( stat == 0 ) EXIT + fft_type = 0 + END DO + IF (fft_type == 0 ) call stop_prg ("init_fft","No FFT library available") END IF - - ndata = 0 - data ( : ) = 0 - DO h = 0, maxn_twos - nmax = HUGE(0) / 2**h - DO i = 0, maxn_threes - DO j = 0, maxn_fives - DO k = 0, maxn_sevens - DO m = 0, maxn_elevens - number = (3**i) * (5**j) * (7**k) * (11**m) - - IF ( number > nmax ) CYCLE - - number = number * 2 ** h - IF ( number >= maxn ) CYCLE - - ndata = ndata + 1 - data ( ndata ) = number - END DO - END DO - END DO - END DO - END DO - - CALL sort ( data, ndata, idx ) - - DEALLOCATE ( idx, STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_prg ( "fft_get_lengths", "error deallocating idx" ) + + IF ( PRESENT ( fftnum ) ) THEN + IF ( fft_type /= fftnum ) call stop_prg ("init_fft",& + " Inconsistent Arguments ") END IF - -END SUBROUTINE fft_get_lengths + +END SUBROUTINE init_fft + +!****************************************************************************** + +SUBROUTINE get_fft_library ( fft_handle, library ) + + INTEGER, INTENT ( OUT ) :: fft_handle + CHARACTER ( LEN = * ), INTENT ( OUT ) :: library + + SELECT CASE ( fft_type ) + CASE DEFAULT + library = " No FFT library initialized " + fft_handle = 0 + CASE ( 1 ) + library = " FFTsg library initialized " + fft_handle = 1 + CASE ( 2 ) + library = " FFTw library initialized " + fft_handle = 2 + END SELECT + +END SUBROUTINE get_fft_library !****************************************************************************** @@ -182,7 +120,14 @@ SUBROUTINE fft_radix_operations ( radix_in, radix_out, operation ) !------------------------------------------------------------------------------ - CALL fft_get_lengths ( data, max_length = 1024 ) + SELECT CASE ( fft_type ) + CASE ( 1 ) + CALL sg_fft_get_lengths ( data, max_length = 1024 ) + CASE ( 2 ) + CALL w_fft_get_lengths ( data, max_length = 1024 ) + CASE DEFAULT + CALL stop_prg ("fft3d","Unknown FFT library") + END SELECT iloc = 0 DO i = 1, SIZE ( data ) @@ -233,757 +178,58 @@ END SUBROUTINE fft_radix_operations !****************************************************************************** -#if defined ( __FFTSG ) +SUBROUTINE fft3d ( fsign, n, zg, zg_out, scale, status ) -SUBROUTINE fft_wrap_sgl ( fsign, n, zg, zgout, scale ) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX(sgl), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX(sgl), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL(sgl), OPTIONAL, INTENT ( IN ):: scale -! locals - stop "SG sFFT not implemented" - -END SUBROUTINE fft_wrap_sgl - -!****************************************************************************** - -SUBROUTINE fft_wrap_dbl ( fsign, n, zg, zgout, scale ) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL ( dbl ), OPTIONAL, INTENT ( IN ):: scale -! locals - INTEGER :: ldx, ldy, ldz, nx, ny, nz, isign, norm - COMPLEX ( dbl ), DIMENSION(SIZE(zg)) :: xf, yf - - ldx = n(1) - ldy = n(2) - ldz = n(3) - nx = n(1) - ny = n(1) - nz = n(1) - norm = 1._dbl - -! CALL mltfft( 'N','T',zg,ldx,ldy*ldz,xf,ldy*ldz,ldx,nx, & -! ldy*ldz,isign,1.d0) -! CALL mltfft( 'N','T',xf,ldy,ldx*ldz,yf,ldx*ldz,ldy,ny, & -! ldx*ldz,isign,1.d0) -! IF ( PRESENT ( zgout ) ) THEN -! CALL mltfft( 'N','T',yf,ldz,ldy*ldx,zgout,ldy*ldx,ldz,nz, & -! ldy*ldx,isign,scale) -! ELSE -! CALL mltfft( 'N','T',yf,ldz,ldy*ldx,zg,ldy*ldx,ldz,nz, & -! ldy*ldx,isign,scale) -! END IF - -END SUBROUTINE fft_wrap_dbl - -!****************************************************************************** - -#elif defined ( __FFTW ) && defined ( __AIX ) && defined ( __SPRECFFT ) - -!*** Single precision from FFTW ... - -SUBROUTINE fft_wrap_sgl ( fsign, n, zg, zgout, scale ) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX(sgl), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX(sgl), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL(sgl), OPTIONAL, INTENT ( IN ):: scale -! locals - INTEGER, SAVE :: n1a_save = -1, n2a_save = -1, n3a_save = -1 - INTEGER, SAVE :: n1b_save = -1, n2b_save = -1, n3b_save = -1 - LOGICAL, SAVE :: ffta_in_place = .true., fftb_in_place = .true. - LOGICAL :: fft_in_place - INTEGER :: sign_fft, n1, n2, n3 - INTEGER ( KIND = 4 ), SAVE :: plan_a_fw, plan_a_bw - INTEGER ( KIND = 4 ), SAVE :: plan_b_fw, plan_b_bw - REAL(sgl) :: norm - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF - - n1 = n(1) - n2 = n(2) - n3 = n(3) - - IF ( PRESENT ( zgout ) ) THEN - fft_in_place = .false. - ELSE - fft_in_place = .true. - END IF - - sign_fft = fsign - - IF ( n1a_save == n1 .AND. n2a_save == n2 .AND. n3a_save == n3 & - .AND. ( fft_in_place .eqv. ffta_in_place ) ) THEN - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_a_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_a_bw, zg, zgout ) - END IF - ELSE IF ( n1b_save == n1 .AND. n2b_save == n2 .AND. n3b_save == n3 & - .AND. ( fft_in_place .eqv. fftb_in_place ) ) THEN - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_b_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_b_bw, zg, zgout ) - END IF - ELSE IF ( n1a_save == -1 .OR. & - ( n1a_save == n1 .AND. n2a_save == n2 .AND. n3a_save == n3 & - .AND. ( fft_in_place .neqv. ffta_in_place ) .AND. & - n1b_save /= -1 ) ) THEN ! Initialise 'a' - write(6,*) "Init a" - IF ( fft_in_place ) THEN - CALL fftw3d_f77_create_plan ( plan_a_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - CALL fftw3d_f77_create_plan ( plan_a_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - ELSE - CALL fftw3d_f77_create_plan ( plan_a_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - CALL fftw3d_f77_create_plan ( plan_a_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - END IF - n1a_save = n1 - n2a_save = n2 - n3a_save = n3 - ffta_in_place = fft_in_place - - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_a_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_a_bw, zg, zgout ) - END IF - ELSE ! Initialise 'b' - write(6,*) "Init b" - IF ( fft_in_place ) THEN - CALL fftw3d_f77_create_plan ( plan_b_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - CALL fftw3d_f77_create_plan ( plan_b_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - ELSE - CALL fftw3d_f77_create_plan ( plan_b_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - CALL fftw3d_f77_create_plan ( plan_b_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - END IF - n1b_save = n1 - n2b_save = n2 - n3b_save = n3 - fftb_in_place = fft_in_place - - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_b_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_b_bw, zg, zgout ) - END IF - END IF - - IF ( norm /= 1._dbl ) THEN - IF ( fft_in_place ) THEN - zg = zg * norm - ELSE - zgout = zgout * norm - END IF - END IF - -END SUBROUTINE fft_wrap_sgl - -!*** ... and double precision from ESSL - -SUBROUTINE fft_wrap_dbl(fsign,n,zg,zgout,scale) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL ( dbl ), OPTIONAL, INTENT ( IN ):: scale -! locals -! REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE:: aux - REAL ( dbl ):: norm - INTEGER:: la1,la2,la3,sign_fft,na1,na2,naux,isos - INTEGER :: n1,n2,n3 - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF -! IBM FFT CALL - n1 = n(1) - n2 = n(2) - n3 = n(3) - la1 = n1 - la2 = n1*n2 - IF( MAX(n2,n3)<252 ) THEN - IF( n1<=2048 ) THEN - naux=60000 - ELSE - naux=60000+4.56*n1 - END IF - ELSE - IF( n1<=2048 ) THEN - na1=60000+(2*n2+256)*(MIN(64,n1)+4.56) - na2=60000+(2*n3+256)*(MIN(64,n1*n2)+4.56) - ELSE - na1=60000+4.56*n1+(2*n2+256)*(MIN(64,n1)+4.56) - naux=60000+4.56*n1+(2*n3+256)*(MIN(64,n1*n2)+4.56) - END IF - IF( n2>=252 .AND. n3<252 ) THEN - naux=na1 - ELSE IF( n2<252 .AND. n3>=252 ) THEN - naux=na2 - ELSE - naux=MAX(na1,na2) - END IF - END IF - -! ALLOCATE(aux(naux),STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate aux') - -! sign_fft = fsign -! CALL dcft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - IF ( PRESENT ( zgout ) ) THEN - CALL do_ibm_fft_ab ( naux ) - ELSE - CALL do_ibm_fft_aa ( naux ) - END IF - -! DEALLOCATE(aux,STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to deallocate aux') - -CONTAINS - - SUBROUTINE do_ibm_fft_ab ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL dcft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_ab - - SUBROUTINE do_ibm_fft_aa ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL dcft3(zg,la1,la2,zg,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_aa - -END SUBROUTINE fft_wrap_dbl - -!****************************************************************************** - -#elif defined ( __FFTW ) && ! defined ( __SPRECFFT ) - -SUBROUTINE fft_wrap_sgl ( fsign, n, zg, zgout, scale ) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX(sgl), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX(sgl), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL(sgl), OPTIONAL, INTENT ( IN ):: scale - - stop "fftw cannot be used in both single and double precision..." -END SUBROUTINE fft_wrap_sgl - -!****************************************************************************** - -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - -SUBROUTINE fft_wrap_dbl ( fsign, n, zg, zg_out, scale ) - - IMPLICIT NONE - ! Arguments INTEGER, INTENT ( IN ) :: fsign INTEGER, DIMENSION ( : ), INTENT ( IN ) :: n COMPLEX ( dbl ), DIMENSION(:,:,:), INTENT ( INOUT ) :: zg - COMPLEX ( dbl ), DIMENSION(:,:,:), INTENT ( INOUT ), OPTIONAL, TARGET :: zg_out + COMPLEX ( dbl ), DIMENSION(:,:,:), INTENT ( INOUT ), OPTIONAL :: zg_out REAL ( dbl ), INTENT ( IN ), OPTIONAL :: scale - -! Locals - INTEGER, SAVE :: n1a_save = -1, n2a_save = -1, n3a_save = -1 - INTEGER, SAVE :: n1b_save = -1, n2b_save = -1, n3b_save = -1 - INTEGER, SAVE :: n1c_save = -1, n2c_save = -1, n3c_save = -1 - LOGICAL, SAVE :: ffta_in_place = .TRUE., fftb_in_place = .TRUE. - LOGICAL, SAVE :: fftc_in_place = .TRUE. - LOGICAL :: fft_in_place - INTEGER :: sign_fft, n1, n2, n3 - INTEGER ( KIND = 8 ), SAVE :: plan_a_fw, plan_a_bw - INTEGER ( KIND = 8 ), SAVE :: plan_b_fw, plan_b_bw - INTEGER ( KIND = 8 ), SAVE :: plan_c_fw, plan_c_bw + INTEGER, INTENT ( OUT ), OPTIONAL :: status + REAL ( dbl ) :: norm - - ! Just due to DEC... apsi - COMPLEX ( dbl ), DIMENSION(:,:,:), POINTER :: zgout - COMPLEX ( dbl ), DIMENSION(1,1,1), TARGET :: zgout_tmp - -!------------------------------------------------------------------------------ - + INTEGER :: sign + IF ( PRESENT ( scale ) ) THEN - norm = scale + norm = scale ELSE - norm = 1._dbl - END IF - - n1 = n(1) - n2 = n(2) - n3 = n(3) - - IF ( PRESENT ( zg_out ) ) THEN - fft_in_place = .false. - zgout => zg_out - ELSE - fft_in_place = .true. - zgout => zgout_tmp - END IF - - sign_fft = fsign - - IF ( n1a_save == n1 .AND. n2a_save == n2 .AND. n3a_save == n3 & - .AND. ( fft_in_place .eqv. ffta_in_place ) ) THEN - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_a_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_a_bw, zg, zgout ) - END IF - ELSE IF ( n1b_save == n1 .AND. n2b_save == n2 .AND. n3b_save == n3 & - .AND. ( fft_in_place .eqv. fftb_in_place ) ) THEN - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_b_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_b_bw, zg, zgout ) - END IF - ELSE IF ( n1c_save == n1 .AND. n2c_save == n2 .AND. n3c_save == n3 & - .AND. ( fft_in_place .eqv. fftc_in_place ) ) THEN - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_c_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_c_bw, zg, zgout ) - END IF - ELSE IF ( n1a_save == -1 .OR. & - ( n1a_save == n1 .AND. n2a_save == n2 .AND. n3a_save == n3 & - .AND. ( fft_in_place .neqv. ffta_in_place ) .AND. & - ( n1b_save /= -1 .AND. n1c_save /= -1 ) ) ) THEN ! Initialise 'a' - write(6,*) "Init a" - IF ( fft_in_place ) THEN - CALL fftw3d_f77_create_plan ( plan_a_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - CALL fftw3d_f77_create_plan ( plan_a_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - ELSE - CALL fftw3d_f77_create_plan ( plan_a_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - CALL fftw3d_f77_create_plan ( plan_a_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - END IF - n1a_save = n1 - n2a_save = n2 - n3a_save = n3 - ffta_in_place = fft_in_place - - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_a_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_a_bw, zg, zgout ) - END IF - - ELSE IF ( n1b_save == -1 .OR. & - ( n1b_save == n1 .AND. n2b_save == n2 .AND. n3b_save == n3 & - .AND. ( fft_in_place .neqv. fftb_in_place ) .AND. & - n1c_save /= -1 ) ) THEN ! Initialise 'a' - write(6,*) "Init b" - IF ( fft_in_place ) THEN - CALL fftw3d_f77_create_plan ( plan_b_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - CALL fftw3d_f77_create_plan ( plan_b_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - ELSE - CALL fftw3d_f77_create_plan ( plan_b_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - CALL fftw3d_f77_create_plan ( plan_b_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - END IF - n1b_save = n1 - n2b_save = n2 - n3b_save = n3 - fftb_in_place = fft_in_place - - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_b_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_b_bw, zg, zgout ) - END IF - - ELSE ! Initialise 'c' - write(6,*) "Init c" - IF ( fft_in_place ) THEN - CALL fftw3d_f77_create_plan ( plan_c_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - CALL fftw3d_f77_create_plan ( plan_c_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - ELSE - CALL fftw3d_f77_create_plan ( plan_c_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - CALL fftw3d_f77_create_plan ( plan_c_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - END IF - n1c_save = n1 - n2c_save = n2 - n3c_save = n3 - fftc_in_place = fft_in_place - - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_c_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_c_bw, zg, zgout ) - END IF + norm = 1._dbl END IF - IF ( norm /= 1._dbl ) THEN - IF ( fft_in_place ) THEN - zg = zg * norm - ELSE - zgout = zgout * norm - END IF + sign = fsign + + SELECT CASE ( fft_type ) + CASE ( 1 ) + IF ( PRESENT ( zg_out ) ) THEN + CALL sg_fft3d ( sign, norm, n, zg, zg_out ) + ELSE + CALL sg_fft3d ( sign, norm, n, zg ) + END IF + CASE ( 2 ) + IF ( PRESENT ( zg_out ) ) THEN + CALL w_fft3d ( sign, norm, n, zg, zg_out ) + ELSE + CALL w_fft3d ( sign, norm, n, zg ) + END IF + CASE DEFAULT + CALL stop_prg ("fft3d","Unknown FFT library") + END SELECT + + IF ( PRESENT ( status ) ) THEN + IF ( sign == 0 ) THEN + status = 1 + ELSE + status = 0 + END IF END IF -END SUBROUTINE fft_wrap_dbl +END SUBROUTINE fft3d !****************************************************************************** -#elif defined ( __AIX ) - -SUBROUTINE fft_wrap_dbl(fsign,n,zg,zgout,scale) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL ( dbl ), OPTIONAL, INTENT ( IN ):: scale -! locals -! REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE:: aux - REAL ( dbl ):: norm - INTEGER:: la1,la2,la3,sign_fft,na1,na2,naux,isos - INTEGER :: n1,n2,n3 - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF -! IBM FFT CALL - n1 = n(1) - n2 = n(2) - n3 = n(3) - la1 = n1 - la2 = n1*n2 - IF( MAX(n2,n3)<252 ) THEN - IF( n1<=2048 ) THEN - naux=60000 - ELSE - naux=60000+4.56*n1 - END IF - ELSE - IF( n1<=2048 ) THEN - na1=60000+(2*n2+256)*(MIN(64,n1)+4.56) - na2=60000+(2*n3+256)*(MIN(64,n1*n2)+4.56) - ELSE - na1=60000+4.56*n1+(2*n2+256)*(MIN(64,n1)+4.56) - naux=60000+4.56*n1+(2*n3+256)*(MIN(64,n1*n2)+4.56) - END IF - IF( n2>=252 .AND. n3<252 ) THEN - naux=na1 - ELSE IF( n2<252 .AND. n3>=252 ) THEN - naux=na2 - ELSE - naux=MAX(na1,na2) - END IF - END IF - -! ALLOCATE(aux(naux),STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate aux') - -! sign_fft = fsign -! CALL dcft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - IF ( PRESENT ( zgout ) ) THEN - CALL do_ibm_fft_ab ( naux ) - ELSE - CALL do_ibm_fft_aa ( naux ) - END IF - -! DEALLOCATE(aux,STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to deallocate aux') - -CONTAINS - - SUBROUTINE do_ibm_fft_ab ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL dcft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_ab - - SUBROUTINE do_ibm_fft_aa ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL dcft3(zg,la1,la2,zg,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_aa - -END SUBROUTINE fft_wrap_dbl - -!****************************************************************************** - -SUBROUTINE fft_wrap_sgl(fsign,n,zg,zgout,scale) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX(sgl), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX(sgl), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL(sgl), OPTIONAL, INTENT ( IN ):: scale -! locals -! REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE:: aux - REAL(sgl):: norm - INTEGER:: la1,la2,la3,sign_fft,na1,na2,naux,isos - INTEGER :: n1,n2,n3 - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF -! IBM FFT CALL - n1 = n(1) - n2 = n(2) - n3 = n(3) - la1 = n1 - la2 = n1*n2 - IF( MAX(n2,n3)<252 ) THEN - IF( n1<=2048 ) THEN - naux=60000 - ELSE - naux=60000+4.56*n1 - END IF - ELSE - IF( n1<=2048 ) THEN - na1=60000+(2*n2+256)*(MIN(64,n1)+4.56) - na2=60000+(2*n3+256)*(MIN(64,n1*n2)+4.56) - ELSE - na1=60000+4.56*n1+(2*n2+256)*(MIN(64,n1)+4.56) - naux=60000+4.56*n1+(2*n3+256)*(MIN(64,n1*n2)+4.56) - END IF - IF( n2>=252 .AND. n3<252 ) THEN - naux=na1 - ELSE IF( n2<252 .AND. n3>=252 ) THEN - naux=na2 - ELSE - naux=MAX(na1,na2) - END IF - END IF - -! ALLOCATE(aux(naux),STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate aux') - -! sign_fft = fsign -! CALL dcft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - IF ( PRESENT ( zgout ) ) THEN - CALL do_ibm_fft_ab ( naux ) - ELSE - CALL do_ibm_fft_aa ( naux ) - END IF - -! DEALLOCATE(aux,STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to deallocate aux') - -CONTAINS - - SUBROUTINE do_ibm_fft_ab ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL scft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_ab - - SUBROUTINE do_ibm_fft_aa ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL scft3(zg,la1,la2,zg,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_aa - -END SUBROUTINE fft_wrap_sgl - -!****************************************************************************** - -#elif defined ( __T3E ) - -SUBROUTINE fft_wrap_ab ( fsign, n, zg, zgout, scale ) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( IN ):: zg - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zgout - REAL ( dbl ), OPTIONAL, INTENT ( IN ):: scale -! locals - INTEGER, SAVE :: n1save = -1, n2save = -1, n3save = -1 - INTEGER:: la1,la2,la3,sign_fft,na1,na2,isos, isys ( 4 ) - INTEGER :: n1,n2,n3 - REAL ( dbl ):: norm - REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE :: work - REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE, SAVE :: table - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF - - n1 = n(1) - n2 = n(2) - n3 = n(3) - la1 = n1 - la2 = n2 - isys ( 1 ) = 3 - isys ( 2 ) = 0 - isys ( 3 ) = 0 - isys ( 4 ) = 0 - - ALLOCATE ( work ( 2 * n1 * n2 * n3 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate work') - sign_fft = fsign - - IF ( n1save /= n1 .OR. n2save /= n2 .OR. n3save /= n3 ) THEN - IF ( ALLOCATED ( table ) ) DEALLOCATE ( table ) - ALLOCATE ( table ( 2 * ( n1 + n2 + n3 ) ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate table') - CALL ccfft3d ( 0, n1, n2, n3, norm, zg, la1, la2, & - zgout, la1, la2, table, work, isys ) - n1save = n1 - n2save = n2 - n3save = n3 - END IF - - CALL ccfft3d ( sign_fft, n1, n2, n3, norm, zg, la1, la2, & - zgout, la1, la2, table, work, isys ) - - DEALLOCATE ( work, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to deallocate work') - -END SUBROUTINE fft_wrap_ab - -!****************************************************************************** - -SUBROUTINE fft_wrap_aa ( fsign, n, zg, scale ) - -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - REAL ( dbl ), OPTIONAL, INTENT ( IN ):: scale -! locals - INTEGER, SAVE :: n1save = -1, n2save = -1, n3save = -1 - INTEGER:: la1,la2,la3,sign_fft,na1,na2,isos, isys ( 4 ) - INTEGER :: n1,n2,n3 - REAL ( dbl ):: norm - REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE :: work - REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE, SAVE :: table - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF - - n1 = n(1) - n2 = n(2) - n3 = n(3) - la1 = n1 - la2 = n2 - isys ( 1 ) = 3 - isys ( 2 ) = 0 - isys ( 3 ) = 0 - isys ( 4 ) = 0 - - ALLOCATE ( work ( 2 * n1 * n2 * n3 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate work') - sign_fft = fsign - - IF ( n1save /= n1 .OR. n2save /= n2 .OR. n3save /= n3 ) THEN - IF ( ALLOCATED ( table ) ) DEALLOCATE ( table ) - ALLOCATE ( table ( 2 * ( n1 + n2 + n3 ) ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate table') - CALL ccfft3d ( 0, n1, n2, n3, norm, zg, la1, la2, & - zg, la1, la2, table, work, isys ) - n1save = n1 - n2save = n2 - n3save = n3 - END IF - - CALL ccfft3d ( sign_fft, n1, n2, n3, norm, zg, la1, la2, & - zg, la1, la2, table, work, isys ) - - DEALLOCATE ( work, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to deallocate work') - -END SUBROUTINE fft_wrap_aa - -#endif - END MODULE fft_tools + +!****************************************************************************** diff --git a/src/fftsg_lib.F b/src/fftsg_lib.F new file mode 100644 index 0000000000..9d3f44bd6a --- /dev/null +++ b/src/fftsg_lib.F @@ -0,0 +1,155 @@ +!-----------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!-----------------------------------------------------------------------------! + +MODULE fftsg_lib + + USE kinds, ONLY: dbl + USE stop_program, ONLY : stop_memory, stop_prg + + IMPLICIT NONE + + PRIVATE + PUBLIC :: fft3d + PUBLIC :: fft_get_lengths + +!****************************************************************************** + +CONTAINS + +!****************************************************************************** + +!! Give the allowed lengths of FFT's ''' + +SUBROUTINE fft_get_lengths ( data, max_length ) + + IMPLICIT NONE + +! Arguments + INTEGER, INTENT ( IN ) :: max_length + INTEGER, DIMENSION ( : ), POINTER :: data + +! Locals + INTEGER, PARAMETER :: rlen = 82 + INTEGER, DIMENSION ( rlen ), PARAMETER :: radix = & + (/ 2, 4, 5, 6, 8, 9, 12, 15, 16, 18, 20, 24, 25, 27, 30, 32, 36, 40, & + 45, 48, 54, 60, 64, 72, 75, 80, 81, 90, 96, 100, 108, 120, 125, 128, & + 135, 144, 150, 160, 162, 180, 192, 200, 216, 225, 240, 243, 256, 270, & + 288, 300, 320, 324, 360, 375, 384, 400, 405, 432, 450, 480, 486, 500, & + 512, 540, 576, 600, 625, 640, 648, 675, 720, 729, 750, 768, 800, 810, & + 864, 900, 960, 972, 1000, 1024 /) + INTEGER :: i, allocstat, ndata + +!------------------------------------------------------------------------------ + + ndata = 0 + DO i = 1, rlen + IF ( radix ( i ) > max_length ) EXIT + ndata = ndata + 1 + END DO + + ALLOCATE ( data ( ndata ), STAT = allocstat ) + IF ( allocstat /= 0 ) THEN + CALL stop_memory ( "fft_get_lengths", "data", ndata ) + END IF + + data ( 1:ndata ) = radix ( 1:ndata ) + +END SUBROUTINE fft_get_lengths + +!****************************************************************************** + +! routine with wrapper for all fft calls: +! Does transform with exp(+ig.r*sign): + +SUBROUTINE fft3d ( fsign, scale, n, zg, zg_out ) + + IMPLICIT NONE + +! Arguments + INTEGER, INTENT ( INOUT ) :: fsign + REAL ( dbl ), INTENT ( IN ), OPTIONAL :: scale + INTEGER, DIMENSION ( : ), INTENT ( IN ) :: n + COMPLEX ( dbl ), DIMENSION(:,:,:), INTENT ( INOUT ) :: zg + COMPLEX ( dbl ), DIMENSION(:,:,:), INTENT ( INOUT ), OPTIONAL :: zg_out + +! Locals + INTEGER :: sign_fft, ldx, ldy, ldz, ldox, ldoy, ldoz, ierr + INTEGER :: nx, ny, nz + COMPLEX ( dbl ), DIMENSION(:), ALLOCATABLE :: xf, yf + LOGICAL :: fft_in_place + +!------------------------------------------------------------------------------ + + IF ( PRESENT ( zg_out ) ) THEN + fft_in_place = .false. + ELSE + fft_in_place = .true. + END IF + + sign_fft = fsign + + nx = n ( 1 ) + ny = n ( 2 ) + nz = n ( 3 ) + + ldx = SIZE ( zg (:,1,1) ) + ldy = SIZE ( zg (1,:,1) ) + ldz = SIZE ( zg (1,1,:) ) + +#if defined ( __FFTSG ) + + IF ( fft_in_place ) THEN + + ALLOCATE ( xf ( ldx*ldy*ldz ), STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "fft3d", "xf", ldx*ldy*ldz ) + ALLOCATE ( yf ( ldx*ldy*ldz ), STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "fft3d", "yf", ldx*ldy*ldz ) + + CALL mltfftsg ( 'N', 'T', zg, ldx, ldy*ldz, xf, ldy*ldz, ldx, nx, & + ldy*ldz, sign_fft, 1._dbl ) + CALL mltfftsg ( 'N', 'T', xf, ldy, ldx*ldz, yf, ldx*ldz, ldy, ny, & + ldx*ldz, sign_fft, 1._dbl ) + CALL mltfftsg ( 'N', 'T', yf, ldz, ldy*ldx, zg, ldy*ldx, ldz, nz, & + ldy*ldx, sign_fft, scale) + + DEALLOCATE ( xf, STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "fft3d", "xf" ) + DEALLOCATE ( yf, STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "fft3d", "yf" ) + + ELSE + + ldox = SIZE ( zg_out (:,1,1) ) + ldoy = SIZE ( zg_out (1,:,1) ) + ldoz = SIZE ( zg_out (1,1,:) ) + + ALLOCATE ( xf ( ldx*ldy*ldz ), STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "fft3d", "xf", ldx*ldy*ldz ) + + CALL mltfftsg ( 'N', 'T', zg, ldx, ldy*ldz, zg_out, ldy*ldz, ldx, nx, & + ldy*ldz, sign_fft, 1._dbl ) + CALL mltfftsg ( 'N', 'T', zg_out, ldy, ldx*ldz, xf, ldx*ldz, ldy, ny, & + ldx*ldz, sign_fft, 1._dbl ) + CALL mltfftsg ( 'N', 'T', xf, ldz, ldy*ldx, zg_out, ldy*ldx, ldz, nz, & + ldy*ldx, sign_fft, scale) + + DEALLOCATE ( xf, STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "fft3d", "xf" ) + + END IF + +#else + + fsign = 0 + +#endif + +END SUBROUTINE fft3d + +!****************************************************************************** + +END MODULE fftsg_lib + +!****************************************************************************** diff --git a/src/fftw_lib.F b/src/fftw_lib.F new file mode 100644 index 0000000000..36135cd450 --- /dev/null +++ b/src/fftw_lib.F @@ -0,0 +1,313 @@ +!-----------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!-----------------------------------------------------------------------------! + +MODULE fftw_lib + + USE kinds, ONLY: dbl + USE stop_program, ONLY : stop_memory, stop_prg + USE util, ONLY: sort + + IMPLICIT NONE + + PRIVATE + PUBLIC :: fft3d + PUBLIC :: fft_get_lengths + +!*apsi 220500 This is actually the file fftw_f77.i ... +! This file contains PARAMETER statements for various constants +! that can be passed to FFTW routines. You should include +! this file in any FORTRAN program that calls the fftw_f77 +! routines (either directly or with an #include statement +! if you use the C preprocessor). + + integer FFTW_FORWARD,FFTW_BACKWARD + parameter (FFTW_FORWARD=-1,FFTW_BACKWARD=1) + + integer FFTW_REAL_TO_COMPLEX,FFTW_COMPLEX_TO_REAL + parameter (FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1) + + integer FFTW_ESTIMATE,FFTW_MEASURE + parameter (FFTW_ESTIMATE=0,FFTW_MEASURE=1) + + integer FFTW_OUT_OF_PLACE,FFTW_IN_PLACE,FFTW_USE_WISDOM + parameter (FFTW_OUT_OF_PLACE=0) + parameter (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16) + + integer FFTW_THREADSAFE + parameter (FFTW_THREADSAFE=128) + +! Constants for the MPI wrappers: + integer FFTW_TRANSPOSED_ORDER, FFTW_NORMAL_ORDER + integer FFTW_SCRAMBLED_INPUT, FFTW_SCRAMBLED_OUTPUT + parameter(FFTW_TRANSPOSED_ORDER=1, FFTW_NORMAL_ORDER=0) + parameter(FFTW_SCRAMBLED_INPUT=8192) + parameter(FFTW_SCRAMBLED_OUTPUT=16384) + +!****************************************************************************** + +CONTAINS + +!****************************************************************************** + +!! Give the allowed lengths of FFT's ''' + +SUBROUTINE fft_get_lengths ( data, max_length ) + + IMPLICIT NONE + +! Arguments + INTEGER, INTENT ( IN ) :: max_length + INTEGER, DIMENSION ( : ), POINTER :: data + +! Locals + INTEGER :: iloc + INTEGER, DIMENSION ( : ), ALLOCATABLE :: idx + INTEGER :: h, i, j, k, m, number, ndata, nmax, allocstat, maxn + INTEGER :: maxn_twos, maxn_threes, maxn_fives + INTEGER :: maxn_sevens, maxn_elevens, maxn_thirteens + +!------------------------------------------------------------------------------ + +! compute ndata +!! FFTW can do arbitrary(?) lenghts, maybe you want to limit them to some +!! powers of small prime numbers though... + + maxn_twos = 15 + maxn_threes = 3 + maxn_fives = 2 + maxn_sevens = 1 + maxn_elevens = 1 + maxn_thirteens = 0 + maxn = MIN ( max_length, 37748736 ) + + ndata = 0 + DO h = 0, maxn_twos + nmax = HUGE(0) / 2**h + DO i = 0, maxn_threes + DO j = 0, maxn_fives + DO k = 0, maxn_sevens + DO m = 0, maxn_elevens + number = (3**i) * (5**j) * (7**k) * (11**m) + + IF ( number > nmax ) CYCLE + + number = number * 2 ** h + IF ( number >= maxn ) CYCLE + + ndata = ndata + 1 + END DO + END DO + END DO + END DO + END DO + + ALLOCATE ( data ( ndata ), idx ( ndata ), STAT = allocstat ) + IF ( allocstat /= 0 ) THEN + CALL stop_memory ( "fft_get_lengths", "data, idx", 2*ndata ) + END IF + + ndata = 0 + data ( : ) = 0 + DO h = 0, maxn_twos + nmax = HUGE(0) / 2**h + DO i = 0, maxn_threes + DO j = 0, maxn_fives + DO k = 0, maxn_sevens + DO m = 0, maxn_elevens + number = (3**i) * (5**j) * (7**k) * (11**m) + + IF ( number > nmax ) CYCLE + + number = number * 2 ** h + IF ( number >= maxn ) CYCLE + + ndata = ndata + 1 + data ( ndata ) = number + END DO + END DO + END DO + END DO + END DO + + CALL sort ( data, ndata, idx ) + + DEALLOCATE ( idx, STAT = allocstat ) + IF ( allocstat /= 0 ) THEN + CALL stop_memory ( "fft_get_lengths", "idx" ) + END IF + +END SUBROUTINE fft_get_lengths + +!****************************************************************************** + +! routine with wrapper for all fft calls: +! Does transform with exp(+ig.r*sign): + +SUBROUTINE fft3d ( fsign, scale, n, zg, zg_out ) + + IMPLICIT NONE + +! Arguments + INTEGER, INTENT ( INOUT ) :: fsign + REAL ( dbl ), INTENT ( IN ) :: scale + INTEGER, DIMENSION ( : ), INTENT ( IN ) :: n + COMPLEX ( dbl ), DIMENSION(:,:,:), INTENT ( INOUT ) :: zg + COMPLEX ( dbl ), DIMENSION(:,:,:), INTENT ( INOUT ), OPTIONAL, TARGET :: zg_out + +! Locals + INTEGER, SAVE :: n1a_save = -1, n2a_save = -1, n3a_save = -1 + INTEGER, SAVE :: n1b_save = -1, n2b_save = -1, n3b_save = -1 + INTEGER, SAVE :: n1c_save = -1, n2c_save = -1, n3c_save = -1 + LOGICAL, SAVE :: ffta_in_place = .TRUE., fftb_in_place = .TRUE. + LOGICAL, SAVE :: fftc_in_place = .TRUE. + LOGICAL :: fft_in_place + INTEGER :: sign_fft, n1, n2, n3 + INTEGER ( KIND = 8 ), SAVE :: plan_a_fw, plan_a_bw + INTEGER ( KIND = 8 ), SAVE :: plan_b_fw, plan_b_bw + INTEGER ( KIND = 8 ), SAVE :: plan_c_fw, plan_c_bw + REAL ( dbl ) :: norm + + ! Just due to DEC... apsi + COMPLEX ( dbl ), DIMENSION(:,:,:), POINTER :: zgout + COMPLEX ( dbl ), DIMENSION(1,1,1), TARGET :: zgout_tmp + +!------------------------------------------------------------------------------ + + norm = scale + + n1 = n(1) + n2 = n(2) + n3 = n(3) + + IF ( PRESENT ( zg_out ) ) THEN + fft_in_place = .false. + zgout => zg_out + ELSE + fft_in_place = .true. + zgout => zgout_tmp + END IF + + sign_fft = fsign + +#if defined ( __FFTW ) + + IF ( n1a_save == n1 .AND. n2a_save == n2 .AND. n3a_save == n3 & + .AND. ( fft_in_place .eqv. ffta_in_place ) ) THEN + IF ( sign_fft == +1 ) THEN + CALL fftwnd_f77_one ( plan_a_fw, zg, zgout ) + ELSE + CALL fftwnd_f77_one ( plan_a_bw, zg, zgout ) + END IF + ELSE IF ( n1b_save == n1 .AND. n2b_save == n2 .AND. n3b_save == n3 & + .AND. ( fft_in_place .eqv. fftb_in_place ) ) THEN + IF ( sign_fft == +1 ) THEN + CALL fftwnd_f77_one ( plan_b_fw, zg, zgout ) + ELSE + CALL fftwnd_f77_one ( plan_b_bw, zg, zgout ) + END IF + ELSE IF ( n1c_save == n1 .AND. n2c_save == n2 .AND. n3c_save == n3 & + .AND. ( fft_in_place .eqv. fftc_in_place ) ) THEN + IF ( sign_fft == +1 ) THEN + CALL fftwnd_f77_one ( plan_c_fw, zg, zgout ) + ELSE + CALL fftwnd_f77_one ( plan_c_bw, zg, zgout ) + END IF + ELSE IF ( n1a_save == -1 .OR. & + ( n1a_save == n1 .AND. n2a_save == n2 .AND. n3a_save == n3 & + .AND. ( fft_in_place .neqv. ffta_in_place ) .AND. & + ( n1b_save /= -1 .AND. n1c_save /= -1 ) ) ) THEN ! Initialise 'a' + IF ( fft_in_place ) THEN + CALL fftw3d_f77_create_plan ( plan_a_fw, n1, n2, n3, FFTW_FORWARD, & + FFTW_ESTIMATE + FFTW_IN_PLACE ) + CALL fftw3d_f77_create_plan ( plan_a_bw, n1, n2, n3, FFTW_BACKWARD, & + FFTW_ESTIMATE + FFTW_IN_PLACE ) + ELSE + CALL fftw3d_f77_create_plan ( plan_a_fw, n1, n2, n3, FFTW_FORWARD, & + FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) + CALL fftw3d_f77_create_plan ( plan_a_bw, n1, n2, n3, FFTW_BACKWARD, & + FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) + END IF + n1a_save = n1 + n2a_save = n2 + n3a_save = n3 + ffta_in_place = fft_in_place + + IF ( sign_fft == +1 ) THEN + CALL fftwnd_f77_one ( plan_a_fw, zg, zgout ) + ELSE + CALL fftwnd_f77_one ( plan_a_bw, zg, zgout ) + END IF + + ELSE IF ( n1b_save == -1 .OR. & + ( n1b_save == n1 .AND. n2b_save == n2 .AND. n3b_save == n3 & + .AND. ( fft_in_place .neqv. fftb_in_place ) .AND. & + n1c_save /= -1 ) ) THEN ! Initialise 'a' + IF ( fft_in_place ) THEN + CALL fftw3d_f77_create_plan ( plan_b_fw, n1, n2, n3, FFTW_FORWARD, & + FFTW_ESTIMATE + FFTW_IN_PLACE ) + CALL fftw3d_f77_create_plan ( plan_b_bw, n1, n2, n3, FFTW_BACKWARD, & + FFTW_ESTIMATE + FFTW_IN_PLACE ) + ELSE + CALL fftw3d_f77_create_plan ( plan_b_fw, n1, n2, n3, FFTW_FORWARD, & + FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) + CALL fftw3d_f77_create_plan ( plan_b_bw, n1, n2, n3, FFTW_BACKWARD, & + FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) + END IF + n1b_save = n1 + n2b_save = n2 + n3b_save = n3 + fftb_in_place = fft_in_place + + IF ( sign_fft == +1 ) THEN + CALL fftwnd_f77_one ( plan_b_fw, zg, zgout ) + ELSE + CALL fftwnd_f77_one ( plan_b_bw, zg, zgout ) + END IF + + ELSE ! Initialise 'c' + IF ( fft_in_place ) THEN + CALL fftw3d_f77_create_plan ( plan_c_fw, n1, n2, n3, FFTW_FORWARD, & + FFTW_ESTIMATE + FFTW_IN_PLACE ) + CALL fftw3d_f77_create_plan ( plan_c_bw, n1, n2, n3, FFTW_BACKWARD, & + FFTW_ESTIMATE + FFTW_IN_PLACE ) + ELSE + CALL fftw3d_f77_create_plan ( plan_c_fw, n1, n2, n3, FFTW_FORWARD, & + FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) + CALL fftw3d_f77_create_plan ( plan_c_bw, n1, n2, n3, FFTW_BACKWARD, & + FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) + END IF + n1c_save = n1 + n2c_save = n2 + n3c_save = n3 + fftc_in_place = fft_in_place + + IF ( sign_fft == +1 ) THEN + CALL fftwnd_f77_one ( plan_c_fw, zg, zgout ) + ELSE + CALL fftwnd_f77_one ( plan_c_bw, zg, zgout ) + END IF + END IF + +#else + + fsign = 0 + +#endif + + IF ( norm /= 1._dbl ) THEN + IF ( fft_in_place ) THEN + zg = zg * norm + ELSE + zgout = zgout * norm + END IF + END IF + +END SUBROUTINE fft3d + +!****************************************************************************** + +END MODULE fftw_lib + +!****************************************************************************** diff --git a/src/fist_debug.F b/src/fist_debug.F index ab86f4ae77..6e5f59ee17 100644 --- a/src/fist_debug.F +++ b/src/fist_debug.F @@ -6,23 +6,23 @@ MODULE fist_debug USE ewald_parameters_types, ONLY : ewald_parameters_type - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE md, ONLY : thermodynamic_type - USE molecule_types, ONLY : molecule_structure_type, particle_node_type - USE particle_types, ONLY : particle_type - USE pair_potential, ONLY : potentialparm_type, ener_coul - USE fist_force, ONLY : force_control, debug_variables_type USE fist_force_numer, ONLY : force_bond_numer, force_bend_numer, & force_nonbond_numer, force_recip_numer, pvbond_numer, pvbend_numer, & ptens_numer, pvg_numer, potential_g_numer, de_g_numer, & energy_recip_numer + USE fist_force, ONLY : force_control, debug_variables_type + USE global_types, ONLY : global_environment_type + USE kinds, ONLY : dbl USE linklists, ONLY : bonds, bends, torsions, dist_constraints, & g3x3_constraints - USE pw_grid_types, ONLY : pw_grid_type - USE pw_grids, ONLY : pw_grid_setup + USE md, ONLY : thermodynamic_type + USE molecule_types, ONLY : molecule_structure_type, particle_node_type + USE particle_types, ONLY : particle_type + USE pair_potential, ONLY : potentialparm_type, ener_coul + USE pw_grid_types, ONLY : pw_grid_type, HALFSPACE + USE pw_grids, ONLY : pw_find_cutoff, pw_grid_setup USE simulation_cell, ONLY : cell_type - USE stop_program, ONLY : stop_memory + USE stop_program, ONLY : stop_memory, stop_prg IMPLICIT NONE @@ -53,16 +53,16 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, & ! Locals TYPE ( debug_variables_type ) :: dbg - TYPE ( pw_grid_type ) :: pw_grid - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_numer - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rel, diff - INTEGER :: iflag, i, natoms, isos, iatom, iw, ir + TYPE ( pw_grid_type ) :: ewald_grid + INTEGER :: iflag, i, natoms, isos, iatom, iw, ir, npts_s(3), gmax INTEGER, DIMENSION ( 2 ) :: dum - REAL ( dbl ) :: delta, energy_numer + REAL ( dbl ) :: delta, energy_numer, cutoff REAL ( dbl ) :: e_numer, pv_test ( 3, 3 ) REAL ( dbl ) :: err1, numer, denom1, vec ( 3 ), e_bc, e_real, energy_tot REAL ( dbl ) :: denom2, err2 REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_bc, f_real + REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_numer + REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rel, diff !------------------------------------------------------------------------------ @@ -113,8 +113,8 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, & ELSE WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta END IF - CALL force_nonbond_numer ( pnode, box, potparm, delta, f_numer, & - energy_numer ) + CALL force_nonbond_numer ( ewald_param, pnode, box, potparm, & + delta, f_numer, energy_numer ) WRITE ( iw, '( A, T61, E20.14 )' ) ' NON BOND NUMER ENERGY = ', & energy_numer WRITE ( iw, '( A, T61, E20.14 )' ) ' NON BOND ANAL ENERGY = ', & @@ -314,101 +314,112 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, & END IF ! Debug g-space -! IF ( ewald_param % ewald_type /= 'NONE' ) THEN -! WRITE ( iw, '( A )' ) ' DO YOU WANT TO DEBUG YOUR G-SPACE (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! CALL pw_grid_setup ( box, pw_grid, ewald_param % gmax ) -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE ENERGIES (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! WRITE ( iw, '( A, T71, I10 )' ) 'TOTAL NUMBER OF G-VECTORS= ', & -! pw_grid % ngpts_cut -! WRITE ( iw, '( A, T71, F10.4 )' ) 'ALPHA= ', & -! ewald_param % alpha -! CALL energy_recip_numer ( pnode, box, potparm, pw_grid, & -! energy_numer, pw_grid % ngpts_cut ) -! WRITE ( iw, '( A, T61, G20.14 )' ) 'G-SPACE ANAL ENERGY = ', & -! dbg % pot_g -! WRITE ( iw, '( A, T61, G20.14 )' ) & -! 'G-SPACE NUMERICAL ENERGY = ', energy_numer -! END IF -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE FORCES (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' -! READ ( ir, * ) delta -! IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN -! delta = 1.0E-5_dbl -! WRITE ( iw, '( A, T71, F10.6 )' ) & -! ' DELTA (changed to default) = ', delta -! ELSE -! WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta -! END IF -! -! CALL force_recip_numer ( pnode, box, potparm, gvec, delta, f_numer ) -! + IF ( ewald_param % ewald_type /= 'NONE' ) THEN + WRITE ( iw, '( A )' ) ' DO YOU WANT TO DEBUG YOUR G-SPACE (1=yes)?' + READ ( ir, * ) iflag + IF ( iflag == 1 ) THEN + gmax = ewald_param % gmax + ewald_grid % bounds ( 1, : ) = -gmax / 2 + ewald_grid % bounds ( 2, : ) = +gmax / 2 + npts_s = (/ gmax, gmax, gmax /) + ewald_grid % grid_span = HALFSPACE + + CALL pw_find_cutoff ( npts_s, box, cutoff ) + + CALL pw_grid_setup( box, ewald_grid, cutoff) + + WRITE ( iw, '( A )' ) & + ' DO YOU WANT TO DEBUG YOUR G-SPACE ENERGIES (1=yes)?' + READ ( ir, * ) iflag + IF ( iflag == 1 ) THEN + WRITE ( iw, '( A, T71, I10 )' ) 'TOTAL NUMBER OF G-VECTORS= ', & + ewald_grid % ngpts_cut + WRITE ( iw, '( A, T71, F10.4 )' ) 'ALPHA= ', & + ewald_param % alpha + CALL energy_recip_numer ( ewald_param, pnode, box, & + ewald_grid, energy_numer, ewald_grid % ngpts_cut ) + WRITE ( iw, '( A, T61, G20.14 )' ) 'G-SPACE ANAL ENERGY = ', & + dbg % pot_g + WRITE ( iw, '( A, T61, G20.14 )' ) & + 'G-SPACE NUMERICAL ENERGY = ', energy_numer + END IF + WRITE ( iw, '( A )' ) & + ' DO YOU WANT TO DEBUG YOUR G-SPACE FORCES (1=yes)?' + READ ( ir, * ) iflag + IF ( iflag == 1 ) THEN + WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' + READ ( ir, * ) delta + IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN + delta = 1.0E-5_dbl + WRITE ( iw, '( A, T71, F10.6 )' ) & + ' DELTA (changed to default) = ', delta + ELSE + WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta + END IF + + CALL force_recip_numer ( ewald_param, pnode, box, ewald_grid, & + delta, f_numer ) + ! computing the absolute value of the differences in the forces -! diff = ABS ( dbg % f_g - f_numer ) -! rel = diff / dbg % f_g -! + diff = ABS ( dbg % f_g - f_numer ) + rel = diff / dbg % f_g + ! find the maximum difference and the relative and absolute errors. -! WRITE ( iw, '( A,T61,G20.14 )' ) & -! 'MAXIMUM ABSOLUTE ERROR = ', maxval(diff) -! WRITE ( iw, '( A,T61,G20.14 )' ) & -! 'MAXIMUM RELATIVE ERROR = ', maxval(rel) + WRITE ( iw, '( A,T61,G20.14 )' ) & + 'MAXIMUM ABSOLUTE ERROR = ', maxval(diff) + WRITE ( iw, '( A,T61,G20.14 )' ) & + 'MAXIMUM RELATIVE ERROR = ', maxval(rel) ! -! write out the particle number and forces of -! the max absolute and relative error -! dum = MAXLOC ( diff ) -! WRITE ( iw, '( A,T71,I10 )' ) & -! ' PARTICLE WITH MAX ABSOLUTE ERROR IS ', dum(2) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & -! dbg % f_g(:,dum(2)) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & -! f_numer(:,dum(2)) -! -! dum = MAXLOC ( rel ) -! WRITE ( iw, '( A,T71,I10 )' ) & -! 'PARTICLE WITH MAX RELATIVE ERROR IS ', dum(2) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & -! dbg % f_g(:,dum(2)) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & -! f_numer(:,dum(2)) -! END IF -! -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE VIRIAL (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN +! write out the particle number and forces of the max absolute +! and relative error + dum = MAXLOC ( diff ) + WRITE ( iw, '( A,T71,I10 )' ) & + ' PARTICLE WITH MAX ABSOLUTE ERROR IS ', dum(2) + WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & + dbg % f_g(:,dum(2)) + WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & + f_numer(:,dum(2)) + + dum = MAXLOC ( rel ) + WRITE ( iw, '( A,T71,I10 )' ) & + 'PARTICLE WITH MAX RELATIVE ERROR IS ', dum(2) + WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & + dbg % f_g(:,dum(2)) + WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & + f_numer(:,dum(2)) + END IF + + WRITE ( iw, '( A )' ) & + ' DO YOU WANT TO DEBUG YOUR G-SPACE VIRIAL (1=yes)?' + READ ( ir, * ) iflag + IF ( iflag == 1 ) THEN ! ! get numerical virial -! WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' -! READ ( ir, * ) delta -! IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN -! delta = 1.0E-5_dbl -! WRITE ( iw, '( A,T71,F10.6 )' ) & -! ' DELTA (changed to default) = ', delta -! ELSE -! WRITE ( iw, '( A,T71,F10.6 )' ) ' DELTA = ', delta -! END IF -! CALL pvg_numer ( pnode, box, potparm, gvec, pv_test, delta ) -! + WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' + READ ( ir, * ) delta + IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN + delta = 1.0E-5_dbl + WRITE ( iw, '( A,T71,F10.6 )' ) & + ' DELTA (changed to default) = ', delta + ELSE + WRITE ( iw, '( A,T71,F10.6 )' ) ' DELTA = ', delta + END IF + CALL pvg_numer ( ewald_param, pnode, box, & + ewald_grid, pv_test, delta ) + ! writing out the virials -! WRITE ( iw, '( A )' ) ' PV G-SPACE NUMERICAL' -! DO i = 1, 3 -! WRITE ( iw, '( T21,3G20.14 )' ) pv_test(i,:) -! END DO -! WRITE ( iw, '( A )' ) ' PV G-SPACE' -! DO i = 1, 3 -! WRITE ( iw, '( T21,3G20.14 )' ) dbg % pv_g(i,:) -! END DO -! END IF -! END IF -! END IF -! + WRITE ( iw, '( A )' ) ' PV G-SPACE NUMERICAL' + DO i = 1, 3 + WRITE ( iw, '( T21,3G20.14 )' ) pv_test(i,:) + END DO + WRITE ( iw, '( A )' ) ' PV G-SPACE' + DO i = 1, 3 + WRITE ( iw, '( T21,3G20.14 )' ) dbg % pv_g(i,:) + END DO + END IF + END IF + END IF + ! Debug real-space virial WRITE ( iw, '( A )' ) & ' DO YOU WANT TO DEBUG YOUR NON BOND (REAL SPACE) VIRIAL (1=yes)?' @@ -425,7 +436,7 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, & ELSE WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta END IF - CALL ptens_numer ( pnode, box, potparm, pv_test, delta ) + CALL ptens_numer ( ewald_param, pnode, box, potparm, pv_test, delta ) ! ! writing out the virials WRITE ( iw, '( A )' ) ' PV NUMERICAL' diff --git a/src/fist_force.F b/src/fist_force.F index a1e4d8ea92..918c47a0da 100644 --- a/src/fist_force.F +++ b/src/fist_force.F @@ -61,7 +61,7 @@ SUBROUTINE force_control ( molecule, pnode, part, box, thermo, & TYPE ( debug_variables_type ), INTENT ( OUT ), OPTIONAL :: debug ! Locals - INTEGER :: id, i, natoms, nnodes, handle, isos + INTEGER :: id, i, ii, natoms, nnodes, handle, isos REAL ( dbl ) :: pot_nonbond, pot_bond, pot_bend, vg_coulomb REAL ( dbl ), DIMENSION ( :,: ), ALLOCATABLE, SAVE :: f_nonbond REAL ( dbl ), DIMENSION ( 3,3 ) :: pv_nonbond, pv_bond, pv_bend @@ -80,21 +80,27 @@ SUBROUTINE force_control ( molecule, pnode, part, box, thermo, & natoms = SIZE ( part ) isos = 0 first_time = .NOT. ALLOCATED ( f_nonbond ) - IF ( .NOT. ALLOCATED ( f_nonbond ) ) & - ALLOCATE ( f_nonbond ( 3,natoms ), STAT = isos ) - IF ( isos /= 0 ) & + IF ( .NOT. ALLOCATED ( f_nonbond ) ) THEN + ALLOCATE ( f_nonbond ( 3,natoms ), STAT = isos ) + IF ( isos /= 0 ) & CALL stop_memory ( 'force_control', 'f_nonbond', 3 * natoms ) + ELSE IF ( SIZE ( f_nonbond ( 1, : ) ) < natoms ) THEN + DEALLOCATE ( f_nonbond, STAT = isos ) + IF ( isos /= 0 ) CALL stop_memory ( 'force_control', 'f_nonbond' ) + ALLOCATE ( f_nonbond ( 3,natoms ), STAT = isos ) + IF ( isos /= 0 ) & + CALL stop_memory ( 'force_control', 'f_nonbond', 3 * natoms ) + END IF ! initialize ewalds IF ( first_time ) THEN SELECT CASE ( ewald_param % ewald_type ) CASE ( 'EWALD_GAUSS' ) - CALL ewald_initialize ( dg, part, pnode, fc_global % group, & - ewald_param, box, thermo, fc_global % scr, & - ewald_grid = grid_ewald ) + CALL ewald_initialize ( dg, part, pnode, fc_global, & + ewald_param, box, thermo, ewald_grid = grid_ewald ) CASE ( 'PME_GAUSS' ) - CALL ewald_initialize ( dg, part, pnode, fc_global % group, & - ewald_param, box, thermo, fc_global % scr, & + CALL ewald_initialize ( dg, part, pnode, fc_global, & + ewald_param, box, thermo, & pme_small_grid = grid_s, pme_big_grid = grid_b ) END SELECT END IF @@ -200,19 +206,19 @@ SUBROUTINE force_control ( molecule, pnode, part, box, thermo, & ! add up all the forces ! nonbonded forces might be claculated for atoms not on this node ! ewald forces are strictly local -> sum only over pnode +! We first sum the forces in f_nonbond, this allows for a more efficient +! global sum in the parallel code and in the end copy them back to part DO i = 1, natoms - part ( i ) % f ( 1 ) = part ( i ) % f ( 1 ) + f_nonbond ( 1, i ) - part ( i ) % f ( 2 ) = part ( i ) % f ( 2 ) + f_nonbond ( 2, i ) - part ( i ) % f ( 3 ) = part ( i ) % f ( 3 ) + f_nonbond ( 3, i ) + f_nonbond ( 1, i ) = part ( i ) % f ( 1 ) + f_nonbond ( 1, i ) + f_nonbond ( 2, i ) = part ( i ) % f ( 2 ) + f_nonbond ( 2, i ) + f_nonbond ( 3, i ) = part ( i ) % f ( 3 ) + f_nonbond ( 3, i ) END DO IF ( ewald_param % ewald_type /= 'NONE' ) THEN DO i = 1, nnodes - pnode ( i ) % p % f ( 1 ) = pnode ( i ) % p % f ( 1 ) & - + fg_coulomb ( 1, i ) - pnode ( i ) % p % f ( 2 ) = pnode ( i ) % p % f ( 2 ) & - + fg_coulomb ( 2, i ) - pnode ( i ) % p % f ( 3 ) = pnode ( i ) % p % f ( 3 ) & - + fg_coulomb ( 3, i ) + ii = pnode ( i ) % p % iatom + f_nonbond ( 1, ii ) = f_nonbond ( 1, ii ) + fg_coulomb ( 1, i ) + f_nonbond ( 2, ii ) = f_nonbond ( 2, ii ) + fg_coulomb ( 2, i ) + f_nonbond ( 3, ii ) = f_nonbond ( 3, ii ) + fg_coulomb ( 3, i ) END DO END IF @@ -265,10 +271,14 @@ SUBROUTINE force_control ( molecule, pnode, part, box, thermo, & IF ( isos /= 0 ) CALL stop_memory ( 'force_control', 'fg_coulomb' ) #if defined ( __parallel ) - DO i = 1, natoms - CALL mp_sum ( part ( i ) % f, fc_global % group ) - END DO + CALL mp_sum ( f_nonbond, fc_global % group ) #endif + + DO i = 1, natoms + part ( i ) % f ( 1 ) = f_nonbond ( 1, i ) + part ( i ) % f ( 2 ) = f_nonbond ( 2, i ) + part ( i ) % f ( 3 ) = f_nonbond ( 3, i ) + END DO CALL timestop ( zero, handle ) diff --git a/src/fist_force_numer.F b/src/fist_force_numer.F index a538cbbe8b..fe5ec57646 100644 --- a/src/fist_force_numer.F +++ b/src/fist_force_numer.F @@ -14,6 +14,7 @@ MODULE fist_force_numer USE mol_force, ONLY : force_bonds, force_bends USE pair_potential, ONLY : potential_f, potentialparm_type USE pw_grid_types, ONLY : pw_grid_type + USE pw_grids, ONLY : pw_find_cutoff, pw_grid_setup USE simulation_cell, ONLY : cell_type, pbc, get_hinv, get_cell_param USE stop_program, ONLY : stop_memory @@ -197,8 +198,8 @@ END SUBROUTINE force_bend_numer !****************************************************************************** -SUBROUTINE force_nonbond_numer ( pnode, box, potparm, numerical_shift, & - f_numer, energy_numer ) +SUBROUTINE force_nonbond_numer ( ewald_param, pnode, box, potparm, & + numerical_shift, f_numer, energy_numer ) ! ! Calculates the force and the potential of the minimum image, and @@ -207,6 +208,7 @@ SUBROUTINE force_nonbond_numer ( pnode, box, potparm, numerical_shift, & IMPLICIT NONE ! Arguments + TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode TYPE ( cell_type ), INTENT ( INOUT ) :: box TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm @@ -298,17 +300,29 @@ SUBROUTINE force_nonbond_numer ( pnode, box, potparm, numerical_shift, & delta(id) = numerical_shift rij_minus_delta_sq = dot_product(rij-delta,rij-delta) rij_plus_delta_sq = dot_product(rij+delta,rij+delta) - CALL potential_f ( rij_minus_delta_sq, potparm, qi, qj, & + IF (qi==0.AND.qj==0) THEN + CALL potential_f(rij_minus_delta_sq,potparm,qi,qj, & iatomtype, jatomtype, energy_minus ) - CALL potential_f ( rij_plus_delta_sq, potparm, qi, qj, & + CALL potential_f(rij_plus_delta_sq,potparm,qi,qj, & iatomtype, jatomtype, energy_plus ) + ELSE + CALL potential_f(rij_minus_delta_sq,potparm,qi,qj, & + iatomtype, jatomtype, energy_minus, ewald_param ) + CALL potential_f(rij_plus_delta_sq,potparm,qi,qj, & + iatomtype, jatomtype, energy_plus, ewald_param ) + ENDIF f_numer(id,i) = f_numer(id,i) + (energy_plus-energy_minus) f_numer(id,j) = f_numer(id,j) - (energy_plus-energy_minus) delta = 0.0_dbl END DO DIM_LOOP - - CALL potential_f ( rijsq, potparm, qi, qj, & + IF (qi==0.AND.qj==0) THEN + CALL potential_f ( rijsq, potparm, qi, qj, & iatomtype, jatomtype, energy ) + ELSE + CALL potential_f ( rijsq, potparm, qi, qj, & + iatomtype, jatomtype, energy, ewald_param ) + ENDIF + energy_numer = energy_numer + energy END IF NOTMATCH END IF @@ -339,10 +353,17 @@ SUBROUTINE force_nonbond_numer ( pnode, box, potparm, numerical_shift, & delta(id) = numerical_shift rij_minus_delta_sq = dot_product(rij-delta,rij-delta) rij_plus_delta_sq = dot_product(rij+delta,rij+delta) - CALL potential_f(rij_minus_delta_sq,potparm,qi,qj, & + IF (qi==0.AND.qj==0) THEN + CALL potential_f(rij_minus_delta_sq,potparm,qi,qj, & iatomtype, jatomtype, energy_minus ) - CALL potential_f(rij_plus_delta_sq,potparm,qi,qj, & + CALL potential_f(rij_plus_delta_sq,potparm,qi,qj, & iatomtype, jatomtype, energy_plus ) + ELSE + CALL potential_f(rij_minus_delta_sq,potparm,qi,qj, & + iatomtype, jatomtype, energy_minus, ewald_param ) + CALL potential_f(rij_plus_delta_sq,potparm,qi,qj, & + iatomtype, jatomtype, energy_plus, ewald_param ) + ENDIF f_numer(id,i) = f_numer(id,i) & + (energy_plus-energy_minus) f_numer(id,j) = f_numer(id,j) & @@ -350,8 +371,13 @@ SUBROUTINE force_nonbond_numer ( pnode, box, potparm, numerical_shift, & delta = 0.0_dbl END DO DIM_LOOP2 - CALL potential_f ( rijsq, potparm, qi, qj, & + IF (qi==0.AND.qj==0) THEN + CALL potential_f ( rijsq, potparm, qi, qj, & iatomtype, jatomtype, energy ) + ELSE + CALL potential_f ( rijsq, potparm, qi, qj, & + iatomtype, jatomtype, energy, ewald_param ) + ENDIF energy_numer = energy_numer + energy END IF END DO @@ -377,10 +403,17 @@ SUBROUTINE force_nonbond_numer ( pnode, box, potparm, numerical_shift, & delta(id) = numerical_shift rij_minus_delta_sq = dot_product(rij-delta,rij-delta) rij_plus_delta_sq = dot_product(rij+delta,rij+delta) - CALL potential_f(rij_minus_delta_sq,potparm,qi,qi, & - iatomtype,iatomtype,energy_minus) - CALL potential_f(rij_plus_delta_sq,potparm,qi,qi, & - iatomtype,iatomtype,energy_plus) + IF (qi==0.AND.qj==0) THEN + CALL potential_f(rij_minus_delta_sq,potparm,qi,qj, & + iatomtype, jatomtype, energy_minus ) + CALL potential_f(rij_plus_delta_sq,potparm,qi,qj, & + iatomtype, jatomtype, energy_plus ) + ELSE + CALL potential_f(rij_minus_delta_sq,potparm,qi,qj, & + iatomtype, jatomtype, energy_minus, ewald_param ) + CALL potential_f(rij_plus_delta_sq,potparm,qi,qj, & + iatomtype, jatomtype, energy_plus, ewald_param ) + ENDIF f_numer(id,i) = f_numer(id,i) & + (energy_plus-energy_minus) f_numer(id,i) = f_numer(id,i) & @@ -388,8 +421,13 @@ SUBROUTINE force_nonbond_numer ( pnode, box, potparm, numerical_shift, & delta = 0.0_dbl END DO DIM_LOOP3 - CALL potential_f ( rijsq, potparm, qi, qi, & - iatomtype,iatomtype, energy ) + IF (qi==0.AND.qj==0) THEN + CALL potential_f ( rijsq, potparm, qi, qj, & + iatomtype, jatomtype, energy ) + ELSE + CALL potential_f ( rijsq, potparm, qi, qj, & + iatomtype, jatomtype, energy, ewald_param ) + ENDIF energy_numer = energy_numer + energy END IF END DO @@ -411,16 +449,15 @@ END SUBROUTINE force_nonbond_numer !****************************************************************************** -SUBROUTINE force_recip_numer ( ewald_param, pnode, box, potparm, & - pw_grid, numerical_shift, f_numer ) +SUBROUTINE force_recip_numer ( ewald_param, pnode, box, pw_grid, & + numerical_shift, f_numer ) IMPLICIT NONE ! Arguments + TYPE ( cell_type ), INTENT ( IN ) :: box TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - TYPE ( cell_type ), INTENT ( IN ) :: box - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm TYPE ( pw_grid_type ), INTENT ( IN ) :: pw_grid REAL ( dbl ), INTENT ( IN ) :: numerical_shift REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: f_numer @@ -428,48 +465,30 @@ SUBROUTINE force_recip_numer ( ewald_param, pnode, box, potparm, & ! Locals COMPLEX ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: sum_igr REAL ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: gauss - REAL ( dbl ), ALLOCATABLE, DIMENSION ( :, : ) :: gdebug REAL ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: r_delta - INTEGER :: ig, i, idim, natoms, ngtot, isos, lp, mp, np REAL ( dbl ) :: alpha, epsilon0, ep, em, charge + INTEGER :: gpt, i, idim, natoms, ngtot, isos, lp, mp, np !------------------------------------------------------------------------------ - + ! allocating ngtot = pw_grid % ngpts_cut - ALLOCATE (gdebug(3,ngtot),STAT=isos) - IF ( isos /= 0 ) & - CALL stop_memory ( 'force_recip_numer', 'gdebug', 3 * ngtot ) ALLOCATE (sum_igr(ngtot),STAT=isos) IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer', 'sum_igr', ngtot ) ALLOCATE (gauss(ngtot),STAT=isos) IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer', 'gauss', ngtot ) ALLOCATE (r_delta(3),STAT=isos) IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer', 'r_delta', 3 ) - -! computing the g-vectors - DO ig = 1, ngtot - lp = pw_grid % mapl % pos ( pw_grid % g_hat(1,ig) ) - mp = pw_grid % mapm % pos ( pw_grid % g_hat(2,ig) ) - np = pw_grid % mapn % pos ( pw_grid % g_hat(3,ig) ) - - gdebug(1,ig) = 2.0_dbl*pi*(box % h_inv(1,1)*lp+box % h_inv(2,1)* mp & - +box % h_inv(3,1)*np) - gdebug(2,ig) = 2.0_dbl*pi*(box % h_inv(1,2)*lp+box % h_inv(2,2)* mp & - +box % h_inv(3,2)*np) - gdebug(3,ig) = 2.0_dbl*pi*(box % h_inv(1,3)*lp+box % h_inv(2,3)* mp & - +box % h_inv(3,3)*np) - END DO - -! defining alpha and epsilon0 (see ewald.f for details) +! defining alpha and epsilon0 alpha = ewald_param % alpha epsilon0 = ewald_param % eps0 ! first initialize the arrays gauss and sum_igr - CALL potential_g_numer ( ep, pnode, sum_igr, gauss, alpha, gdebug, ngtot ) + CALL potential_g_numer ( ep, pnode, sum_igr, gauss, alpha, & + pw_grid % g, ngtot ) ! initializing numerical force - f_numer = 0.0_dbl + f_numer( :, : ) = 0.0_dbl ! computing the numerical force on each atom natoms = size(pnode) @@ -478,21 +497,19 @@ SUBROUTINE force_recip_numer ( ewald_param, pnode, box, potparm, & r_delta ( : ) = pnode(i) % p % r ( : ) DO idim = 1, 3 r_delta(idim) = r_delta(idim) + numerical_shift - CALL de_g_numer(ep,sum_igr,gauss,pnode(i) % p % r,r_delta,charge, & - gdebug,ngtot) + CALL de_g_numer(ep, sum_igr, gauss, pnode(i) % p % r , & + r_delta, charge, pw_grid % g, ngtot) r_delta(idim) = r_delta(idim) - 2.0_dbl*numerical_shift - CALL de_g_numer(em,sum_igr,gauss,pnode(i) % p % r,r_delta,charge, & - gdebug,ngtot) - f_numer(idim,i) = (em-ep)/epsilon0/box % deth + CALL de_g_numer(em, sum_igr, gauss, pnode(i) % p % r , & + r_delta, charge, pw_grid % g, ngtot) + f_numer(idim,i) = ( em - ep ) / epsilon0 / box % deth r_delta(idim) = r_delta(idim) + numerical_shift END DO END DO - f_numer = f_numer / ( 2.0_dbl * numerical_shift ) + f_numer = f_numer / 2.0_dbl / numerical_shift DEALLOCATE (r_delta,STAT=isos) IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer','r_delta') - DEALLOCATE (gdebug,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer','gdebug') DEALLOCATE (sum_igr,STAT=isos) IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer','sum_igr') DEALLOCATE (gauss,STAT=isos) @@ -681,13 +698,14 @@ END SUBROUTINE pvbend_numer !****************************************************************************** -SUBROUTINE ptens_numer(pnode,box,potparm,pv_test,delta) +SUBROUTINE ptens_numer(ewald_param,pnode,box,potparm,pv_test,delta) ! computes the numerical pressure tensor IMPLICIT NONE ! Arguments TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode + TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param TYPE ( cell_type ), INTENT ( IN ) :: box REAL ( dbl ), INTENT ( IN ) :: delta REAL ( dbl ), DIMENSION ( 3, 3 ), INTENT ( OUT ) :: pv_test @@ -731,7 +749,7 @@ SUBROUTINE ptens_numer(pnode,box,potparm,pv_test,delta) DO i = 1, natoms x(:,i) = matmul(box_local % hmat,s(:,i)) END DO - CALL getv_ptens(pnode,x,vnb,box_local,potparm) + CALL getv_ptens(ewald_param,pnode,x,vnb,box_local,potparm) vp = vnb ! tweak again @@ -740,7 +758,7 @@ SUBROUTINE ptens_numer(pnode,box,potparm,pv_test,delta) DO i = 1, natoms x(:,i) = matmul(box_local % hmat,s(:,i)) END DO - CALL getv_ptens(pnode,x,vnb,box_local,potparm) + CALL getv_ptens(ewald_param,pnode,x,vnb,box_local,potparm) vm = vnb ! calculate the derivative @@ -773,7 +791,7 @@ END SUBROUTINE ptens_numer !****************************************************************************** -SUBROUTINE pvg_numer(ewald_param,pnode,box,potparm,pw_grid,pv_test,delta) +SUBROUTINE pvg_numer(ewald_param,pnode,box,pw_grid,pv_test,delta) ! computes the numerical pressure tensor @@ -786,22 +804,21 @@ SUBROUTINE pvg_numer(ewald_param,pnode,box,potparm,pw_grid,pv_test,delta) TYPE ( cell_type ), INTENT ( IN ) :: box REAL ( dbl ), INTENT ( IN ) :: delta REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: pv_test - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm ! Locals + TYPE ( pw_grid_type ) :: pw_grid_local TYPE ( cell_type ) :: box_local + TYPE ( particle_node_type ), DIMENSION ( : ), ALLOCATABLE :: pnode_local REAL ( dbl ), DIMENSION (3,3) :: dvdh REAL ( dbl ) :: idelta, vm, vp - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: glocal - TYPE ( particle_node_type ), DIMENSION ( : ), ALLOCATABLE :: pnode_local REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: s - REAL ( dbl ) :: alpha, epsilon0 - COMPLEX ( dbl ), DIMENSION ( : ), ALLOCATABLE :: sum_igr + REAL ( dbl ) :: alpha, epsilon0, cutoff REAL ( dbl ), DIMENSION ( : ), ALLOCATABLE :: gauss - INTEGER :: i, j, k, ii, jj, ig, ngtot, natoms, isos, lp, mp, np + COMPLEX ( dbl ), DIMENSION ( : ), ALLOCATABLE :: sum_igr + INTEGER :: i, j, k, ii, jj, natoms, isos, gmax, npts_s(3), ngtot !------------------------------------------------------------------------------ - + ! allocating natoms = SIZE ( pnode ) ALLOCATE ( s ( 3, natoms ), STAT = isos ) @@ -811,14 +828,13 @@ SUBROUTINE pvg_numer(ewald_param,pnode,box,potparm,pw_grid,pv_test,delta) IF ( isos /= 0 ) CALL stop_memory ( 'pvg_numer', 'sum_igr', ngtot ) ALLOCATE (gauss(ngtot),STAT=isos) IF ( isos /= 0 ) CALL stop_memory ( 'pvg_numer', 'gauss', ngtot ) - ALLOCATE (glocal(3,ngtot),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvg_numer', 'glocal', 3 * ngtot ) ALLOCATE (pnode_local(natoms),STAT=isos) IF ( isos /= 0 ) CALL stop_memory ( 'pvg_numer', 'pnode_local', natoms ) ! assigning the local variables box_local = box pnode_local = pnode + pw_grid_local = pw_grid DO i = 1, natoms s(:,i) = matmul(box % h_inv,pnode(i) % p % r) END DO @@ -829,6 +845,10 @@ SUBROUTINE pvg_numer(ewald_param,pnode,box,potparm,pw_grid,pv_test,delta) ! Initializing pv_test pv_test = 0.0_dbl + + gmax = ewald_param % gmax + npts_s = (/ gmax, gmax, gmax /) + CALL pw_find_cutoff ( npts_s, box, cutoff ) ! Defining the increments idelta = 1.0_dbl/(2.0_dbl*delta) @@ -845,27 +865,10 @@ SUBROUTINE pvg_numer(ewald_param,pnode,box,potparm,pw_grid,pv_test,delta) END DO ! compute the g-vectors - DO ig = 1, ngtot - lp = pw_grid % mapl % pos ( pw_grid % g_hat(1,ig) ) - mp = pw_grid % mapm % pos ( pw_grid % g_hat(2,ig) ) - np = pw_grid % mapn % pos ( pw_grid % g_hat(3,ig) ) - - glocal(1,ig) = 2.0_dbl * pi * & - ( box % h_inv(1,1) * lp & - + box % h_inv(2,1) * mp & - + box % h_inv(3,1) * np ) - glocal(2,ig) = 2.0_dbl * pi * & - ( box % h_inv(1,2) * lp & - + box % h_inv(2,2) * mp & - + box % h_inv(3,2) * np ) - glocal(3,ig) = 2.0_dbl * pi * & - ( box % h_inv(1,3) * lp & - + box % h_inv(2,3) * mp & - + box % h_inv(3,3) * np ) - END DO + CALL pw_grid_setup( box_local, pw_grid_local, cutoff) CALL potential_g_numer ( vp, pnode_local, sum_igr, gauss, alpha, & - glocal, ngtot ) + pw_grid_local % g, ngtot ) vp = vp / ( epsilon0 * box_local % deth ) ! tweak again @@ -880,26 +883,10 @@ SUBROUTINE pvg_numer(ewald_param,pnode,box,potparm,pw_grid,pv_test,delta) END DO ! compute the g-vectors - DO ig = 1, ngtot - lp = pw_grid % mapl % pos ( pw_grid % g_hat(1,ig) ) - mp = pw_grid % mapm % pos ( pw_grid % g_hat(2,ig) ) - np = pw_grid % mapn % pos ( pw_grid % g_hat(3,ig) ) - - glocal ( 1, ig ) = 2.0_dbl * pi * & - ( box % h_inv ( 1, 1 ) * lp & - + box % h_inv ( 2, 1 ) * mp & - + box % h_inv ( 3, 1 ) * np ) - glocal ( 2, ig ) = 2.0_dbl * pi * & - ( box % h_inv ( 1, 2 ) * lp & - + box % h_inv ( 2, 2 ) * mp & - + box % h_inv ( 3, 2 ) * np ) - glocal ( 3, ig ) = 2.0_dbl * pi * & - ( box % h_inv ( 1, 3 ) * lp & - + box % h_inv ( 2, 3 ) * mp & - + box % h_inv ( 3, 3 ) * np ) - END DO + CALL pw_grid_setup( box_local, pw_grid_local, cutoff) + CALL potential_g_numer ( vm, pnode_local, sum_igr, gauss, alpha, & - glocal, ngtot ) + pw_grid_local % g, ngtot ) vm = vm / epsilon0 / box_local % deth ! calculate the derivative @@ -925,10 +912,6 @@ SUBROUTINE pvg_numer(ewald_param,pnode,box,potparm,pw_grid,pv_test,delta) IF ( isos /= 0 ) CALL stop_memory( 'pvg_numer', 'sum_igr' ) DEALLOCATE (gauss,STAT=isos) IF ( isos /= 0 ) CALL stop_memory( 'pvg_numer', 'gauss' ) - DEALLOCATE (glocal,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory( 'pvg_numer', 'glocal' ) - DEALLOCATE (pnode_local,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory( 'pvg_numer', 'pnode_local' ) END SUBROUTINE pvg_numer @@ -959,16 +942,18 @@ SUBROUTINE potential_g_numer(energy,pnode,sum_igr,gauss,alpha, & energy = 0.0_dbl sum_igr = 0.0_dbl DO ig = 1, ngtot - gsq = dot_product(glocal(:,ig),glocal(:,ig)) - gauss(ig) = exp(-gsq*.25_dbl/alpha/alpha)/gsq + gsq = DOT_PRODUCT(glocal(:,ig),glocal(:,ig)) + IF ( gsq <= 1.0E-10_dbl ) CYCLE + gauss(ig) = exp(-gsq*0.25_dbl/alpha/alpha)/gsq DO iatom = 1, natoms - gdotr = dot_product(pnode(iatom) % p % r ( : ),glocal(:,ig)) + gdotr = DOT_PRODUCT(pnode(iatom) % p % r ( : ), glocal(:,ig)) charge = pnode(iatom) % p % prop % charge - sum_igr(ig) = sum_igr(ig) + charge*cmplx(cos(gdotr),sin(gdotr)) + sum_igr(ig) = sum_igr(ig) + charge*CMPLX(COS(gdotr),SIN(gdotr)) END DO ! computing the potential energy - energy = energy + gauss(ig)*sum_igr(ig)*conjg(sum_igr(ig)) + energy = energy + gauss(ig)* REAL ( sum_igr ( ig ) * & + CONJG( sum_igr ( ig ) ) ) END DO END SUBROUTINE potential_g_numer @@ -991,74 +976,60 @@ SUBROUTINE de_g_numer(energy,sum_igr,gauss,r,r_delta,charge,glocal, & ! Locals INTEGER :: ig - REAL ( dbl ) :: gdotr, gdotr_delta + REAL ( dbl ) :: gdotr, gdotr_delta, gsq COMPLEX ( dbl ) :: sum !------------------------------------------------------------------------------ ! initialize energy energy = 0._dbl + sum = ( 0._dbl, 0._dbl ) DO ig = 1, igtot + gsq = DOT_PRODUCT( glocal(:,ig), glocal(:,ig)) + IF ( gsq <= 1.0E-10_dbl ) CYCLE ! compute g.r and g.(r+delta) - gdotr = dot_product(r ( : ),glocal(:,ig)) - gdotr_delta = dot_product(r_delta ( : ),glocal(:,ig)) + gdotr = DOT_PRODUCT ( r ( : ), glocal ( :, ig ) ) + gdotr_delta = DOT_PRODUCT ( r_delta ( : ), glocal ( :, ig ) ) ! subtract off exp(ig.r) and add exp(ig.(r+delta)) - sum = sum_igr(ig) - charge*cmplx(cos(gdotr),sin(gdotr)) + & - charge*cmplx(cos(gdotr_delta),sin(gdotr_delta)) + sum = sum_igr ( ig ) - charge * CMPLX ( COS( gdotr ), SIN( gdotr ) ) + & + charge * CMPLX( COS( gdotr_delta ), SIN( gdotr_delta ) ) ! recompute energy - energy = energy + gauss(ig)*sum*conjg(sum) + energy = energy + gauss(ig) * REAL ( sum * CONJG ( sum ) ) END DO END SUBROUTINE de_g_numer !****************************************************************************** -SUBROUTINE energy_recip_numer ( ewald_param, pnode, box, potparm, pw_grid, & +SUBROUTINE energy_recip_numer ( ewald_param, pnode, box, pw_grid, & energy_numer, ngtot ) IMPLICIT NONE ! Arguments TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - TYPE ( pw_grid_type ), INTENT ( IN ) :: pw_grid + TYPE ( pw_grid_type ), INTENT ( IN ):: pw_grid TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode TYPE ( cell_type ), INTENT ( IN ) :: box - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm REAL ( dbl ), INTENT ( OUT ) :: energy_numer INTEGER, INTENT ( IN ) :: ngtot ! Locals COMPLEX ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: sum_igr REAL ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: gauss - REAL ( dbl ), ALLOCATABLE, DIMENSION ( :, : ) :: gdebug + REAL ( dbl ) :: alpha, epsilon0 INTEGER :: ig, i, idim, isos, lp, mp, np - REAL ( dbl ) :: alpha, epsilon0, ep, em, charge !------------------------------------------------------------------------------ - + ! allocating - ALLOCATE (gdebug(3,ngtot),STAT=isos) - IF ( isos /= 0 ) & - CALL stop_memory ( 'energy_recip_numer', 'gdebug', 3 * ngtot ) + ALLOCATE ( sum_igr ( ngtot ), STAT = isos ) IF ( isos /= 0 ) CALL stop_memory ( 'energy_recip_numer', 'sum_igr', ngtot ) - ALLOCATE (gauss(ngtot),STAT=isos) + ALLOCATE ( gauss ( ngtot ), STAT = isos ) IF ( isos /= 0 ) CALL stop_memory ( 'energy_recip_numer', 'gauss', ngtot ) - -! computing the g-vectors - DO ig = 1, ngtot - lp = pw_grid % mapl % pos ( pw_grid % g_hat(1,ig) ) - mp = pw_grid % mapm % pos ( pw_grid % g_hat(2,ig) ) - np = pw_grid % mapn % pos ( pw_grid % g_hat(3,ig) ) - gdebug(1,ig) = 2.0_dbl*pi*(box % h_inv(1,1)*lp+box % h_inv(2,1)*mp & - +box % h_inv(3,1)*np) - gdebug(2,ig) = 2.0_dbl*pi*(box % h_inv(1,2)*lp+box % h_inv(2,2)*mp & - +box % h_inv(3,2)*np) - gdebug(3,ig) = 2.0_dbl*pi*(box % h_inv(1,3)*lp+box % h_inv(2,3)*mp & - +box % h_inv(3,3)*np) - END DO - -! defining alpha and epsilon0 (see ewald.f for details) + +! defining alpha and epsilon0 alpha = ewald_param % alpha epsilon0 = ewald_param % eps0 @@ -1067,11 +1038,8 @@ SUBROUTINE energy_recip_numer ( ewald_param, pnode, box, potparm, pw_grid, & ! computing the energy CALL potential_g_numer(energy_numer,pnode,sum_igr,gauss,alpha, & - gdebug,ngtot) + pw_grid % g, ngtot) energy_numer = energy_numer/epsilon0/box % deth - - DEALLOCATE (gdebug,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'energy_recip_numer', 'gdebug' ) DEALLOCATE (sum_igr,STAT=isos) IF ( isos /= 0 ) CALL stop_memory ( 'energy_recip_numer', 'sum_igr' ) DEALLOCATE (gauss,STAT=isos) @@ -1157,7 +1125,7 @@ END SUBROUTINE vnumer_bends !****************************************************************************** -SUBROUTINE getv_ptens ( pnode, x, vnb, box, potparm ) +SUBROUTINE getv_ptens ( ewald_param, pnode, x, vnb, box, potparm ) IMPLICIT NONE @@ -1167,6 +1135,7 @@ SUBROUTINE getv_ptens ( pnode, x, vnb, box, potparm ) TYPE (cell_type), INTENT ( INOUT ) :: box TYPE (particle_node_type ), INTENT ( IN ), DIMENSION ( : ) :: pnode TYPE (potentialparm_type), INTENT ( IN ), DIMENSION ( :, : ) :: potparm + TYPE (ewald_parameters_type), INTENT (IN) :: ewald_param ! Locals INTEGER :: i, j, ii, jj, iatomtype, jatomtype, iexclude, natoms, id @@ -1248,9 +1217,13 @@ SUBROUTINE getv_ptens ( pnode, x, vnb, box, potparm ) END DO EXCL NOTMATCH: IF ( .NOT. match) THEN - CALL potential_f ( rijsq, potparm, qi, qj, & + IF (qi==0.AND.qj==0) THEN + CALL potential_f ( rijsq, potparm, qi, qj, & iatomtype, jatomtype, energy ) - + ELSE + CALL potential_f ( rijsq, potparm, qi, qj, & + iatomtype, jatomtype, energy, ewald_param ) + ENDIF ! ! summing up the potential energy ! @@ -1279,9 +1252,14 @@ SUBROUTINE getv_ptens ( pnode, x, vnb, box, potparm ) CALL find_image(s,perd,vec,box % hmat,rijsq,rij) IF ( rijsq <= potparm ( iatomtype, jatomtype ) % rcutsq ) & THEN - CALL potential_f ( rijsq, potparm, qi, qj, & - iatomtype,jatomtype, energy ) - vnb = vnb + energy + IF (qi==0.AND.qj==0) THEN + CALL potential_f ( rijsq, potparm, qi, qj, & + iatomtype, jatomtype, energy ) + ELSE + CALL potential_f ( rijsq, potparm, qi, qj, & + iatomtype, jatomtype, energy, ewald_param ) + ENDIF + vnb = vnb + energy END IF END DO END DO @@ -1302,9 +1280,14 @@ SUBROUTINE getv_ptens ( pnode, x, vnb, box, potparm ) CALL find_image ( s, perd, vec, box % hmat, rijsq, rij ) IF ( rijsq <= potparm ( iatomtype, iatomtype ) % rcutsq ) & THEN - CALL potential_f ( rijsq, potparm, qi, qi, & - iatomtype, iatomtype, energy ) - vnb = vnb + energy + IF (qi==0.AND.qj==0) THEN + CALL potential_f ( rijsq, potparm, qi, qj, & + iatomtype, jatomtype, energy ) + ELSE + CALL potential_f ( rijsq, potparm, qi, qj, & + iatomtype, jatomtype, energy, ewald_param ) + ENDIF + vnb = vnb + energy END IF END DO diff --git a/src/fist_intra_force.F b/src/fist_intra_force.F index ad7edfea1e..15848d3630 100644 --- a/src/fist_intra_force.F +++ b/src/fist_intra_force.F @@ -10,6 +10,7 @@ MODULE fist_intra_force get_pv_bond, get_pv_bend, get_pv_torsion USE molecule_types, ONLY : molecule_structure_type, linklist_bonds, & linklist_bends + USE timings, ONLY : timeset, timestop IMPLICIT NONE @@ -39,9 +40,11 @@ SUBROUTINE force_intra_control ( molecule, v_bond, v_bend, pvbond, pvbend, & REAL ( dbl ), DIMENSION (3) :: rij, b12, b32, g1, g2, g3 TYPE (linklist_bonds), POINTER :: llbond TYPE (linklist_bends), POINTER :: llbend - INTEGER :: ibond, ibend, imol + INTEGER :: ibond, ibend, imol, handle !------------------------------------------------------------------------------ + + CALL timeset ( 'FORCE_INTRA_CONTROL','I',' ',handle ) IF ( PRESENT ( f_bond)) f_bond = 0._dbl IF ( PRESENT ( f_bend)) f_bend = 0._dbl @@ -110,6 +113,8 @@ SUBROUTINE force_intra_control ( molecule, v_bond, v_bend, pvbond, pvbend, & END DO BEND END DO MOL + + CALL timestop ( 0._dbl, handle ) END SUBROUTINE force_intra_control diff --git a/src/force_control.F b/src/force_control.F index 5a961568bd..34ec8b6e6d 100644 --- a/src/force_control.F +++ b/src/force_control.F @@ -7,14 +7,12 @@ MODULE force_control USE ewald_parameters_types, ONLY : ewald_parameters_type USE fist_force, ONLY : fist_force_control => force_control - USE fist_global, ONLY : fistpar + USE global_types, ONLY : global_environment_type USE tbmd_force, ONLY : tbmd_force_control => force_control - USE tbmd_global, ONLY : tbmdpar USE kinds, ONLY : dbl USE md, ONLY : simulation_parameters_type, thermodynamic_type - USE pair_potential, ONLY : potentialparm_type USE stop_program, ONLY : stop_prg - USE structure_types, ONLY : structure_type + USE structure_types, ONLY : structure_type, interaction_type IMPLICIT NONE @@ -25,7 +23,7 @@ CONTAINS !****************************************************************************** -SUBROUTINE force ( struc, potparm, thermo, simpar, ewald_param ) +SUBROUTINE force ( struc, inter, thermo, simpar, ewald_param, globenv ) IMPLICIT NONE @@ -34,7 +32,8 @@ SUBROUTINE force ( struc, potparm, thermo, simpar, ewald_param ) TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm + TYPE ( interaction_type ), INTENT ( IN ) :: inter + TYPE ( global_environment_type), INTENT ( IN ) :: globenv !------------------------------------------------------------------------------ @@ -44,13 +43,13 @@ SUBROUTINE force ( struc, potparm, thermo, simpar, ewald_param ) CASE ( 'FIST' ) CALL fist_force_control ( struc % molecule, struc % pnode, struc % part, & - struc % box, thermo, potparm, ewald_param, simpar % ensemble, & - fistpar ) + struc % box, thermo, inter%potparm, ewald_param, simpar % ensemble, & + globenv ) CASE ( 'TBMD' ) CALL tbmd_force_control ( struc % molecule, struc % pnode, struc % part, & - struc % box, thermo, potparm, ewald_param, simpar % ensemble, & - tbmdpar ) + struc % box, thermo, inter%potparm, ewald_param, simpar % ensemble, & + globenv ) END SELECT diff --git a/src/integrator.F b/src/integrator.F index c99e8322bb..581a032f60 100644 --- a/src/integrator.F +++ b/src/integrator.F @@ -9,6 +9,7 @@ MODULE integrator ! pv_constraint, initialize_roll, rattle_roll_control, & ! shake_roll_control USE constraint + USE global_types, ONLY: global_environment_type USE eigenvalueproblems, ONLY : diagonalise USE ewald_parameters_types, ONLY : ewald_parameters_type USE force_control, ONLY : force @@ -22,11 +23,10 @@ MODULE integrator linklist_atoms USE message_passing, ONLY : mp_sum USE nose, ONLY : extended_parameters_type, lnhc, lnhcp, lnhcpf - USE pair_potential, ONLY : potentialparm_type USE particle_types, ONLY : particle_type USE simulation_cell, ONLY : get_cell_param USE stop_program, ONLY : stop_prg, stop_memory - USE structure_types, ONLY : structure_type + USE structure_types, ONLY : structure_type, interaction_type USE timings, ONLY : timeset, timestop USE util, ONLY : get_unit @@ -65,11 +65,15 @@ MODULE integrator INTEGER :: crd, vel, ptn, ene, tem, scr INTEGER :: icrd, ivel, iptens, iener, itemp, idump, iscreen + TYPE ( global_environment_type ) :: intenv + +!****************************************************************************** + CONTAINS !****************************************************************************** -SUBROUTINE velocity_verlet ( itimes, constant, simpar, potparm, & +SUBROUTINE velocity_verlet ( itimes, constant, simpar, inter, & thermo, struc, ewald_param, nhcp ) IMPLICIT NONE @@ -82,26 +86,30 @@ SUBROUTINE velocity_verlet ( itimes, constant, simpar, potparm, & TYPE ( structure_type ), INTENT ( INOUT ) :: struc TYPE ( extended_parameters_type ), INTENT ( INOUT ) :: nhcp TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm + TYPE ( interaction_type ), INTENT ( IN ) :: inter + INTEGER :: handle + !------------------------------------------------------------------------------ - + CALL timeset ( 'VERLET', 'I', ' ', handle ) SELECT CASE ( simpar % ensemble ) CASE DEFAULT CALL stop_prg ( 'velocity_verlet','integrator not implemented') CASE ( 'NVE') - CALL nve(itimes,constant,simpar,potparm,thermo,struc,ewald_param) + CALL nve(itimes,constant,simpar,inter,thermo,struc,ewald_param) CALL energy(itimes,constant,simpar,struc,thermo,nhcp) CASE ( 'NVT') - CALL nvt(itimes,constant,simpar,potparm,thermo,struc,ewald_param,nhcp) + CALL nvt(itimes,constant,simpar,inter,thermo,struc,ewald_param,nhcp) CALL energy(itimes,constant,simpar,struc,thermo,nhcp) CASE ( 'NPT_I') - CALL npt_i(itimes,constant,simpar,potparm,thermo,struc,ewald_param,nhcp) + CALL npt_i(itimes,constant,simpar,inter,thermo,struc,ewald_param,nhcp) CALL energy(itimes,constant,simpar,struc,thermo,nhcp) CASE ( 'NPT_F') - CALL npt_f(itimes,constant,simpar,potparm,thermo,struc,ewald_param,nhcp) + CALL npt_f(itimes,constant,simpar,inter,thermo,struc,ewald_param,nhcp) CALL energy(itimes,constant,simpar,struc,thermo,nhcp) END SELECT + + CALL timestop ( zero, handle ) END SUBROUTINE velocity_verlet @@ -110,20 +118,20 @@ END SUBROUTINE velocity_verlet ! call this subroutine before the first call to energy or velocity_verlet ! or if you want to change ionode and/or output files -SUBROUTINE set_integrator ( ion, group, iw, mdio ) +SUBROUTINE set_integrator ( globenv, mdio ) IMPLICIT NONE ! Arguments - LOGICAL, INTENT (IN) :: ion - INTEGER, INTENT (IN) :: group - INTEGER, INTENT (IN) :: iw TYPE(mdio_parameters_type), INTENT (IN) :: mdio + TYPE ( global_environment_type ), INTENT (IN) :: globenv !------------------------------------------------------------------------------ - ionode = ion - int_group = group - scr = iw + intenv = globenv + + ionode = globenv % ionode + int_group = globenv % group + scr = globenv % scr crd_file_name = mdio % crd_file_name vel_file_name = mdio % vel_file_name @@ -140,12 +148,6 @@ SUBROUTINE set_integrator ( ion, group, iw, mdio ) idump = mdio % idump iscreen = mdio % iscreen - crd = get_unit() - vel = get_unit() - ptn = get_unit() - ene = get_unit() - tem = get_unit() - END SUBROUTINE set_integrator !****************************************************************************** @@ -197,13 +199,18 @@ SUBROUTINE energy ( itimes, constant, simpar, struc, thermo, nhcp ) !------------------------------------------------------------------------------ - CALL timeset ( 'ENERGY', 'I', ' ', handle ) + CALL timeset ( 'ENERGY', 'E', ' ', handle ) IF ( ionode .AND. itimes == 0 ) THEN + tem = get_unit() OPEN ( UNIT = tem, FILE = temp_file_name ) + ene = get_unit() OPEN ( UNIT = ene, FILE = ener_file_name ) + crd = get_unit() OPEN ( UNIT = crd, FILE = crd_file_name ) + vel = get_unit() OPEN ( UNIT = vel, FILE = vel_file_name ) + ptn = get_unit() OPEN ( UNIT = ptn, FILE = ptens_file_name ) END IF @@ -444,7 +451,7 @@ END SUBROUTINE energy ! nve integrator for particle positions & momenta ! velocity Verlet -SUBROUTINE nve(itimes,constant,simpar,potparm,thermo,struc,ewald_param) +SUBROUTINE nve(itimes,constant,simpar,inter,thermo,struc,ewald_param) IMPLICIT NONE INTEGER, INTENT ( IN ) :: itimes REAL ( dbl ), INTENT ( INOUT ) :: constant @@ -452,7 +459,7 @@ SUBROUTINE nve(itimes,constant,simpar,potparm,thermo,struc,ewald_param) TYPE (thermodynamic_type ), INTENT ( INOUT ) :: thermo TYPE (structure_type ), INTENT ( INOUT ) :: struc TYPE (ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE (potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm + TYPE (interaction_type ), INTENT ( IN ) :: inter INTEGER :: i, nnodes REAL ( dbl ) :: dtom @@ -489,7 +496,7 @@ SUBROUTINE nve(itimes,constant,simpar,potparm,thermo,struc,ewald_param) ! ! get new forces ! - CALL force ( struc, potparm, thermo, simpar, ewald_param ) + CALL force ( struc, inter, thermo, simpar, ewald_param, intenv ) ! ! second half of velocity verlet @@ -519,7 +526,7 @@ END SUBROUTINE nve !****************************************************************************** -SUBROUTINE nvt(itimes,constant,simpar,potparm,thermo,struc, & +SUBROUTINE nvt(itimes,constant,simpar,inter,thermo,struc, & ewald_param,nhcp) IMPLICIT NONE @@ -532,7 +539,7 @@ SUBROUTINE nvt(itimes,constant,simpar,potparm,thermo,struc, & TYPE (structure_type ), INTENT ( INOUT ) :: struc TYPE (extended_parameters_type ), INTENT ( INOUT ) :: nhcp TYPE (ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE (potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm + TYPE (interaction_type ), INTENT ( IN ) :: inter ! Locals INTEGER :: i, nnodes @@ -572,7 +579,7 @@ SUBROUTINE nvt(itimes,constant,simpar,potparm,thermo,struc, & ! ! get new forces ! - CALL force ( struc, potparm, thermo, simpar, ewald_param ) + CALL force ( struc, inter, thermo, simpar, ewald_param, intenv ) ! ! second half of velocity verlet @@ -604,7 +611,7 @@ END SUBROUTINE nvt !****************************************************************************** -SUBROUTINE npt_i ( itimes, constant, simpar, potparm, thermo, struc, & +SUBROUTINE npt_i ( itimes, constant, simpar, inter, thermo, struc, & ewald_param, nhcp ) IMPLICIT NONE @@ -617,7 +624,7 @@ SUBROUTINE npt_i ( itimes, constant, simpar, potparm, thermo, struc, & TYPE (structure_type ), INTENT ( INOUT ) :: struc TYPE (extended_parameters_type ), INTENT ( INOUT ) :: nhcp TYPE (ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE (potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm + TYPE (interaction_type ), INTENT ( IN ) :: inter ! Locals INTEGER :: i, nnodes, iroll @@ -700,7 +707,7 @@ SUBROUTINE npt_i ( itimes, constant, simpar, potparm, thermo, struc, & ! ! get new forces ! - CALL force(struc,potparm,thermo,simpar,ewald_param) + CALL force(struc,inter,thermo,simpar,ewald_param,intenv) ! ! second half of velocity verlet @@ -757,10 +764,13 @@ SUBROUTINE pressure ( pnode, thermo ) TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo ! Locals - INTEGER :: i, j, iatom, nnodes + INTEGER :: i, j, iatom, nnodes, handle + REAL ( dbl ) :: mfl !------------------------------------------------------------------------------ + CALL timeset ( 'PRESSURE', 'E', 'Mflops', handle ) + thermo%pv_kin = 0._dbl nnodes = size(pnode) DO i = 1, 3 @@ -772,6 +782,7 @@ SUBROUTINE pressure ( pnode, thermo ) END DO END DO END DO + mfl = REAL( 9 * nnodes, dbl ) * 2._dbl * 1.e-6_dbl #if defined(__parallel) CALL mp_sum(thermo%pv_kin,int_group) @@ -780,6 +791,8 @@ SUBROUTINE pressure ( pnode, thermo ) ! total virial thermo%ptens = thermo%pv + thermo%pv_kin + thermo%pv_const + CALL timestop ( mfl, handle ) + END SUBROUTINE pressure !****************************************************************************** @@ -794,11 +807,13 @@ SUBROUTINE update_structure(struc,task) ! Locals REAL ( dbl ), ALLOCATABLE, DIMENSION ( :, : ) :: atot - INTEGER :: natoms, ios, imol, atombase, iat, i + INTEGER :: natoms, ios, imol, atombase, iat, i, handle TYPE (linklist_atoms), POINTER :: current_atom !------------------------------------------------------------------------------ + CALL timeset ( 'UPDATE_STRUCTURE', 'E', ' ', handle ) + natoms = size(struc%part) ALLOCATE (atot(3,natoms),STAT=ios) IF ( ios /= 0 ) CALL stop_memory ( 'update_structure', 'atot', 3 * natoms ) @@ -840,6 +855,8 @@ SUBROUTINE update_structure(struc,task) DEALLOCATE ( atot, STAT = ios ) IF ( ios /= 0 ) CALL stop_memory ( 'update_structure', 'atot' ) + + CALL timestop ( zero, handle ) END SUBROUTINE update_structure @@ -910,7 +927,7 @@ END SUBROUTINE set !****************************************************************************** -SUBROUTINE npt_f ( itimes, constant, simpar, potparm, thermo, struc, & +SUBROUTINE npt_f ( itimes, constant, simpar, inter, thermo, struc, & ewald_param, nhcp ) IMPLICIT NONE @@ -923,7 +940,7 @@ SUBROUTINE npt_f ( itimes, constant, simpar, potparm, thermo, struc, & TYPE (structure_type ), INTENT ( INOUT ) :: struc TYPE (extended_parameters_type ), INTENT ( INOUT ) :: nhcp TYPE (ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE (potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm + TYPE (interaction_type ), INTENT ( IN ) :: inter ! Locals INTEGER :: i, j, nnodes, iroll @@ -1009,7 +1026,7 @@ SUBROUTINE npt_f ( itimes, constant, simpar, potparm, thermo, struc, & ! ! get new forces ! - CALL force ( struc, potparm, thermo, simpar, ewald_param ) + CALL force ( struc, inter, thermo, simpar, ewald_param, intenv ) ! ! second half of velocity verlet diff --git a/src/k290.F b/src/k290.F new file mode 100644 index 0000000000..f79ae525b2 --- /dev/null +++ b/src/k290.F @@ -0,0 +1,2773 @@ +!------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!------------------------------------------------------------------------------! +! invmat uses lapack routines --> should be handled by a more general f95 +! interface +! + MODULE k290 +! +!------------------------------------------------------------------------------! + USE kinds, ONLY : dbl + USE stop_program, ONLY : stop_prg, stop_memory + USE string_utilities, ONLY : xstring + USE timings, ONLY : timeset, timestop +! + IMPLICIT NONE +! + PRIVATE +! + PUBLIC :: set_k290, set_k290_atoms, kp_sym_gen +! + INTEGER :: plevel = 0, istriz = -1 + INTEGER :: punit = 6 + INTEGER :: nat, nsp, iq1, iq2, iq3, nkpoint, ntvec + REAL (dbl), DIMENSION (:,:), ALLOCATABLE :: xkappa + INTEGER, DIMENSION (:), ALLOCATABLE :: ty + REAL (dbl) :: a1(3), a2(3), a3(3), alat + REAL (dbl) :: strain(3,3) = 0._dbl, wvk0(3) = 0._dbl + REAL (dbl) :: delta = 1.E-6_dbl +!------------------------------------------------------------------------------! +! + CONTAINS +! +!------------------------------------------------------------------------------! + SUBROUTINE kp_sym_gen + + IMPLICIT NONE + + INTEGER :: iout, isos, nhash, handle + REAL (dbl), ALLOCATABLE :: rx(:,:), tvec(:,:), wvkl(:,:), rlist(:,:) + INTEGER, ALLOCATABLE :: isc(:), lwght(:), lrot(:,:), includ(:), & + list(:), f0(:,:) + + CALL timeset ( 'K290','I',' ',handle ) + + IF (plevel<0) THEN + iout = plevel + ELSE + iout = punit + END IF + nkpoint = iq1*iq2*iq3 +!..allocate intermediate arrays + ALLOCATE (rx(3,nat),STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','rx',3*nat) + ALLOCATE (tvec(3,nat),STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','tvec',3*nat) + ALLOCATE (isc(nat),STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','isc',nat) + ALLOCATE (f0(49,nat),STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','f0',49*nat) + ALLOCATE (wvkl(3,nkpoint),STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','wvkl',3*nkpoint) + ALLOCATE (lwght(nkpoint),STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','lwght',nkpoint) + ALLOCATE (lrot(48,nkpoint),STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','lrot',48*nkpoint) + ALLOCATE (includ(nkpoint),STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','includ',nkpoint) + nhash = max(2000,nkpoint/10) + ALLOCATE (list(nkpoint+nhash),STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','list',nkpoint+nhash) + ALLOCATE (rlist(3,nkpoint),STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','rlist',3*nkpoint) +!..calculate symmetry operations and generate kpoints + CALL k290prg(iout,nat,nkpoint,nsp,iq1,iq2,iq3,istriz,a1,a2,a3,alat, & + strain,xkappa,rx,tvec,ty,isc,f0,ntvec,wvk0,wvkl,lwght,lrot,nhash, & + includ,list,rlist,delta) +!..deallocate intermediate arrays + DEALLOCATE (rx,STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','rx') + DEALLOCATE (tvec,STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','tvec') + DEALLOCATE (isc,STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','isc') + DEALLOCATE (f0,STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','f0') + DEALLOCATE (wvkl,STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','wvkl') + DEALLOCATE (lwght,STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','lwght') + DEALLOCATE (lrot,STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','lrot') + DEALLOCATE (includ,STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','includ') + DEALLOCATE (list,STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','list') + DEALLOCATE (rlist,STAT=isos) + IF (isos/=0) CALL stop_memory('kp_sym_gen','rlist') + + CALL timestop ( 0._dbl, handle ) + + END SUBROUTINE kp_sym_gen + +!------------------------------------------------------------------------------! + + SUBROUTINE set_k290(hmat,nk,shift,stress,symm,del,unit) + + IMPLICIT NONE + + REAL (dbl), INTENT (IN) :: hmat(3,3) + INTEGER, INTENT (IN) :: nk(3) + REAL (dbl), OPTIONAL, INTENT (IN) :: shift(3) + REAL (dbl), OPTIONAL, INTENT (IN) :: stress(3,3) + LOGICAL, OPTIONAL, INTENT (IN) :: symm + REAL (dbl), OPTIONAL, INTENT (IN) :: del + INTEGER, OPTIONAL, INTENT (IN) :: unit + + a1(:) = hmat(:,1) + a2(:) = hmat(:,2) + a3(:) = hmat(:,3) + alat = a1(1) + iq1 = nk(1) + iq2 = nk(2) + iq3 = nk(3) + IF (present(shift)) wvk0 = shift + IF (present(stress)) strain = stress + IF (present(symm)) THEN + istriz = -1 + IF (symm) istriz = 1 + END IF + IF (present(del)) delta = del + IF (present(unit)) THEN + IF (unit>0) THEN + plevel = 0 + punit = unit + ELSE + plevel = -1 + punit = -unit + END IF + END IF + + END SUBROUTINE set_k290 + +!------------------------------------------------------------------------------! + + SUBROUTINE set_k290_atoms(coor,types) + + IMPLICIT NONE + + REAL (dbl), INTENT (IN) :: coor(:,:) + INTEGER, INTENT (IN) :: types(:) + INTEGER :: isos, n + +!..total number of atoms + nat = size(coor(1,:)) +!..allocate arrays for coordinates and atom types + IF (allocated(xkappa)) DEALLOCATE (xkappa) + ALLOCATE (xkappa(3,nat),STAT=isos) + IF (isos/=0) CALL stop_memory('set_k290_atoms','xkappa',3*nat) + IF (allocated(ty)) DEALLOCATE (ty) + ALLOCATE (ty(nat),STAT=isos) + IF (isos/=0) CALL stop_memory('set_k290_atoms','ty',nat) +!..count number of atom types + ty = types + nsp = 0 + DO + n = maxval(ty) + IF (n/=-100) THEN + nsp = nsp + 1 + WHERE (ty==n) ty = -100 + ELSE + EXIT + END IF + END DO +!..copy coordinates and atom types + xkappa = coor + ty = types + + END SUBROUTINE set_k290_atoms + +!------------------------------------------------------------------------------! +! SUPPORT ROUTINES +!------------------------------------------------------------------------------! + SUBROUTINE k290prg(iout,nat,nkpoint,nsp,iq1,iq2,iq3,istriz,a1,a2,a3, & + alat,strain,xkapa,rx,tvec,ty,isc,f0,ntvec,wvk0,wvkl,lwght,lrot, & + nhash,includ,list,rlist,delta) +!------------------------------------------------------------------------------! +! WRITTEN ON SEPTEMBER 12TH, 1979. +! IBM-RETOUCHED ON OCTOBER 27TH, 1980. +! GENERATION OF SPECIAL POINTS MODIFIED ON 26-MAY-82 BY OHN. +! RETOUCHED ON JANUARY 8TH, 1997 +! INTEGRATION IN CPMD-FEMD PROGRAM BY THIERRY DEUTSCH +!------------------------------------------------------------------------------! +! PLAYING WITH SPECIAL POINTS AND CREATION OF 'CRYSTALLOGRAPHIC' +! FILE FOR BAND STRUCTURE CALCULATIONS. +! GENERATION OF SPECIAL POINTS IN K-SPACE FOR AN ARBITRARY LATTICE, +! FOLLOWING THE METHOD MONKHORST,PACK, PHYS. REV. B13 (1976) 5188 +! MODIFIED BY MACDONALD, PHYS. REV. B18 (1978) 5897 +! MODIFIED ALSO BY OLE HOLM NIELSEN ("SYMMETRIZATION") +!------------------------------------------------------------------------------! +! TESTING THEIR EFFICIENCY AND PREPARATION OF THE +! "STRUCTURAL" FILE FOR RUNNING THE +! SELF-CONSISTENT BAND STRUCTURE PROGRAMS. +! IN THE CASES WHERE THE POINT GROUP OF THE CRYSTAL DOES NOT +! CONTAIN INVERSION, THE LATTER IS ARTIFICIALLY ADDED, IN ORDER +! TO MAKE USE OF THE HERMITICITY OF THE HAMILTONIAN +!------------------------------------------------------------------------------! +! INPUT: +! IOUT LOGIC FILE NUMBER +! NAT NUMBER OF ATOMS +! NKPOINT MAXIMAL NUMBER OF K POINTS +! NSP NUMBER OF SPECIES +! IQ1,IQ2,IQ3 THE MONKHORST-PACK MESH PARAMETERS +! ISTRIZ SWITCH FOR SYMMETRIZATION +! A1(3),A2(3),A3(3) LATTICE VECTORS +! ALAT LATTICE CONSTANT +! STRAIN(3,3) STRAIN APPLIED TO LATTICE IN ORDER +! TO HAVE K POINTS WITH SYMMETRY OF STRAINED LATTICE +! XKAPA(3,NAT) ATOMS COORDINATES +! TY(NAT) TYPES OF ATOMS +! WVK0(3) SHIFT FOR K POINTS MESh (MACDONALD ARTICLE) +! NHASH SIZE OF THE HASH TABLES (LIST) +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +! K-VECTOR < DELTA IS CONSIDERED ZERO +! OUTPUT: +! RX(3,NAT) SCRATCH ARRAY USED BY GROUP1 ROUTINE +! TVEC(1:3,1:NTVEC) TRANSLATION VECTORS (SEE NTVEC) +! ISC(NAT) SCRATCH ARRAY USED BY GROUP1 ROUTINE +! F0(49,NAT) ATOM TRANSFORMATION TABLE +! IF NTVEC/=1 THE 49TH GIVES INEQUIVALENT ATOMS +! NTVEC NUMBER OF TRANSLATION VECTORS (IF NOT PRIMITIVE CELL) +! WVKL(3,NKPOINT) SPECIAL KPOINTS GENERATED +! LWGHT(NKPOINT) WEIGHT FOR EACH K POINT +! LROT(48,NKPOINT) SYMMETRY OPERATION FOR EACh K POINTS +! INCLUD(NKPOINT) SCRATCH ARRAY USED BY SPPT2 +! LIST(NKPOINT+NHASH) HASH TABLE USED BY SPPT2 +! RLIST(3,NKPOINT) SCRATCH ARRAY USED BY SPPT2 +!------------------------------------------------------------------------------! +! SUBROUTINES NEEDED: +! SPPT2, GROUP1, PGL1, ATFTM1, ROT1, STRUCT, +! BZRDUC, INBZ, MESH, BZDEFI +! (GROUP1, PGL1, ATFTM1, ROT1 FROM THE +! "COMPUTER PHYSICS COMMUNICATIONS" PACKAGE "ACMI" - (1971,1974) +! WORLTON-WARREN). +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: iout, nat, nkpoint, nsp, nhash, iq1, iq2, iq3, istriz, & + ntvec, ty(nat), isc(nat), f0(49,nat), lwght(nkpoint), & + lrot(48,nkpoint), includ(nkpoint), list(nkpoint+nhash) + REAL (dbl) :: a1(3), a2(3), a3(3), alat, strain(6), xkapa(3,nat), & + rx(3,nat), tvec(3,nat), wvk0(3), wvkl(3,nkpoint), rlist(3,nkpoint), & + delta +!------------------------------------------------------------------------------! +! Variables + INTEGER :: ib0(48), ib(48), i, istrin, itype, ihg, ihc, isy, li, nc, & + indpg, j, invadd, k, ihg0, ihc0, isy0, li0, nc0, indpg0, ntvec0, n, & + ntot, iswght, l, lmax + REAL (dbl) :: r(3,3,48), b1(3), b2(3), b3(3), origin(3), origin0(3), & + vv0(3), a01(3), a02(3), a03(3), b01(3), b02(3), b03(3), tvec0(3,1), & + r0(3,3,48), totstr, volum, proj1, proj2, proj3, dtotstr +!------------------------------------------------------------------------------! +! Constants + INTEGER :: f00(49,1) = 0 + REAL (dbl) :: v(3,48) = 0._dbl, v0(3,48) = 0._dbl, x0(3,1) = 0._dbl + CHARACTER (len=12) :: icst(7) = (/ ' TRICLINIC', ' MONOCLINIC', & + 'ORTHORHOMBIC', ' TETRAGONAL', ' CUBIC', ' TRIGONAL', & + ' HEXAGONAL'/) +! Name of 48 rotations (convention Warren-Worlton) + CHARACTER (len=10) :: rname_cubic(48) = (/ ' 1 ', ' 2[ 1 0 0]', & + ' 2[ 0 1 0]', ' 2[ 0 0 1]', ' 3[-1-1-1]', ' 3[ 1 1-1]', & + ' 3[-1 1 1]', ' 3[ 1-1 1]', ' 3[ 1 1 1]', ' 3[-1 1-1]', & + ' 3[-1-1 1]', ' 3[ 1-1-1]', ' 2[-1 1 0]', ' 4[ 0 0 1]', & + ' 4[ 0 0-1]', ' 2[ 1 1 0]', ' 2[ 0-1 1]', ' 2[ 0 1 1]', & + ' 4[ 1 0 0]', ' 4[-1 0 0]', ' 2[-1 0 1]', ' 4[ 0-1 0]', & + ' 2[ 1 0 1]', ' 4[ 0 1 0]', '-1 ', '-2[ 1 0 0]', & + '-2[ 0 1 0]', '-2[ 0 0 1]', '-3[-1-1-1]', '-3[ 1 1-1]', & + '-3[-1 1 1]', '-3[ 1-1 1]', '-3[ 1 1 1]', '-3[-1 1-1]', & + '-3[-1-1 1]', '-3[ 1-1-1]', '-2[-1 1 0]', '-4[ 0 0 1]', & + '-4[ 0 0-1]', '-2[ 1 1 0]', '-2[ 0-1 1]', '-2[ 0 1 1]', & + '-4[ 1 0 0]', '-4[-1 0 0]', '-2[-1 0 1]', '-4[ 0-1 0]', & + '-2[ 1 0 1]', '-4[ 0 1 0]'/) + CHARACTER (len=11) :: rname_hexa(24) = (/ ' 1 ', & + ' 6[ 0 0. 1]', ' 3[ 0 0. 1]', ' 2[ 0 0. 1]', ' 3[ 0 0.-1]', & + ' 6[ 0 0.-1]', ' 2[ 0 1. 0]', ' 2[-1 1. 0]', ' 2[ 1 0. 0]', & + ' 2[ 2 1. 0]', ' 2[ 1 1. 0]', ' 2[ 1 2. 0]', '-1 ', & + '-6[ 0 0. 1]', '-3[ 0 0. 1]', '-2[ 0 0. 1]', '-3[ 0 0.-1]', & + '-6[ 0 0.-1]', '-2[ 0 1. 0]', '-2[-1 1. 0]', '-2[ 1 0. 0]', & + '-2[ 2 1. 0]', '-2[ 1 1. 0]', '-2[ 1 2. 0]'/) +!------------------------------------------------------------------------------! +! read in lattice structure +!------------------------------------------------------------------------------! + DO i = 1, 3 + a01(i) = a1(i)/alat + a02(i) = a2(i)/alat + a03(i) = a3(i)/alat + END DO +!------------------------------------------------------------------------------! +! is the strain significant ? +!------------------------------------------------------------------------------! + dtotstr = delta*delta + totstr = 0._dbl + istrin = 0 + DO i = 1, 6 + totstr = totstr + abs(strain(i)) + END DO + IF (totstr>dtotstr) istrin = 1 +!------------------------------------------------------------------------------! +! Volume of the cell. + volum = a1(1)*a2(2)*a3(3) + a2(1)*a3(2)*a1(3) + a3(1)*a1(2)*a2(3) - & + a1(3)*a2(2)*a3(1) - a2(3)*a3(2)*a1(1) - a3(3)*a1(2)*a2(1) + volum = abs(volum) + b1(1) = (a2(2)*a3(3)-a2(3)*a3(2))/volum + b1(2) = (a2(3)*a3(1)-a2(1)*a3(3))/volum + b1(3) = (a2(1)*a3(2)-a2(2)*a3(1))/volum + b2(1) = (a3(2)*a1(3)-a3(3)*a1(2))/volum + b2(2) = (a3(3)*a1(1)-a3(1)*a1(3))/volum + b2(3) = (a3(1)*a1(2)-a3(2)*a1(1))/volum + b3(1) = (a1(2)*a2(3)-a1(3)*a2(2))/volum + b3(2) = (a1(3)*a2(1)-a1(1)*a2(3))/volum + b3(3) = (a1(1)*a2(2)-a1(2)*a2(1))/volum +!------------------------------------------------------------------------------! +! GROUP-THEORY ANALYSIS OF LATTICE +!------------------------------------------------------------------------------! + CALL group1(iout,a1,a2,a3,nat,ty,xkapa,b1,b2,b3,ihg,ihc,isy,li,nc, & + indpg,ib,ntvec,v,f0,r,tvec,origin,rx,isc,delta) +!------------------------------------------------------------------------------! + DO n = nc + 1, 48 + ib(n) = 0 + END DO +!------------------------------------------------------------------------------! + invadd = 0 + IF (li==0 .AND. iout>0) THEN + WRITE (iout,'(A)') & + ' K290| Although the point group of the crystal does not' + WRITE (iout,'(A,A)') ' K290| contain inversion, ', & + 'the special point generation algorithm' + WRITE (iout,'(A)') ' K290| will consider it as a symmetry operation' + invadd = 1 + END IF + IF (iout>0) THEN +!------------------------------------------------------------------------------! +! GROUP-THEORETICAL INFORMATION +!------------------------------------------------------------------------------! + WRITE (iout,'(/," K290| Group-theoretical information:")') +! IHG .... Point group of the primitive lattice, holohedral + WRITE (iout, '(A,T62,A,A)') & + " Point group of the primitive lattice: ",& + adjustr(icst(ihg))," system" +! IHC .... Code distinguishing between hexagonal and cubic groups +! ISY .... Code indicating whether the space group is symmorphic + IF (isy==0) THEN + WRITE (iout,'(T62,"nonsymmorphic group")') + ELSE IF (isy==1) THEN + WRITE (iout,'(T65,"symmorphic group")') + ELSE IF (isy==-1) THEN + WRITE (iout,'(T40,"symmorphic group with non-standard origin")') + ELSE IF (isy==-2) THEN + WRITE (iout,'(T59,"nonsymmorphic group???")') + END IF +! LI ..... Inversions symmetry + IF (li==0) THEN + WRITE (iout,'(T60,"no inversion symmetry")') + ELSE IF (li>0) THEN + WRITE (iout,'(T63,"inversion symmetry")') + END IF +! NC ..... Total number of elements in the point group + WRITE (iout,'(7X,A,T78,I3)') & + "Total number of elements in the point group:",nc + WRITE (iout,'(7X,"to sum up: (",T64,I1,5I3,")")') & + ihg, ihc, isy, li, nc, indpg +! IB ..... List of the rotations constituting the point group + WRITE (iout,'(/,7X,"List of the rotations:")') + WRITE (iout,'(7X,T33,12I4)') (ib(i),i=1,nc) +! V ...... Nonprimitive translations (for nonsymmorphic groups) + IF (isy<=0) THEN + WRITE (iout,'(/,7X,"Nonprimitive translations:")') + WRITE (iout,'(A,A)') ' ROT V in the basis A1, A2, A3 ', & + 'V in cartesian coordinates' +! Cartesian components of nonprimitive translation. + DO i = 1, nc + DO j = 1, 3 + vv0(j) = v(1,i)*a1(j) + v(2,i)*a2(j) + v(3,i)*a3(j) + END DO + WRITE (iout,'(7X,I3,3F10.5,3X,3F10.5)') ib(i), (v(j,i),j=1,3), & + vv0 + END DO + END IF +! F0 ..... The function defined in Maradudin, Ipatova by +! eq. (3.2.12): atom transformation table. +! WRITE (iout,'(/,4X,"atom transformation table (Maradudin,Vosko):")') +! WRITE (iout,'(5(4X,"R AT->AT"))') +! WRITE (iout,'(I5," [Identity]")') 1 +! DO k = 2, nc +! DO j = 1, nat +! WRITE (iout,'(I5,2I4,$)') ib(k), j, f0(k,j) +! IF (mod(j,5)==0) WRITE (iout,*) +! END DO +! IF (mod(j-1,5)/=0) WRITE (iout,*) +! END DO +! R ...... List of the 3 x 3 rotation matrices + WRITE (iout,'(/,7X,"List of the 3 X 3 rotation matrices:")') + IF (ihc==0) THEN + DO k = 1, nc + WRITE (iout, & + '(17X,I3," (",I2,": ",A11,")",2(3F14.6,/,38X),3F14.6)') k, & + ib(k), rname_hexa(ib(k)), ((r(i,j,k),j=1,3),i=1,3) + END DO + ELSE + DO k = 1, nc + WRITE (iout, & + '(17X,I3," (",I2,": ",A10,") ",2(3F14.6,/,38X),3F14.6)') k, & + ib(k), rname_cubic(ib(k)), ((r(i,j,k),j=1,3),i=1,3) + END DO + END IF + END IF + IF (abs(iq1)+abs(iq2)+abs(iq3)/=0) THEN +!------------------------------------------------------------------------------! +! GENERATE THE BRAVAIS LATTICE +!------------------------------------------------------------------------------! + WRITE (iout,'(/,1X,20("-"),A,20("-"),/,A)') & + ' The (unstrained) bravais lattice ', & + ' (used for generating the largest possible mesh in the B.Z.)' +!------------------------------------------------------------------------------! + CALL group1(iout,a01,a02,a03,1,ty,x0,b01,b02,b03,ihg0,ihc0,isy0,li0, & + nc0,indpg0,ib0,ntvec0,v0,f00,r0,tvec0,origin0,rx,isc,delta) +!------------------------------------------------------------------------------! +! It is assumed that the same 'type' of symmetry operations +! (cubic/hexagonal) will apply to the crystal as well as the Bravais +! lattice. +!------------------------------------------------------------------------------! + WRITE (iout,'(/,1X,19("*"),A,25("*"))') & + ' Generation of special points ' +! Parameter Q of Monkhorst and Pack, generalized for 3 axes B1,2,3 + WRITE (iout,'(A,/,1X,3I5)') & + ' Monkhorst-Pack parameters (generalized) IQ1,IQ2,IQ3:', iq1, iq2, & + iq3 +! WVK0 is the shift of the whole mesh (see Macdonald) + WRITE (iout,'(A,/,1X,3F10.5)') & + ' constant vector shift (MacDonald) of this mesh:', wvk0 + IF (abs(istriz)/=1) THEN + WRITE (iout,'(" invalid switch for symmetrization",I10)') istriz + WRITE (*,'(" invalid switch for symmetrization",I10)') istriz + CALL stop_prg('K290','istriz wrong argument') + END IF + WRITE (iout,'(" symmetrization switch: ",I3,$)') istriz + IF (istriz==1) THEN + WRITE (iout,'(" (symmetrization of Monkhorst-Pack mesh)")') + ELSE + WRITE (iout,'(" (no symmetrization of Monkhorst-Pack mesh)")') + END IF +! Set to 0. + DO i = 1, nkpoint + lwght(i) = 0 + END DO +!------------------------------------------------------------------------------! +! Generation of the points (they are not multiplied +! by 2*Pi because B1,2,3 were not,either) +!------------------------------------------------------------------------------! + IF (nc>nc0) THEN +! Due to non-use of primitive cell, the crystal has more +! rotations than Bravais lattice. +! We use only the rotations for Bravais lattices + IF (ntvec==1) THEN + WRITE (iout,*) ' K290| Number of rotations for bravais lattice', & + nc0 + WRITE (iout,*) ' K290| Number of rotations for crystal lattice', & + nc + WRITE (iout,*) ' K290| No duplication found' + CALL stop_prg('ERROR', & + 'something is wrong in group determination') + END IF + nc = nc0 + DO i = 1, nc0 + ib(i) = ib0(i) + END DO + WRITE (iout,'(/,1X,20("!"),"WARNING",20("!"))') + WRITE (iout,'(A)') & + ' K290| The crystal has more symmetry than the bravais lattice' + WRITE (iout,'(A)') ' K290| Because this is not a primitive cell' + WRITE (iout,'(A)') ' K290| Use only symmetry from bravais lattice' + WRITE (iout,'(1X,20("!"),"WARNING",20("!"),/)') + END IF + CALL sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a01,a02,a03,b01,b02,b03, & + invadd,nc,ib,r,ntot,wvkl,lwght,lrot,nc0,ib0,istriz,nhash,includ, & + list,rlist,delta) +!------------------------------------------------------------------------------! +! Check on error signals +!------------------------------------------------------------------------------! + WRITE (iout,'(/,1X,I5," Special points generated")') ntot + IF (ntot/=0) THEN + IF (ntot<0) THEN + WRITE (iout,'(A,I5,/,A,/,A)') ' Dimension nkpoint =', nkpoint, & + ' insufficient for accommodating all the special points', & + ' what follows is an incomplete list' + ntot = iabs(ntot) + END IF +! Before using the list WVKL as wave vectors, they have to be +! multiplied by 2*Pi +! The list of weights LWGHT is not normalized + iswght = 0 + DO i = 1, ntot + iswght = iswght + lwght(i) + END DO + WRITE (iout,'(8X,A,T33,A,4X,A)') 'WAVEVECTOR K', 'WEIGHT', & + 'UNFOLDING ROTATIONS' +! Set near-zeroes equal to zero: + DO l = 1, ntot + DO i = 1, 3 + IF (abs(wvkl(i,l))1) THEN +! All rotations found by PGL1 have axes in x, y or z cart. axis +! So we have too check if we do not loose symmetry + ncprim = nc +! The hexagonal system is found if the z axis is the sixfold axis + CALL pgl1(a,ai,ihc,nc,ib,ihg,r,delta) + IF (ncprim>nc) THEN +! More symmetry with + CALL pgl1(ap,api,ihc,nc,ib,ihg,r,delta) + END IF + END IF +!------------------------------------------------------------------------------! +! Determination of the space group + CALL atftm1(iout,r,v,x,f0,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec,a,ai, & + li,isy,isc,delta) +!------------------------------------------------------------------------------! + IF (iout>0) THEN + IF (li>0) THEN + WRITE (iout,'(A)') & + ' K290| The point group of the crystal contains the inversion' + END IF + END IF + END SUBROUTINE group1 +!------------------------------------------------------------------------------! + SUBROUTINE calbrec(a,ai) +!------------------------------------------------------------------------------! +! CALCULATE RECIPROCAL VECTOR BASIS (AI(1:3,1:3)) +! INPUT: +! A(3,3) A(I,J) IS THE I-TH CARTESIAN COMPONENT +! OF THE J-TH PRIMITIVE TRANSLATION VECTOR OF +! THE DIRECT LATTICE +! OUTPUT: +! AI(3,3) RECIPROCAL VECTOR BASIS +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + REAL (dbl) :: a(3,3), ai(3,3) +! Variables + REAL (dbl) :: det + INTEGER :: i, il, iu, j, jl, ju +!------------------------------------------------------------------------------! + det = a(1,1)*a(2,2)*a(3,3) + a(2,1)*a(1,3)*a(3,2) + & + a(3,1)*a(1,2)*a(2,3) - a(1,1)*a(2,3)*a(3,2) - a(2,1)*a(1,2)*a(3,3) - & + a(3,1)*a(1,3)*a(2,2) + det = 1.E0_dbl/det + DO i = 1, 3 + il = 1 + iu = 3 + IF (i==1) il = 2 + IF (i==3) iu = 2 + DO j = 1, 3 + jl = 1 + ju = 3 + IF (j==1) jl = 2 + IF (j==3) ju = 2 + ai(j,i) = (-1._dbl)**(i+j)*det*(a(il,jl)*a(iu,ju)-a(il,ju)*a(iu,jl & + )) + END DO + END DO +!------------------------------------------------------------------------------! + END SUBROUTINE calbrec +!------------------------------------------------------------------------------! + SUBROUTINE primlatt(a,ai,ap,api,nat,ty,x,ntvec,tvec,f0,isc,delta) +!------------------------------------------------------------------------------! +! DETERMINATION OF THE TRANSLATION VECTORS ASSOCIATED WITH +! THE IDENTITY SYMMETRY I.E. IF THE CELL IS DUPLICATED +! GIVE ALSO THE PRIMITIVE DIRECT AND RECIPROCAL LATTICE VECTOR +!------------------------------------------------------------------------------! +! INPUT: +! A(3,3) A(I,J) IS THE I-TH CARTESIAN COMPONENT +! OF THE J-TH TRANSLATION VECTOR OF +! THE DIRECT LATTICE +! AI(3,3) RECIPROCAL VECTOR BASIS (CARTESIAN) +! NAT NUMBER OF ATOMS +! TY(NAT) TYPE OF ATOMS +! X(3,NAT) ATOMIC COORDINATES IN CARTESIAN COORDINATES +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +! OUTPUT: +! AP(3,3) COMPONENTS OF THE PRIMITIVE TRANSLATION VECTORS +! API(3,3) PRIMITIVE RECIPROCAL BASIS VECTORS +! BOTH BAISI ARE IN CARTESIAN COORDINATES +! NTVEC NUMBER OF TRANSLATION VECTORS (FRACTIONNAL) +! TVEC(3,NTVEC) COMPONENTS OF TRANSLATIONAL VECTORS +! (CRYSTAL COORDINATES) +! F0(49,NAT) GIVES INEQUIVALENT ATOM FOR EACH ATOM +! THE 49-TH LINE +! ISC(NAT) SCRATCH ARRAY +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: nat, ntvec, ty(nat), f0(49,nat), isc(nat) + REAL (dbl) :: a(3,3), ai(3,3), ap(3,3), api(3,3), x(3,nat), & + tvec(3,nat), delta +! Variables + INTEGER :: i, j, k2, il, iv + REAL (dbl) :: xb(3), vr(3) + LOGICAL :: oksym +!------------------------------------------------------------------------------! +! First we check if there exist fractional translational vectors +! associated with Identity operation i.e. +! if the cell is duplicated or not. + ntvec = 1 + tvec(1,1) = 0._dbl + tvec(2,1) = 0._dbl + tvec(3,1) = 0._dbl + DO i = 1, nat + f0(49,i) = i + END DO + DO k2 = 2, nat + IF (ty(1)/=ty(k2)) GO TO 100 + DO i = 1, 3 + xb(i) = x(i,k2) - x(i,1) + END DO +! A fractional translation vector VR is defined. + CALL rlv3(ai,xb,vr,il,delta) + CALL checkrlv3(1,nat,ty,x,x,vr,f0,ai,isc,.TRUE.,oksym,delta) + IF (oksym) THEN +! A fractional translational vector is found + ntvec = ntvec + 1 +! F0(49,1:NAT) gives number of equivalent atoms +! and has atom indexes of inequivalent atoms (for translation) + DO i = 1, nat + IF (f0(49,i)>f0(1,i)) f0(49,i) = f0(1,i) + END DO + DO i = 1, 3 + tvec(i,ntvec) = vr(i) + END DO + END IF +100 CONTINUE + END DO +!------------------------------------------------------------------------------! + DO i = 1, 3 + DO il = 1, 3 + ap(il,i) = a(il,i) + END DO + END DO + DO j = 1, 3 + DO i = 1, 3 + api(i,j) = ai(i,j) + END DO + END DO + IF (ntvec==1) THEN +! The current cell is definitely a primitive one +! Copy A and AI to AP and API + ELSE +! We are looking for the primitive lattice vector basis set +! AP is our current lattice vector basis + DO iv = 2, ntvec +! TVEC in cartesian coordinates + DO i = 1, 3 + xb(i) = tvec(1,iv)*a(i,1) + tvec(2,iv)*a(i,2) + & + tvec(3,iv)*a(i,3) + END DO +! We calculare TVEC in AP basis + CALL rlv3(api,xb,vr,il,delta) + DO i = 1, 3 + IF (abs(vr(i))>delta) THEN + il = nint(1._dbl/abs(vr(i))) + IF (il>1) THEN +! We replace AP(1:3,I) by TVEC(1:3,IV) + DO j = 1, 3 + ap(j,i) = xb(j) + END DO +! Calculate new API + CALL calbrec(ap,api) + GO TO 200 + END IF + END IF + END DO +200 CONTINUE + END DO + END IF + END SUBROUTINE primlatt +!------------------------------------------------------------------------------! + SUBROUTINE pgl1(a,ai,ihc,nc,ib,ihg,r,delta) +!------------------------------------------------------------------------------! +! WRITTEN ON SEPTEMBER 11TH, 1979 - FROM ACMI COMPLEX +! AUXILIARY SUBROUTINE TO GROUP1 +! SUBROUTINE PGL DETERMINES THE POINT GROUP OF THE LATTICE +! AND THE CRYSTAL SYSTEM. +! SUBROUTINES NEEDED: ROT1, RLV3 +!------------------------------------------------------------------------------! +! WARNING: FOR THE HEXAGONAL SYSTEM, THE 3RD AXIS SUPPOSE +! TO BE THE SIX-FOLD AXIS +!------------------------------------------------------------------------------! +! INPUT: +! A ..... DIRECT LATTICE VECTORS +! AI .... RECIPROCAL LATTICE VECTORS +! DELTA.. REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +!------------------------------------------------------------------------------! +! OUTPUT: +! IHC .... CODE DISTINGUISHING BETWEEN HEXAGONAL AND CUBIC +! GROUPS +! IHC=0 STANDS FOR HEXAGONAL GROUPS +! IHC=1 STANDS FOR CUBIC GROUPS +! NC .... NUMBER OF ROTATIONS IN THE POINT GROUP +! IB .... SET OF ROTATION +! IHG .... POINT GROUP OF THE PRIMITIVE LATTICE, HOLOHEDRAL +! GROUP NUMBER: +! IHG=1 STANDS FOR TRICLINIC SYSTEM +! IHG=2 STANDS FOR MONOCLINIC SYSTEM +! IHG=3 STANDS FOR ORTHORHOMBIC SYSTEM +! IHG=4 STANDS FOR TETRAGONAL SYSTEM +! IHG=5 STANDS FOR CUBIC SYSTEM +! IHG=6 STANDS FOR TRIGONAL SYSTEM +! IHG=7 STANDS FOR HEXAGONAL SYSTEM +! R ...... LIST OF THE 3 X 3 ROTATION MATRICES +! (XYZ REPRESENTATION OF THE O(H) OR D(6)H GROUPS) +! ALL 48 OR 24 MATRICES ARE LISTED. +! FOLLOW NOTATION OF WORLTON-WARREN(1972) +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: ihc, nc, ihg, ib(48) + REAL (dbl) :: a(3,3), ai(3,3), r(3,3,48), delta +!------------------------------------------------------------------------------! +! Variables + REAL (dbl) :: vr(3), xa(3), tr + INTEGER :: nr, n, k, i, j, lx +!------------------------------------------------------------------------------! + DO ihc = 0, 1 +! IHC is 0 for hexagonal groups and 1 for cubic groups. + IF (ihc==0) THEN + nr = 24 + ELSE + nr = 48 + END IF +100 CONTINUE + nc = 0 +! Constructs rotation operations. + CALL rot1(ihc,r) + DO n = 1, nr + ib(n) = 0 +! Rotate the A1,2,3 vectors by rotation No. N + DO k = 1, 3 + DO i = 1, 3 + xa(i) = 0._dbl + DO j = 1, 3 + xa(i) = xa(i) + r(i,j,n)*a(j,k) + END DO + END DO + CALL rlv3(ai,xa,vr,lx,delta) + tr = 0._dbl + DO i = 1, 3 + tr = tr + abs(vr(i)) + END DO +! If VR.ne.0, then XA cannot be a multiple of a lattice vector + IF (tr>delta) GO TO 140 + END DO + nc = nc + 1 + ib(nc) = n +140 CONTINUE + END DO +!------------------------------------------------------------------------------! +! IHG stands for holohedral group number. + IF (ihc==0) THEN +! Hexagonal group: + IF (nc==12) ihg = 6 + IF (nc>12) ihg = 7 + IF (nc>=12) RETURN +! Too few operations, try cubic group: (IHC=1,NR=48) + ELSE +! Cubic group: + IF (nc<4) ihg = 1 + IF (nc==4) ihg = 2 + IF (nc>4) ihg = 3 + IF (nc==16) ihg = 4 + IF (nc>16) ihg = 5 + RETURN + END IF + END DO + END SUBROUTINE pgl1 +!------------------------------------------------------------------------------! + SUBROUTINE rlv3(ai,xb,vr,il,delta) +!------------------------------------------------------------------------------! +! WRITTEN ON SEPTEMBER 11TH, 1979 - FROM ACMI COMPLEX +! AUXILIARY SUBROUTINE TO GROUP1 +! SUBROUTINE RLV REMOVES A DIRECT LATTICE VECTOR +! FROM XB LEAVING THE REMAINDER IN VR. +! IF A NONZERO LATTICE VECTOR WAS REMOVED, IL IS MADE NONZERO. +! VR STANDS FOR V-REFERENCE. +!------------------------------------------------------------------------------! +! INPUT: +! AI(I,J) ARE THE RECIPROCAL LATTICE VECTORS, +! B(I) = AI(I,J),J=1,2,3 +! XB(1:3) VECTOR IN CARTESIAN COORDINATES +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +! OUTPUT: +! VR IS NOT GIVEN IN CARTESIAN COORDINATES BUT +! IN THE SYSTEM A1,A2,A3 (CRYSTAL COORDINATES) +! AND BETWEEN -1/2 AND 1/2 +! IL ABS OF VR +! K.K., 23.10.1979 +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: il + REAL (dbl) :: ai(3,3), xb(3), vr(3), delta +! Variables + REAL (dbl) :: ts + INTEGER :: i, j +!------------------------------------------------------------------------------! + il = 0 + DO i = 1, 3 + vr(i) = 0._dbl + END DO + ts = abs(xb(1)) + abs(xb(2)) + abs(xb(3)) + IF (ts<=delta) RETURN + DO i = 1, 3 + DO j = 1, 3 + vr(i) = vr(i) + ai(i,j)*xb(j) + END DO + il = il + nint(abs(vr(i))) +! Change in order to have correct determination of origin and +! symmorphic group (T.D 30/03/98) +! VR(I) = - MOD(DBLE(VR(I)),1._dbl) + vr(i) = nint(vr(i)) - vr(i) + END DO + END SUBROUTINE rlv3 +!------------------------------------------------------------------------------! + SUBROUTINE atftm1(iout,r,v,x,f0,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec, & + a,ai,li,isy,isc,delta) +!------------------------------------------------------------------------------! +! WRITTEN ON SEPTEMBER 11TH, 1979 - FROM ACMI COMPLEX +! AUXILIARY SUBROUTINE TO GROUP1 +! SUBROUTINE ATFTMT DETERMINES +! THE POINT GROUP OF THE CRYSTAL, +! THE ATOM TRANSFORMATION TABLE,F0, +! THE FRACTIONAL TRANSLATIONS,V, +! ASSOCIATED WITH EACH ROTATION. +! SUBROUTINES NEEDED: RLV3 CHECKRLV3 SYMMORPHIC STOPGM XSTRING +! MAY 14TH,1998: A LOT OF CHANGES (ARGUMENTS) +! BETTER DETERMINATION OF V +! SEP 15TH,1998: DETERMINATION OF FRACTIONAL TRANSLATIONAL VEC. +!------------------------------------------------------------------------------! +! INPUT: +! IOUT Logical file number (output) +! If IOUT.LE.0 no message +! IHG Holohedral group number (determined by PGL1) +! NC Number of rotation operations +! NAT Number of atoms (used in the routine) +! X Coordinates of atoms (cartesian) +! TY Type of atoms +! R Sets of transformation operations (cartesian) +! IB Index giving NC operations in R +! AI Reciprocal lattice vectors +! NTVEC Number of translational vectors +! associated with Identity +! if primitive cell NTVEC=1, TVEC=(0,0,0) +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +! OUTPUT: +! RX(3,NAT) Scratch array +! ISC(NAT) Scratch array +! NC is modified (number of symmetry operations) +! INDPG Point group index +! V(3,48) The fractional translations associated +! with each rotation (crystal coordinates) +! F0(1:48,NAT) +! The atom transformation table for rotation (48,NAT) +! ORIGIN Standard origin if symmorphic (crystal coordinates) +! ISY = 1 Isommorphic group +! =-1 Isommorphic group with non-standard origin +! = 0 Non-Isommorphic group +! =-2 Undetermined (normally never) +! LI ..... Code indicating whether the point group +! of the crystal contains inversion or not +! (operations 13 or 25 in respectively hexagonal +! or cubic groups). +! LI=0 : does not contain inversion +! LI.GT.0 : there is inversion in the point +! group of the crystal +!------------------------------------------------------------------------------! +! INDPG group indpg group indpg group indpg group +! 1 1 (c1) 9 3m (c3v) 17 4/mmm(d4h) 25 222(d2) +! 2 <1>(ci) 10 <3>m(d3d) 18 6 (c6) 26 mm2(c2v) +! 3 2 (c2) 11 4 (c4) 19 <6>(c3h) 27 mmm(d2h) +! 4 m (c1h) 12 <4>(s4) 20 6/m(c6h) 28 23 (t) +! 5 2/m(c2h) 13 4/m(c4h) 21 622(d6) 29 m3 (th) +! 6 3 (c3) 14 422(d4) 22 6mm(c6v) 30 432(o) +! 7 <3>(c3i) 15 4mm(c4v) 23 <6>m2(d3h) 31 <4>3m(td) +! 8 32 (d3) 16 <4>2m(d2d) 24 6/mmm(d6h) 32 m3m(oh) +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: iout, nat, ihg, nc, indpg, ntvec, isy, ib(48), f0(49,nat), & + ty(nat), isc(nat) + REAL (dbl) :: r(3,3,48), v(3,48), x(3,nat), rx(3,nat), a(3,3), & + ai(3,3), delta +! Variables + INTEGER :: iis(48), nca, n, l, k, i, j, k2, il, ni, li, info + REAL (dbl) :: vr(3), origin(3), xb(3), vc(3,48), vs + LOGICAL :: oksym, nodupli + CHARACTER :: icst(7)*12, pgrp(32)*5, pgrd(32)*3 +!------------------------------------------------------------------------------! + DATA icst/'TRICLINIC', 'MONOCLINIC', 'ORTHORHOMBIC', 'TETRAGONAL', & + 'CUBIC', 'TRIGONAL', 'HEXAGONAL'/ +!------------------------------------------------------------------------------! + DATA pgrp/' 1', ' <1>', ' 2', ' m', ' 2/m', ' 3', & + ' <3>', ' 32', ' 3m', ' <3>m', ' 4', ' <4>', ' 4/m', & + ' 422', ' 4mm', '<4>2m', '4/mmm', ' 6', ' <6>', ' 6/m', & + ' 622', ' 6mm', '<6>m2', '6/mmm', ' 222', ' mm2', ' mmm', & + ' 23', ' m3', ' 432', '<4>3m', ' m3m'/ +!------------------------------------------------------------------------------! + DATA pgrd/'c1 ', 'ci ', 'c2 ', 'c1h', 'c2h', 'c3 ', 'c3i', 'd3 ', & + 'c3v', 'd3 ', 'c4 ', 's4 ', 'c4h', 'd4 ', 'c4v', 'd2d', 'd4h', & + 'c6 ', 'c3h', 'c6h', 'd6 ', 'c6v', 'd3h', 'd6h', 'd2 ', 'c2v', & + 'd2h', 't ', 'th ', 'o ', 'td ', 'oh '/ +!------------------------------------------------------------------------------! + nodupli = ntvec == 1 + nca = 0 + DO n = 1, 48 + iis(n) = 0 + END DO +! Calculate translational vector for each operation +! and atom transformation table. + DO n = 1, nc + l = ib(n) + iis(l) = 1 + DO k = 1, nat + DO i = 1, 3 + rx(i,k) = 0._dbl + DO j = 1, 3 + rx(i,k) = rx(i,k) + r(i,j,l)*x(j,k) + END DO + END DO + END DO + DO k = 1, 3 + vr(k) = 0._dbl + END DO +! First we determine for VR=(/0,0,0/) +! IMPORTANT IF NOT UNIQUE ATOMS FOR DETERMINATION OF SYMMORPHIC + CALL checkrlv3(n,nat,ty,rx,x,vr,f0,ai,isc,nodupli,oksym,delta) + IF (oksym) THEN + GO TO 190 + END IF +! Now we try other possible VR +! F0(49,1:NAT) has only inequivalent atom indexes for translation + DO k2 = 1, nat + IF (f0(49,k2)delta) THEN + isy = 0 + ELSE + isy = 1 + END IF +!------------------------------------------------------------------------------! +! Determination of the point group +! (Thierry Deutsch - 1998 [Maybe not complete!!]) + IF (ihg<6) THEN + IF (nc==0) THEN + WRITE (*,'(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nc + CALL stop_prg('ATFTM1','NUMBER OF ROTATION NULL') +! Triclinic system + ELSE IF (nc==1) THEN +! IB=1 + indpg = & !1 (c1) + 1 + ELSE IF (nc==2 .AND. ib(2)==25) THEN +! IB=1 25 + indpg = & !<1>(ci) + 2 + ELSE IF (nc==2 .AND. (ib(2)==4 .OR. & ! Monoclinic system + ib(2)==2 .OR. & ! IB=1 4 (z-axis) OR + ib(2)==3)) & ! IB=1 2 (x-axis) OR + THEN +! IB=1 3 (y-axis) +!2[001] +!2[100] +!2[010] + indpg = & !2 (c2) + 3 + ELSE IF (nc==2 .AND. (ib(2)==28 .OR. ib(2)==26 .OR. ib(2)==27)) THEN +! IB=1 28 (z-axis) OR +! IB=1 26 (x-axis) OR +! IB=1 27 (y-axis) + indpg = & !m (c1h) + 4 + ELSE IF (nc==4 .AND. (ib(4)==28 .OR. & ! IB=1 4 25 28 (z-axis) OR + ib(4)==27 .OR. & ! IB=1 2 25 26 (x-axis) OR + ib(4)==26 .OR. & ! IB=1 3 25 27 (y-axis) OR + ib(4)==37 .OR. & ! IB=1 13 25 37 (-xy-axis)OR + ib(4)==40)) & ! IB=1 16 25 40 (xy-axis) + THEN +!2[001] +!2[010] +!2[100] +!-2[-110] +!2[110] + indpg = & !2/m(c2h) + 5 + ELSE IF (nc==4 .AND. (ib(4)==15 .OR. ib(4)==20 .OR. ib(4)==24)) THEN +! Tetragonal system +! IB=1 4 14 15 (z-axis) OR +! IB=1 2 19 20 (x-axis) OR +! IB=1 3 22 24 (y-axis) + indpg = & !4 (c4) + 11 + ELSE IF (nc==4 .AND. (ib(4)==39 .OR. ib(4)==44 .OR. ib(4)==48)) THEN +! IB=1 4 38 39 (z-axis) OR +! IB=1 2 43 44 (x-axis) OR +! IB=1 3 46 48 (y-axis) + indpg = & !<4>(s4) + 12 + ELSE IF (nc==8 .AND. ((ib(3)==14 .AND. ib(8)==39) .OR. (ib(3)==19 & + .AND. ib(8)==44) .OR. (ib(3)==22 .AND. ib(8)==48))) THEN +! IB=1 4 14 15 28 25 38 39 (z-axis) OR +! IB=1 2 19 20 26 25 43 44 (x-axis) OR +! IB=1 3 22 24 27 25 46 48 (y-axis) + indpg = & !422(d4) + 13 + ELSE IF (nc==8 .AND. ib(4)==4 .AND. (ib(8)==16 .OR. ib( & + 8)==20 .OR. ib(8)==24)) THEN +! IB=1 2 3 4 13 14 15 16 (z-axis) OR +! IB=1 2 3 4 17 19 20 18 (x-axis) OR +! IB=1 2 3 4 21 22 24 23 (y-axis) + indpg = & !4/m(c4h) + 14 + ELSE IF (nc==8 .AND. (ib(8)==40 .OR. ib(8)==42 .OR. ib(8)==47)) THEN +! IB=1 4 14 15 26 27 37 40 (z-axis) OR +! IB=1 2 19 20 28 27 41 42 (x-axis) OR +! IB=1 3 22 24 26 28 45 47 (y-axis) + indpg = & !4mm(c4v) + 15 + ELSE IF (nc==8 .AND. ((ib(3)==13 .AND. ib(8)==39) .OR. (ib(3)==17 & + .AND. ib(8)==44) .OR. (ib(3)==21 .AND. ib(8)==48))) THEN +! IB=1 4 13 16 26 27 38 39 (z-axis) OR +! IB=1 2 17 18 28 27 43 44 (x-axis) OR +! IB=1 3 21 23 26 28 46 48 (y-axis) + indpg = & !<4>2m(d2d) + 16 + ELSE IF (nc==16 .AND. (ib(16)==40 .OR. ib(16)==44 .OR. ib(16)==48)) & + THEN +! IB=1 2 3 4 13 14 15 16 25 26 27 28 37 38 39 40 (z-axis) OR +! IB=1 2 3 4 17 19 20 18 25 26 27 28 41 43 44 42 (x-axis) OR +! IB=1 2 3 4 21 22 24 23 25 26 27 28 45 46 48 47 (y-axis) + indpg = & !4/mmm(d4h) + 17 + ELSE IF (nc==4 .AND. (ib(4)==4)) THEN +! Orthorhombic system +! IB=1 2 3 4 + indpg = & !222(d2) + 25 + ELSE IF (nc==4 .AND. (ib(4)==27 .OR. ib(4)==28)) THEN +! IB=1 3 26 27 (z-axis) OR +! IB=1 2 27 28 (x-axis) OR +! IB=1 4 26 28 (y-axis) OR + indpg = & !mm2(c2v) + 26 + ELSE IF (nc==8) THEN +! IB=1 2 3 4 25 26 27 28 + indpg = & !mmm(d2h) + 27 + ELSE IF (nc==12 .AND. (ib(12)==12 .OR. ib(12)==47 .OR. ib(12)==45)) & + THEN +! Cubic system +! IB=1 2 3 4 5 6 7 8 9 10 11 12 OR +! IB=1 5 11 13 18 23 25 30 35 37 42 47 OR +! IB=1 8 10 16 18 21 25 32 34 40 42 45 + indpg = & !23 (t) + 28 + ELSE IF (nc==24 .AND. ib(24)==36) THEN +! IB= 1 2 3 4 5 6 7 8 9 10 11 12 +! 25 26 27 28 29 30 31 32 33 34 35 36 + indpg = & !m3 (th) + 29 + ELSE IF (nc==24 .AND. ib(24)==24) THEN +! IB=1 2 3 4 5 6 7 8 9 10 11 12 +! 13 14 15 16 17 18 19 20 21 22 23 24 + indpg = & !432 (o) + 30 + ELSE IF (nc==24 .AND. ib(24)==48) THEN +! IB=1 2 3 4 5 6 7 8 9 10 11 12 +! 37 38 39 40 41 42 43 45 46 47 48 + indpg = & !<4>3m(td) + 31 + ELSE IF (nc==48) THEN +! IB=1..48 + indpg = & !m3m(oh) + 32 + ELSE +! WRITE(*,'(" ATFTM1! IHG=",A," NC=",I2)') ICST(IHG),NC +! WRITE(*,'(" ATFTM1!",19I3)') (IB(I),I=1,NC) +! WRITE(*,'(" ATFTM1! THIS CASE IS UNKNOWN IN THE DATABASE")') +! Probably a sub-group of 32 + indpg = -32 + END IF + ELSE IF (ihg>=6) THEN + IF (nc==0) THEN + WRITE (*,'(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nc + CALL stop_prg('ATFTM1','NUMBER OF ROTATION NULL') +! Triclinic system + ELSE IF (nc==1) THEN +! IB=1 + indpg = & !1 (c1) + 1 + ELSE IF (nc==2 .AND. ib(2)==13) THEN +! IB=1 13 + indpg = & !<1>(ci) + 2 + ELSE IF (nc==2 .AND. (ib(2)==4)) & ! Monoclinic system + THEN +! IB=1 4 +!2[001] + indpg = & !2 (c2) + 3 + ELSE IF (nc==2 .AND. (ib(2)==16)) THEN +! IB=1 16 + indpg = & !m (c1h) + 4 + ELSE IF (nc==4 .AND. (ib(4)==24 .OR. ib(4)==20)) THEN +! IB=1 12 13 24 OR +! IB=1 8 13 20 + indpg = & !2/m(c2h) + 5 + ELSE IF (nc==3 .AND. ib(3)==5) THEN +! Trigonal system +! IB=1 3 5 + indpg = & !3 (c3) + 6 + ELSE IF (nc==6 .AND. ib(6)==17) THEN +! IB=1 13 15 17 35 + indpg = & !<3>(c3i) + 7 + ELSE IF (nc==6 .AND. ib(6)==11) THEN +! IB=1 7 9 11 35 + indpg = & !32 (d3) + 8 + ELSE IF (nc==6 .AND. ib(6)==23) THEN +! IB=1 3 5 19 21 23 + indpg = & !3m (c3v) + 9 + ELSE IF (nc==12 .AND. ib(12)==23) THEN +! IB=1 3 5 7 9 11 13 15 17 19 21 23 + indpg = & !<3>m(d3d) + 10 + ELSE IF (nc==6 .AND. ib(6)==6) THEN +! Hexagonal system +! IB=1 2 3 4 5 6 + indpg = & !6 (c6) + 18 + ELSE IF (nc==6 .AND. ib(6)==18) THEN +! IB=1 3 5 14 16 18 + indpg = & !<6>(c3h) + 19 + ELSE IF (nc==12 .AND. ib(12)==18) THEN +! IB=1 2 3 4 5 6 13 14 15 16 17 18 + indpg = & !6/m(c6h) + 20 + ELSE IF (nc==12 .AND. ib(12)==12) THEN +! IB=1 2 3 4 5 6 7 8 9 10 11 12 + indpg = & !622(d6) + 21 + ELSE IF (nc==12 .AND. ib(2)==2 .AND. ib(12)==24) THEN +! IB=1 2 3 4 5 6 19 20 21 22 23 24 + indpg = & !6mm(c6v) + 22 + ELSE IF (nc==12 .AND. ib(2)==3 .AND. ib(12)==24) THEN +! IB=1 3 5 7 9 11 14 16 18 20 22 24 + indpg = & !<6>m2(d3h) + 23 + ELSE IF (nc==24) THEN +! IB=1..24 + indpg = & !6/mmm(d6h) + 24 + ELSE +! Probably a sub-group of 24 +! WRITE(*,'(" ATFTM1! IHG=",A," NC=",I2)') ICST(IHG),NC +! WRITE(*,'(" ATFTM1!",48I3)') (IB(I),I=1,NC) +! WRITE(*,'(" ATFTM1! THIS CASE IS UNKNOWN IN THE DATABASE")') + indpg = -24 + END IF + END IF +!------------------------------------------------------------------------------! +! Determination if the space group is symmorphic or not +!------------------------------------------------------------------------------! + IF (isy/=1) THEN +! Transform V in cartesian coordinates + DO n = 1, nc + DO i = 1, 3 + vc(i,n) = a(i,1)*v(1,n) + a(i,2)*v(2,n) + a(i,3)*v(3,n) + END DO + END DO + CALL symmorphic(nc,ib,r,vc,ai,info,origin,delta) + IF (info==1) THEN + CALL rlv3(ai,origin,xb,il,delta) +! !!!RLV3 determines -XB in crystal coordinates +! !!We want between 0.0 and 1.0 + DO i = 1, 3 + IF (-xb(i)>=0._dbl) THEN + origin(i) = -xb(i) + ELSE + origin(i) = 1._dbl - xb(i) + END IF + END DO + DO i = 1, 3 + xb(i) = a(i,1)*origin(1) + a(i,2)*origin(2) + a(i,3)*origin(3) + END DO + isy = -1 + ELSE IF (info==0) THEN + isy = 0 + ELSE + isy = -2 + END IF + ELSE + DO i = 1, 3 + origin(i) = 0._dbl + END DO + END IF +!------------------------------------------------------------------------------! +! Output +!------------------------------------------------------------------------------! + IF (iout>0) THEN + WRITE (iout,*) + CALL xstring(icst(ihg),i,j) + IF ((ihg==7 .AND. nc==24) .OR. (ihg==5 .AND. nc==48)) THEN + WRITE (iout,'(A,A,A)') & + ' K290| The point group of the crystal is the full ', & + icst(ihg) (i:j), ' group' + ELSE + WRITE (iout,'(A,A,A,I2,A,/,3(5X,20I3/))') & + ' K290| The crystal system is ', icst(ihg) (i:j), ' with ', nc, & + ' operations:', (ib(i),i=1,nc) + END IF +!------------------------------------------------------------------------------! + IF (isy==1) THEN + WRITE (iout,'(A)') & + ' K290| The space group of the crystal is symmorphic' + ELSE IF (isy==-1) THEN + WRITE (iout,'(A)') & + ' K290| The space group of the crystal is symmorphic' + WRITE (iout,'(A,A,/,T3,3F10.6,3X,3F10.6)') & + ' K290| The standard origin of coordinates is: ', & + '[CARTESIAN] [CRYSTAL]', xb, origin + ELSE IF (isy==0) THEN + WRITE (iout,'(A,/,3X,A,F15.6,A)') & + ' K290| The space group is non-symmorphic,', & + ' (sum of translation vectors=', vs, ')' + ELSE IF (isy==-2) THEN + WRITE (iout,'(A,A)') & + ' K290| Cannot determine if the space group is', & + ' symmorphic or not' + WRITE (iout,'(A,/,A,/,3X,A,F15.6,A)') & + ' K290| The space group is non-symmorphic,', & + ' K290| or else a non standard origin of coordinates was used.', & + ' K290| (sum of translation vectors=', vs, ')' + END IF + IF (indpg>0) THEN + CALL xstring(pgrp(indpg),i,j) + CALL xstring(pgrd(indpg),k,l) + WRITE (iout,'(A,A,"(",A,")",T56,"[INDEX=",I2,"]")') & + ' K290| The point group of the crystal is ', pgrp(indpg) (i:j), & + pgrd(indpg) (k:l), indpg + ELSE + CALL xstring(pgrp(-indpg),i,j) + CALL xstring(pgrd(-indpg),k,l) + WRITE (iout,'(A,I2,T40,A,A,"(",A,")",T71,"[INDEX=",I2,"]")') & + ' K290| Group order=', nc, ' Subgroup of ', & + pgrp(-indpg) (i:j), pgrd(-indpg) (k:l), -indpg + END IF + IF (ntvec==1) THEN + WRITE (iout,'(A,T75,I6)') ' K290| Number of primitive cells:', & + ntvec + END IF + END IF + END SUBROUTINE atftm1 +!------------------------------------------------------------------------------! + SUBROUTINE checkrlv3(n,nat,ty,rx,x,vr,f0,ai,isc,nodupli,oksym,delta) +!------------------------------------------------------------------------------! +! WRITTEN IN MAY 14TH, 1998 (T.D.) +! CHECK IF RX+VR GIVES THE SAME LATTICE AS X +! BUILD THE ATOM TRANSFORMATION TABLE +!------------------------------------------------------------------------------! +! INPUT: +! N ROTATION NUMBER (INDEX USED IN F0 BETWEEN 1 AND 48) +! NAT NUMBER OF ATOMS +! TY(1:NAT) TYPE OF ATOMS +! RX(1:3,1:NAT) ATOMIC COORDINATES FROM Nth ROTATION (CART.) +! X(1:3,1:NAT) ATOMIC COORDINATES (CARTESIAN) +! VR(1:3) TRANSLATION VECTOR (CRYSTAL COOR.) +! AI(1:3,1:3) LATTICE RECIPROCAL VECTORS +! NODUPLI .TRUE., THE CELL IS A PRIMITIVE ONE +! WE CAN SPEED UP +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +! OUTPUT: +! F0(1:49,1:NAT) ATOM TRANSFORMATION TABLE +! F0 IS THE FUNCTION DEFINED IN MARADUDIN AND VOSK0 +! BY EQ.(2.35). +! IT DEFINES THE ATOM TRANSFORMATION TABLE +! OKSYM TRUE IF RX+VR = X +! ISC(1:NAT) SCRATCH ARRAY +! USED TO SPEED UP THE ROUTINE +! EACH ATOM IS ONLY ONCE AN IMAGE +! IF NO DUPLICATION OF THE CELL +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: n, nat, ty(nat), f0(49,nat), isc(nat) + REAL (dbl) :: rx(3,nat), x(3,nat), vr(3), ai(3,3), delta + LOGICAL :: oksym, nodupli +! Variables + REAL (dbl) :: xb(3), vt(3) + INTEGER :: ia, ib, il +!------------------------------------------------------------------------------! + DO ia = 1, nat + isc(ia) = 0 + END DO +! Now we check if ROT(N)+VR gives a correct symmetry. + DO ia = 1, nat + DO ib = 1, nat + IF (ty(ia)==ty(ib) .AND. isc(ib)==0) THEN + xb(1) = rx(1,ia) - x(1,ib) + xb(2) = rx(2,ia) - x(2,ib) + xb(3) = rx(3,ia) - x(3,ib) + CALL rlv3(ai,xb,vt,il,delta) +! VT STANDS FOR V-TEST + oksym = (abs((vr(1)-vt(1))-nint(vr(1)-vt(1)))delta*delta) THEN + DO i = 1, 3 + igood(i) = 1 + END DO +! V is non-zero. Construct matrix 1-R + DO i = 1, 3 + DO j = 1, 3 + r3(i,j) = -r(i,j,ib(ir)) + END DO + r3(i,i) = 1 + r3(i,i) + END DO + CALL invmat(r3(1:3,1:3),ierror) + IF (ierror==0) THEN +! The matrix 3x3 has an inverse. + DO i = 1, 3 + vr(i) = r3(i,1)*v(1,ir) + r3(i,2)*v(2,ir) + r3(i,3)*v(3,ir) + END DO + ELSE +! IERROR gives the column which causes some trouble +! Construct matrix 1-R with 2x2 + igood(ierror) = 0 + imissing3 = ierror + i1 = 0 + DO i = 1, 3 + IF (i/=ierror) THEN + i1 = i1 + 1 + j1 = 0 + DO j = 1, 3 + IF (j/=ierror) THEN + j1 = j1 + 1 + r2(i1,j1) = -r(i,j,ib(ir)) + END IF + END DO + r2(i1,i1) = 1 + r2(i1,i1) + END IF + END DO + CALL invmat(r2(1:2,1:2),ierror) + IF (ierror==0) THEN +! The matrix 2X2 has an inverse. +! Solve Vxy = (1-R).OAxy + OAz R3z (z is IMISSING3) + i1 = 0 + DO i = 1, 3 + IF (igood(i)==1) THEN + i1 = i1 + 1 + vr(i) = 0._dbl + j1 = 0 + DO j = 1, 3 + IF (igood(j)==1) THEN + j1 = j1 + 1 + vr(i) = vr(i) + r2(i1,j1)*(v(j,ir)+origin(imissing3)*r & + (j,imissing3,ib(ir))) + END IF + END DO + ELSE + vr(i) = origin(i) + END IF + END DO + ELSE +! Construct matrix 1-R with 1x1 + i1 = 0 + DO i = 1, 3 + IF (i/=imissing3) THEN + i1 = i1 + 1 + IF (i1==ierror) THEN + igood(i) = 0 + imissing2 = i + ELSE + ionly = i + END IF + END IF + END DO + diag = (1-r(ionly,ionly,ib(ir))) + IF (abs(diag)>delta) THEN + vr(ionly) = 1._dbl/diag*(v(ionly,ir)+origin(imissing3)*r( & + ionly,imissing3,ib(ir))+origin(imissing2)*r(ionly, & + imissing2,ib(ir))) + ELSE + vr(ionly) = origin(ionly) + igood(ionly) = 0 + END IF + vr(imissing3) = origin(imissing3) + vr(imissing2) = origin(imissing2) + END IF + END IF +!------------------------------------------------------------------------------! +! Compare VR with ORIGIN + dif = 0._dbl +! If NTVEC /=1 there are NTVEC possible standard origins + DO i = 1, 3 + IF (iok(i)==1) THEN + dif = dif + abs(origin(i)-vr(i)) + END IF + END DO + IF (dif>delta) THEN +! Non-symmorphic + info = 0 + RETURN + ELSE + DO i = 1, 3 + IF (iok(i)/=1 .AND. igood(i)==1) THEN + iok(i) = 1 + origin(i) = vr(i) + END IF + END DO + END IF + END IF + END DO +!------------------------------------------------------------------------------! + IF (iok(1)==0 .AND. iok(2)==0 .AND. iok(3)==0) THEN +! Cannot not determine + info = -1 + RETURN + END IF +! The group is symmorphic + info = 1 +! Check + DO ir = 1, nc + DO i = 1, 3 + vr(i) = r(i,1,ib(ir))*origin(1) + r(i,2,ib(ir))*origin(2) + & + r(i,3,ib(ir))*origin(3) + vr(i) = (origin(i)-vr(i)) - v(i,ir) + END DO + CALL rlv3(ai,vr,xb,il,delta) + dif = abs(xb(1)) + abs(xb(2)) + abs(xb(3)) + IF (dif>delta) THEN +! Non-symmorphic + info = 0 + RETURN + END IF + END DO + END SUBROUTINE symmorphic +!------------------------------------------------------------------------------! + SUBROUTINE rot1(ihc,r) +!------------------------------------------------------------------------------! +! WRITTEN ON FEBRUARY 17TH, 1976 +! GENERATION OF THE X,Y,Z-TRANSFORMATION MATRICES 3X3 +! FOR HEXAGONAL AND CUBIC GROUPS +! SUBROUTINES NEEDED -- NONE +!------------------------------------------------------------------------------! +! THIS IS IDENTICAL WITH THE SUBROUTINE ROT OF WORLTON-WARREN +! (IN THE AC-COMPLEX), ONLY THE WAY OF TRANSFERRING THE DATA +! WAS CHANGED +!------------------------------------------------------------------------------! +! INPUT DATA: +! IHC SWITCH DETERMINING IF WE DESIRE +! THE HEXAGONAL GROUP(IHC=0) OR THE CUBIC GROUP (IHC=1) +! OUTPUT DATA: +! R...THE 3X3 MATRICES OF THE DESIRED COORDINATE REPRESENTATION +! THEIR NUMBERING CORRESPONDS TO THE SYMMETRY ELEMENTS AS +! LISTE IN WORLTON-WARREN +! (COMPUT. PHYS. COMM. 3(1972) 88--117) +! FOR IHC=0 THE FIRST 24 MATRICES OF THE ARRAY R REPRESENT +! THE FULL HEXAGONAL GROUP D(6H) +! FOR IHC=1 THE FIRST 48 MATRICES OF THE ARRAY R REPRESENT +! THE FULL CUBIC GROUP O(H) +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: ihc + REAL (dbl) :: r(3,3,48) +! Variables + INTEGER :: i, j, k, n, nv + REAL (dbl) :: c, s +!------------------------------------------------------------------------------! + DO j = 1, 3 + DO i = 1, 3 + DO n = 1, 48 + r(i,j,n) = 0._dbl + END DO + END DO + END DO + IF (ihc==0) THEN +!------------------------------------------------------------------------------! +! DEFINE THE GENERATORS FOR THE ROTATION MATRICES--HEXAGONAL GROUP +!------------------------------------------------------------------------------! + c = 0.5D0 + s = 0.5D0*sqrt(3.0D0) + r(1,1,2) = c + r(1,2,2) = -s + r(2,1,2) = s + r(2,2,2) = c + r(1,1,7) = -c + r(1,2,7) = -s + r(2,1,7) = -s + r(2,2,7) = c + DO n = 1, 6 + r(3,3,n) = 1._dbl + r(3,3,n+18) = 1._dbl + r(3,3,n+6) = -1._dbl + r(3,3,n+12) = -1._dbl + END DO +!------------------------------------------------------------------------------! +! GENERATE THE REST OF THE ROTATION MATRICES +!------------------------------------------------------------------------------! + DO i = 1, 2 + r(i,i,1) = 1._dbl + DO j = 1, 2 + r(i,j,6) = r(j,i,2) + DO k = 1, 2 + r(i,j,3) = r(i,j,3) + r(i,k,2)*r(k,j,2) + r(i,j,8) = r(i,j,8) + r(i,k,2)*r(k,j,7) + r(i,j,12) = r(i,j,12) + r(i,k,7)*r(k,j,2) + END DO + END DO + END DO + DO i = 1, 2 + DO j = 1, 2 + r(i,j,5) = r(j,i,3) + DO k = 1, 2 + r(i,j,4) = r(i,j,4) + r(i,k,2)*r(k,j,3) + r(i,j,9) = r(i,j,9) + r(i,k,2)*r(k,j,8) + r(i,j,10) = r(i,j,10) + r(i,k,12)*r(k,j,3) + r(i,j,11) = r(i,j,11) + r(i,k,12)*r(k,j,2) + END DO + END DO + END DO + DO n = 1, 12 + nv = n + 12 + DO i = 1, 2 + DO j = 1, 2 + r(i,j,nv) = -r(i,j,n) + END DO + END DO + END DO + ELSE +!------------------------------------------------------------------------------! +! DEFINE THE GENERATORS FOR THE ROTATION MATRICES-CUBIC GROUP +!------------------------------------------------------------------------------! + r(1,3,9) = 1._dbl + r(2,1,9) = 1._dbl + r(3,2,9) = 1._dbl + r(1,1,19) = 1._dbl + r(2,3,19) = -1._dbl + r(3,2,19) = 1._dbl + DO i = 1, 3 + r(i,i,1) = 1._dbl + DO j = 1, 3 + r(i,j,20) = r(j,i,19) + r(i,j,5) = r(j,i,9) + DO k = 1, 3 + r(i,j,2) = r(i,j,2) + r(i,k,19)*r(k,j,19) + r(i,j,16) = r(i,j,16) + r(i,k,9)*r(k,j,19) + r(i,j,23) = r(i,j,23) + r(i,k,19)*r(k,j,9) + END DO + END DO + END DO + DO i = 1, 3 + DO j = 1, 3 + DO k = 1, 3 + r(i,j,6) = r(i,j,6) + r(i,k,2)*r(k,j,5) + r(i,j,7) = r(i,j,7) + r(i,k,16)*r(k,j,23) + r(i,j,8) = r(i,j,8) + r(i,k,5)*r(k,j,2) + r(i,j,10) = r(i,j,10) + r(i,k,2)*r(k,j,9) + r(i,j,11) = r(i,j,11) + r(i,k,9)*r(k,j,2) + r(i,j,12) = r(i,j,12) + r(i,k,23)*r(k,j,16) + r(i,j,14) = r(i,j,14) + r(i,k,16)*r(k,j,2) + r(i,j,15) = r(i,j,15) + r(i,k,2)*r(k,j,16) + r(i,j,22) = r(i,j,22) + r(i,k,23)*r(k,j,2) + r(i,j,24) = r(i,j,24) + r(i,k,2)*r(k,j,23) + END DO + END DO + END DO + DO i = 1, 3 + DO j = 1, 3 + DO k = 1, 3 + r(i,j,3) = r(i,j,3) + r(i,k,5)*r(k,j,12) + r(i,j,4) = r(i,j,4) + r(i,k,5)*r(k,j,10) + r(i,j,13) = r(i,j,13) + r(i,k,23)*r(k,j,11) + r(i,j,17) = r(i,j,17) + r(i,k,16)*r(k,j,12) + r(i,j,18) = r(i,j,18) + r(i,k,16)*r(k,j,10) + r(i,j,21) = r(i,j,21) + r(i,k,12)*r(k,j,15) + END DO + END DO + END DO + DO n = 1, 24 + nv = n + 24 + DO i = 1, 3 + DO j = 1, 3 + r(i,j,nv) = -r(i,j,n) + END DO + END DO + END DO + END IF + END SUBROUTINE rot1 +!------------------------------------------------------------------------------! + SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & + ib,r,ntot,wvkl,lwght,lrot,ncbrav,ibrav,istriz,nhash,includ,list, & + rlist,delta) +!------------------------------------------------------------------------------! +! WRITTEN ON SEPTEMBER 12-20TH, 1979 BY K.K. +! MODIFIED 26-MAY-82 BY OLE HOLM NIELSEN +! GENERATION OF SPECIAL POINTS FOR AN ARBITRARY LATTICE, +! FOLLOWING THE METHOD MONKHORST,PACK, +! PHYS. REV. B13 (1976) 5188 +! MODIFIED BY MACDONALD, PHYS. REV. B18 (1978) 5897 +! THE SUBROUTINE IS WRITTEN ASSUMING THAT THE POINTS ARE +! GENERATED IN THE RECIPROCAL SPACE. +! IF, HOWEVER, THE B1,B2,B3 ARE REPLACED BY A1,A2,A3, THEN +! SPECIAL POINTS IN THE DIRECT SPACE CAN BE PRODUCED, AS WELL. +! (NO MULTIPLICATION BY 2PI IS THEN NECESSARY.) +! IN THE CASE OF NONSYMMORPHIC GROUPS, THE APPLICATION IN THE +! DIRECT SPACE WOULD PROBABLY REQUIRE A CERTAIN CAUTION. +! SUBROUTINES NEEDED: BZDEFI,BZRDUC,INBZ,MESH +! IN THE CASES WHERE THE POINT GROUP OF THE CRYSTAL DOES NOT +! CONTAIN INVERSION. THE LATTER MAY BE ADDED IF WE WISH +! (SEE COMMENT TO THE SWITCH INV). +! REDUCTION TO THE 1ST BRILLOUIN ZONE IS DONE +! BY ADDING G-VECTORS TO FIND THE SHORTEST WAVE-VECTOR. +! THE ROTATIONS OF THE BRAVAIS LATTICE ARE APPLIED TO THE +! MONKHORST/PACK MESH IN ORDER TO FIND ALL K-POINTS +! THAT ARE RELATED BY SYMMETRY. (OLE HOLM NIELSEN) +!------------------------------------------------------------------------------! +! INPUT DATA: +! IOUT: LOGICAL UNIT FOR OUTPUT +! IF (IOUT.LE.0) NO MESSAGE +! IQ1,IQ2,IQ3 .. PARAMETER Q OF MONKHORST AND PACK, +! GENERALIZED AND DIFFERENT FOR THE 3 DIRECTIONS B1, +! B2 AND B3 +! WVK0 ... THE 'ARBITRARY' SHIFT OF THE WHOLE MESH, DENOTED K0 +! IN MACDONALD. WVK0 = 0 CORRESPONDS TO THE ORIGINAL +! SCHEME OF MONKHORST AND PACK. +! UNITS: 2PI/(UNITS OF LENGTH USED IN A1, A2, A3), +! I.E. THE SAME UNITS AS THE GENERATED SPECIAL POINTS +! NKPOINT .. VARIABLE DIMENSION OF THE (OUTPUT) ARRAYS WVKL, +! LWGHT,LROT, I.E. SPACE RESERVED FOR THE SPECIAL +! POINTS AND ACCESSORIES. +! NKPOINT HAS TO BE .GE. NTOT (TOTAL NUMBER OF SPECIAL +! POINTS. THIS IS CHECKED BY THE SUBROUTINE. +! ISTRIZ . INDICATES WHETHER ADDITIONAL MESH POINTS SHOULD BE +! GENERATED BY APPLYING GROUP OPERATIONS TO THE MESH. +! ISTRIZ=+1 MEANS SYMMETRIZE +! ISTRIZ=-1 MEANS DO NOT SYMMETRIZE +! THE FOLLOWING INPUT DATA MAY BE OBTAINED FROM THE SBRT. +! B1,B2,B3 .. RECIPROCAL LATTICE VECTORS, NOT MULTIPLIED BY +! GROUP1: ANY 2PI (IN UNITS RECIPROCAL TO THOSE +! OF A1,A2,A3) +! INV .... CODE INDICATING WHETHER WE WISH TO ADD THE INVERSION +! TO THE POINT GROUP OF THE CRYSTAL OR NOT (IN THE +! CASE THAT THE POINT GROUP DOES NOT CONTAIN ANY). +! INV=0 MEANS: DO NOT ADD INVERSION +! INV.NE.0 MEANS: ADD THE INVERSION +! INV.NE.0 SHOULD BE THE STANDARD CHOICE WHEN SPPT2 +! IS USED IN RECIPROCAL SPACE - IN ORDER TO MAKE +! USE OF THE HERMITICITY OF HAMILTONIAN. +! WHEN USED IN DIRECT SPACE, THE RIGHT CHOICE OF INV +! WILL DEPEND ON THE NATURE OF THE PHYSICAL PROBLEM. +! IN THE CASES WHERE THE INVERSION IS ADDED BY THE +! SWITCH INV, THE LIST IB WILL NOT BE MODIFIED BUT IN +! THE OUTPUT LIST LROT SOME OF THE OPERATIONS WILL +! APPEAR WITH NEGATIVE SIGN; THIS MEANS THAT THEY HAVE +! TO BE APPLIED MULTIPLIED BY INVERSION. +! NC ..... TOTAL NUMBER OF ELEMENTS IN THE POINT GROUP OF THE +! CRYSTAL +! IB ..... LIST OF THE ROTATIONS CONSTITUTING THE POINT GROUP +! OF THE CRYSTAL. THE NUMBERING IS THAT DEFINED IN +! WORLTON AND WARREN, I.E. THE ONE MATERIALIZED IN THE +! ARRAY R (SEE BELOW) +! ONLY THE FIRST NC ELEMENTS OF THE ARRAY IB ARE +! MEANINGFUL +! R ...... LIST OF THE 3 X 3 ROTATION MATRICES +! (XYZ REPRESENTATION OF THE O(H) OR D(6)H GROUPS) +! ALL 48 OR 24 MATRICES ARE LISTED. +! NCBRAV . TOTAL NUMBER OF ELEMENTS IN RBRAV +! IBRAV .. LIST OF NCBRAV OPERATIONS OF THE BRAVAIS LATTICE +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +!------------------------------------------------------------------------------! +! OUTPUT DATA: +! NTOT ... TOTAL NUMBER OF SPECIAL POINTS +! IF NTOT APPEARS NEGATIVE, THIS IS AN ERROR SIGNAL +! WHICH MEANS THAT THE DIMENSION NKPOINT WAS CHOSEN +! TOO SMALL SO THAT THE ARRAYS WVKL ETC. CANNOT +! ACCOMODATE ALL THE GENERATED SPECIAL POINTS. +! IN THIS CASE THE ARRAYS WILL BE FILLED UP TO NKPOINT +! AND FURTHER GENERATION OF NEW POINTS WILL BE +! INTERRUPTED. +! WVKL ... LIST OF SPECIAL POINTS. +! CARTESIAN COORDINATES AND NOT MULTIPLIED BY 2*PI. +! ONLY THE FIRST NTOT VECTORS ARE MEANINGFUL +! ALTHOUGH NO 2 POINTS FROM THE LIST ARE EQUIVALENT +! BY SYMMETRY, THIS SUBROUTINE STILL HAS A KIND OF +! 'BEAUTY DEFECT': THE POINTS FINALLY +! SELECTED ARE NOT NECESSARILY SITUATED IN A +! 'COMPACT' IRREDUCIBLE BRILL.ZONE; THEY MIGHT LIE IN +! DIFFERENT IRREDUCIBLE PARTS OF THE B.Z. - BUT THEY +! DO REPRESENT AN IRREDUCIBLE SET FOR INTEGRATION +! OVER THE ENTIRE B.Z. +! LWGHT ... THE LIST OF WEIGHTS OF THE CORRESPONDING POINTS. +! THESE WEIGHTS ARE NOT NORMALIZED (JUST INTEGERS) +! LROT ... FOR EACH SPECIAL POINT THE 'UNFOLDING ROTATIONS' +! ARE LISTED. IF E.G. THE WEIGHT OF THE I-TH SPECIAL +! POINT IS LWGHT(I), THEN THE ROTATIONS WITH NUMBERS +! LROT(J,I), J=1,2,...,LWGHT(I) WILL 'SPREAD' THIS +! SINGLE POINT FROM THE IRREDUCIBLE PART OF B.Z. INTO +! SEVERAL POINTS IN AN ELEMENTARY UNIT CELL +! (PARALLELOPIPED) OF THE RECIPROCAL SPACE. +! SOME OPERATION NUMBERS IN THE LIST LROT MAY APPEAR +! NEGATIVE, THIS MEANS THAT THE CORRESPONDING ROTATION +! HAS TO BE APPLIED WITH INVERSION (THE LATTER HAVING +! BEEN ARTIFICIALLY ADDED AS SYMMETRY OPERATION IN +! CASE INV.NE.0).NO OTHER EFFORT WAS TAKEN,TO RENUMBER +! THE ROTATIONS WITH MINUS SIGN OR TO EXTEND THE +! LIST OF THE POINT-GROUP OPERATIONS IN THE LIST NB. +! INCLUD ... INTEGER ARRAY USED BY SPPT2 INCLUD(NKPOINT) +! THE FIRST BIT (0) IS USED BY THE ROUTINE. +! THE OTHER BITS GIVE THE K-POINT INDEX IN +! THE SPECIAL K-POINT TABLE. +!------------------------------------------------------------------------------! +! NHASH USED BY MESH ROUTINE +! LIST INTEGER ARRAY USED BY MESH LIST(NHASH+NKPOINT) +! RLIST REAL(dbl) ARRAY USED BY MESH RLIST(3,NKPOINT) +!------------------------------------------------------------------------------! +! Use bit manipulations functions +! IBSET(I,POS) sets the bit POS to 1 in I integer +! IBCLR(I,POS) clears the bit POS to 1 in I integer +! BTEST(I,POS) .TRUE. if bit POS is 1 in I integer +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: iout, iq1, iq2, iq3, nkpoint, inv, nc, ntot, ncbrav, & + istriz, nhash, ib(48), ibrav(48), lwght(nkpoint), lrot(48,nkpoint), & + includ(nkpoint), list(nkpoint+nhash) + REAL (dbl) :: wvk0(3), a1(3), a2(3), a3(3), b1(3), b2(3), b3(3), & + r(3,3,48), wvkl(3,nkpoint), rlist(3,nkpoint), delta +!------------------------------------------------------------------------------! +! Variables + INTEGER, PARAMETER :: yes = 1, no = 0 + INTEGER, PARAMETER :: nrsdir = 100 + REAL (dbl) :: wvk(3), wva(3), rsdir(4,nrsdir), proja(3), projb(3), & + ur1, ur2, ur3, diff + INTEGER :: i, j, nplane, igarb0, igarbg, imesh, i1, i2, i3, iop, & + iremov, k, jplace, iwvk, igarbage, n, ibsign + INTEGER :: iplace + DATA iplace/ -2/ +!------------------------------------------------------------------------------! + ntot = 0 + DO i = 1, nkpoint + lrot(1,i) = 1 + DO j = 2, 48 + lrot(j,i) = 0 + END DO + END DO + DO i = 1, nkpoint + includ(i) = no + END DO + DO i = 1, 3 + wva(i) = 0._dbl + END DO +!------------------------------------------------------------------------------! +! DEFINE THE 1ST BRILLOUIN ZONE +!------------------------------------------------------------------------------! + CALL bzdefi(iout,b1,b2,b3,rsdir,nrsdir,nplane,delta) +!------------------------------------------------------------------------------! +! Generation of the mesh (they are not multiplied by 2*pi) by +! the Monkhorst/Pack algorithm, supplemented by all rotations +!------------------------------------------------------------------------------! +! Initialize the list of vectors + iplace = -2 + CALL mesh(iout,wva,iplace,igarb0,igarbg,nkpoint,nhash,list,rlist, & + delta) + imesh = 0 + DO i1 = 1, iq1 + DO i2 = 1, iq2 + DO i3 = 1, iq3 + ur1 = dble(1+iq1-2*i1)/dble(2*iq1) + ur2 = dble(1+iq2-2*i2)/dble(2*iq2) + ur3 = dble(1+iq3-2*i3)/dble(2*iq3) + DO i = 1, 3 + wvk(i) = ur1*b1(i) + ur2*b2(i) + ur3*b3(i) + wvk0(i) + END DO +! Reduce WVK to the 1st Brillouin zone + CALL bzrduc(wvk,a1,a2,a3,b1,b2,b3,rsdir,nrsdir,nplane,delta) + IF (istriz==1) THEN +! Symmetrization of the k-points mesh. +! Apply all the Bravais lattice operations to WVK + DO iop = 1, ncbrav + DO i = 1, 3 + wva(i) = 0._dbl + DO j = 1, 3 + wva(i) = wva(i) + r(i,j,ibrav(iop))*wvk(j) + END DO + END DO +! Check that WVA is inside the 1 Bz. + IF (inbz(wva,rsdir,nrsdir,nplane,delta)==no) GO TO 450 +! Place WVA in list + iplace = 0 + CALL mesh(iout,wva,iplace,igarb0,igarbg,nkpoint,nhash,list, & + rlist,delta) +! If WVA was new (and therefore inserted), +! IPLACE is the number. + IF (iplace>0) imesh = iplace + IF (iplace>nkpoint) GO TO 470 + END DO + ELSE +! Place WVK in list + iplace = 0 + CALL mesh(iout,wvk,iplace,igarb0,igarbg,nkpoint,nhash,list, & + rlist,delta) + imesh = iplace + IF (iplace>nkpoint) GO TO 470 + END IF + END DO + END DO + END DO + IF (iout>0) THEN +! IMESH: Number of k points in the mesh. + WRITE (iout,'(" K290| The wavevector mesh contains ",i5," points")') & + imesh + WRITE (iout,'(" K290| The points are:")') + DO i = 1, imesh + CALL mesh(iout,wva,i,igarb0,igarbg,nkpoint,nhash,list,rlist,delta) + IF (mod(i,2)==1) THEN + WRITE (iout,'(1X,I5,3F10.4,$)') i, wva + ELSE + WRITE (iout,'(1X,I5,3F10.4)') i, wva + END IF + END DO + WRITE (iout,*) + END IF +!------------------------------------------------------------------------------! + IF (istriz==1) THEN +! Now figure out if any special point difference (K - K'') is an +! integral multiple of a reciprocal-space vector + iremov = 0 + DO i = 1, (imesh-1) + iplace = i + CALL mesh(iout,wva,iplace,igarb0,igarbg,nkpoint,nhash,list,rlist, & + delta) +! Project WVA onto B1,2,3: + proja(1) = 0._dbl + proja(2) = 0._dbl + proja(3) = 0._dbl + DO k = 1, 3 + proja(1) = proja(1) + wva(k)*a1(k) + proja(2) = proja(2) + wva(k)*a2(k) + proja(3) = proja(3) + wva(k)*a3(k) + END DO +! Now loop over all the rest of the mesh points + DO j = (i+1), imesh + jplace = j + CALL mesh(iout,wvk,jplace,igarb0,igarbg,nkpoint,nhash,list, & + rlist,delta) +! Project WVK onto B1,2,3: + projb(1) = 0._dbl + projb(2) = 0._dbl + projb(3) = 0._dbl + DO k = 1, 3 + projb(1) = projb(1) + wvk(k)*a1(k) + projb(2) = projb(2) + wvk(k)*a2(k) + projb(3) = projb(3) + wvk(k)*a3(k) + END DO +! Check (PROJA - PROJB): Is it integral ? + DO k = 1, 3 + diff = proja(k) - projb(k) + IF (abs(dble(nint(diff))-diff)>delta) GO TO 280 + END DO +! DIFF is integral: remove WVK from mesh: + CALL remove(wvk,jplace,igarb0,igarbg,nkpoint,nhash,list,rlist, & + delta) +! If WVK actually removed, increment IREMOV + IF (jplace>0) iremov = iremov + 1 +280 CONTINUE + END DO + END DO + IF (iremov>0 .AND. iout>0) WRITE (iout,'(A,A,/,A,I6,A,/)') & + ' K290| Some of these mesh points are related by lattice ', & + 'translation vectors', 'K K290| ', iremov, & + ' of the mesh points removed.' + END IF +!------------------------------------------------------------------------------! +! IN THE MESH OF WAVEVECTORS, NOW SEARCH FOR EQUIVALENT POINTS: +! THE INVERSION (TIME REVERSAL !) MAY BE USED. +!------------------------------------------------------------------------------! + DO iwvk = 1, imesh +! IF(INCLUD(IWVK) .EQ. YES) GOTO 350 + IF (btest(includ(iwvk),0)) GO TO 350 +! IWVK has not been encountered previously: new special point, +! (only if WVK is not a garbage vector, however.) +! INCLUD(IWVK) = YES + includ(iwvk) = ibset(includ(iwvk),0) + iplace = iwvk + CALL mesh(iout,wvk,iplace,igarb0,igarbg,nkpoint,nhash,list,rlist, & + delta) +! Find out whether Wvk is in the garbage list + CALL garbag(wvk,igarbage,igarb0,nkpoint,nhash,list,rlist,delta) + IF (igarbage>0) GO TO 350 + ntot = ntot + 1 +! Give the index in the special k points table. + includ(iwvk) = includ(iwvk) + ntot*2 + DO i = 1, 3 + wvkl(i,ntot) = wvk(i) + END DO + lwght(ntot) = 1 +!------------------------------------------------------------------------------! +! Find all the equivalent points (symmetry given by atoms) + DO n = 1, nc +! Rotate: + DO i = 1, 3 + wva(i) = 0._dbl + DO j = 1, 3 + wva(i) = wva(i) + r(i,j,ib(n))*wvk(j) + END DO + END DO + ibsign = + 1 +363 CONTINUE +! Find WVA in the list + iplace = -1 + CALL mesh(iout,wva,iplace,igarb0,igarbg,nkpoint,nhash,list,rlist, & + delta) + IF (iplace==0) THEN + IF (istriz==-1) THEN +! No symmetrisation -> WVA not in the list + GO TO 364 + ELSE +! I think this case is impossible (NC <= NCBRAV) +! Error message + GO TO 490 + END IF + END IF +! Find out whether WVA is in the garbage list + CALL garbag(wva,igarbage,igarb0,nkpoint,nhash,list,rlist,delta) + IF (igarbage>0) GO TO 370 +! Was WVA encountered before ? +! IF(INCLUD(IPLACE) .EQ. YES) GOTO 364 + IF (btest(includ(iplace),0)) GO TO 364 +! Increment weight. + lwght(ntot) = lwght(ntot) + 1 + lrot(lwght(ntot),ntot) = ib(n)*ibsign +! INCLUD(IPLACE) = YES + includ(iplace) = ibset(includ(iplace),0) +! This k-point is an image of a special k-point. +! Put the index of the special k-point. + includ(iplace) = includ(iplace) + ntot*2 +364 CONTINUE + IF (ibsign==-1 .OR. inv==0) GO TO 370 +! The case where we also apply the inversion to WVA +! Repeat the search, but for -WVA + ibsign = -1 + DO i = 1, 3 + wva(i) = -wva(i) + END DO + GO TO 363 +370 CONTINUE + END DO +350 CONTINUE + END DO +!------------------------------------------------------------------------------! +! TOTAL NUMBER OF SPECIAL POINTS: NTOT +! BEFORE USING THE LIST WVKL AS WAVE VECTORS, THEY HAVE TO BE +! MULTIPLIED BY 2*PI +! THE LIST OF WEIGHTS LWGHT IS NOT NORMALIZED +!------------------------------------------------------------------------------! + IF (ntot>nkpoint .AND. iout>0) THEN + WRITE (iout,*) ' K290| In sppt2 number of special points = ', ntot + WRITE (iout,*) ' K290| but nkpoint = ', nkpoint + ntot = -1 + END IF + IF (iout>0) THEN +! Write the index table relating k points in the mesh +! with special k points + WRITE (iout,'(/,A)') & + ' K290| Cross table relating mesh points with special points:' + WRITE (iout,'(5(4X,"IK -> SK"))') + DO i = 1, imesh + iplace = includ(i)/2 + WRITE (iout,'(1X,I5,1X,I5,$)') i, iplace + IF (mod(i,5)==0) WRITE (iout,*) + END DO + IF (mod(j-1,5)/=0) WRITE (iout,*) + END IF + RETURN +!------------------------------------------------------------------------------! +! ERROR MESSAGES +!------------------------------------------------------------------------------! +450 CONTINUE + IF (iout>0) THEN + WRITE (iout,'(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' + WRITE (iout,'(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') ' THE VECTOR ', & + wva, ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & + ' BY ROTATION NO. ', ibrav(iop), ' IS OUTSIDE THE 1BZ' + END IF + CALL stop_prg('SPPT2','VECTOR OUTSIDE THE 1BZ') +!------------------------------------------------------------------------------! +470 CONTINUE + IF (iout>0) THEN + WRITE (iout,'(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' + WRITE (iout,*) 'MESH SIZE EXCEEDS NKPOINT=', nkpoint + END IF + CALL stop_prg('SPPT2','MESH SIZE EXCEEDED') +!------------------------------------------------------------------------------! +490 CONTINUE + IF (iout>0) THEN + WRITE (iout,'(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' + WRITE (iout,'(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') ' THE VECTOR ', & + wva, ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & + ' BY ROTATION NO. ', ib(n), ' IS NOT IN THE LIST' + END IF + CALL stop_prg('SPPT2','VECTOR NOT IN THE LIST') + END SUBROUTINE sppt2 +!------------------------------------------------------------------------------! + SUBROUTINE mesh(iout,wvk,iplace,igarb0,igarbg,nmesh,nhash,list,rlist, & + delta) +!------------------------------------------------------------------------------! +! MESH MAINTAINS A LIST OF VECTORS FOR PLACEMENT AND/OR LOOKUP +! +! ADDITIONAL ENTRY POINTS: REMOVE .... REMOVE VECTOR FROM LIST +! GARBAG .... WAS VECTOR REMOVED ? +! +! WVK ....... VECTOR +! IPLACE .... ON INPUT: -2 MEANS: INITIALIZE THE LIST +! (AND RETURN) +! -1 MEANS: FIND WVK IN THE LIST +! 0 MEANS: ADD WVK TO THE LIST +! >0 MEANS: RETURN WVK NO. IPLACE +! ON OUTPUT: THE POSITION ASSIGNED TO WVK +! (=0 IF WVK IS NOT IN THE LIST) +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + REAL (dbl) :: wvk(3), delta + INTEGER :: iout, iplace, igarb0, igarbg, nmesh, nhash, & + list(nhash+nmesh) + REAL (dbl) :: rlist(3,nmesh) +!------------------------------------------------------------------------------! +! Variables + INTEGER, PARAMETER :: nil = 0 + INTEGER :: ihash, i, j, ipoint + REAL (dbl) :: rhash, delta1 +!------------------------------------------------------------------------------! +! Save + INTEGER, SAVE :: istore +!------------------------------------------------------------------------------! +! Initialization +!------------------------------------------------------------------------------! + delta1 = 10._dbl*delta + IF (iplace<=-2) THEN + DO i = 1, nhash + nmesh + list(i) = nil + END DO + istore = 1 +! IGARB0 points to a linked list of removed WVKS (the garbage). + igarb0 = 0 + igarbg = 0 + RETURN +!------------------------------------------------------------------------------! + ELSE IF ((iplace>-2) .AND. (iplace<=0)) THEN +! The particular HASH function used in this case: + rhash = 0.7890D0*wvk(1) + 0.6810D0*wvk(2) + 0.5811D0*wvk(3) + delta + ihash = int(abs(rhash)*dble(nhash)) + ihash = mod(ihash,nhash) + nmesh + 1 +! Search for WVK in linked list + ipoint = list(ihash) + DO i = 1, 100 +! List exhausted + IF (ipoint==nil) GO TO 130 +! Compare WVK with this element + DO j = 1, 3 + IF (abs(wvk(j)-rlist(j,ipoint))>delta1) GO TO 115 + END DO +! WVK located + GO TO 160 +! Next element of list +115 CONTINUE + ihash = ipoint + ipoint = list(ihash) + END DO +! List too long + WRITE (*,'(2A,/,A)') & + ' SUBROUTINE MESH *** FATAL ERROR *** LINKED LIST', & + ' TOO LONG ***', ' CHOOSE A BETTER HASH-FUNCTION' + CALL stop_prg('MESH','WARNING') +! WVK was not found +130 CONTINUE + IF (iplace==-1) THEN +! IPLACE=-1 : search for WVK unsuccessful + iplace = 0 + RETURN + ELSE +! IPLACE=0: add WVK to the list + list(ihash) = istore + IF (istore>nmesh) THEN + WRITE (*,'(A)') 'SUBROUTINE MESH *** FATAL ERROR ***' + WRITE (*,'(A,I10,A,/,A,3F10.5)') ' ISTORE=', istore, & + ' EXCEEDS DIMENSIONS', ' WVK = ', wvk + CALL stop_prg('MESH','WARNING') + END IF + list(istore) = nil + DO i = 1, 3 + rlist(i,istore) = wvk(i) + END DO + istore = istore + 1 + iplace = istore - 1 + RETURN + END IF +! WVK was found +160 CONTINUE + IF (iplace==0) RETURN +! IPLACE=-1 + iplace = ipoint + RETURN + ELSE +!------------------------------------------------------------------------------! +! Return a wavevector (IPLACE > 0) +!------------------------------------------------------------------------------! + ipoint = iplace + IF (ipoint>=istore) GO TO 190 + DO i = 1, 3 + wvk(i) = rlist(i,ipoint) + END DO + RETURN + END IF +!------------------------------------------------------------------------------! +! Error - beyond list +!------------------------------------------------------------------------------! +190 CONTINUE + IF (iout>0) WRITE (iout,'(A,/,A,I5,A,/)') & + ' SUBROUTINE MESH *** WARNING ***', ' IPLACE = ', iplace, & + ' IS BEYOND THE LISTS - WVK SET TO 1.0E38' + DO i = 1, 3 + wvk(i) = 1.0D38 + END DO + END SUBROUTINE mesh +!------------------------------------------------------------------------------! + SUBROUTINE remove(wvk,iplace,igarb0,igarbg,nmesh,nhash,list,rlist,delta) +!------------------------------------------------------------------------------! +! ENTRY POINT FOR REMOVING A WAVEVECTOR +! +! INPUT: +! WVK(3) +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +! OUTPUT: +! IPLACE ..... 1 IF WVK WAS REMOVED +! 0 IF WVK WAS NOT REMOVED +! (WVK NOT IN THE LINKED LISTS) +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + REAL (dbl) :: wvk(3), delta + INTEGER :: iplace, igarb0, igarbg, nmesh, nhash, list(nhash+nmesh) + REAL (dbl) :: rlist(3,nmesh) +!------------------------------------------------------------------------------! +! Variables + INTEGER, PARAMETER :: nil = 0 + INTEGER :: ihash, ipoint, i, j + REAL (dbl) :: rhash, delta1 +!------------------------------------------------------------------------------! + delta1 = 10._dbl*delta +! The particular hash function used in this case: + rhash = 0.7890D0*wvk(1) + 0.6810D0*wvk(2) + 0.5811D0*wvk(3) + delta + ihash = int(abs(rhash)*dble(nhash)) + ihash = mod(ihash,nhash) + nmesh + 1 +! Search for WVK in linked list + ipoint = list(ihash) + DO i = 1, 100 +! List exhausted + IF (ipoint==nil) THEN +! WVK was not found in the mesh: + iplace = 0 + RETURN + END IF +! Compare WVK with this element + DO j = 1, 3 + IF (abs(wvk(j)-rlist(j,ipoint))>delta1) GO TO 215 + END DO +! WVK located, now remove it from the list: + list(ihash) = list(ipoint) +! LIST(IHASH) now points to the next element in the list, +! and the present WVK has become garbage. +! Add WVK to the list of garbage: + IF (igarb0==0) THEN +! Start up the garbage list: + igarb0 = ipoint + ELSE + list(igarbg) = ipoint + END IF + igarbg = ipoint + list(igarbg) = nil + iplace = 1 + RETURN +! Next element of list +215 CONTINUE + ihash = ipoint + ipoint = list(ihash) + END DO +! List too long + CALL stop_prg('MESH','LIST TOO LONG') + END SUBROUTINE remove +!------------------------------------------------------------------------------! + SUBROUTINE garbag(wvk,iplace,igarb0,nmesh,nhash,list,rlist,delta) +!------------------------------------------------------------------------------! +! ENTRY POINT FOR CHECKING IF A WAVEVECTOR +! IS IN THE GARBAGE LIST +! INPUT: +! WVK(3) +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +! +! OUTPUT: +! IPLACE ..... I > 0 IS THE PLACE IN THE GARBAGE LIST +! 0 IF WVK NOT AMONG THE GARBAGE +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: iplace, igarb0, nmesh, nhash, list(nhash+nmesh) + REAL (dbl) :: wvk(3), delta, rlist(3,nmesh) +!------------------------------------------------------------------------------! +! Variables + INTEGER, PARAMETER :: nil = 0 + INTEGER :: ipoint, i, j, ihash + REAL (dbl) :: delta1 +!------------------------------------------------------------------------------! + delta1 = 10._dbl*delta +! Search for WVK in linked list +! Point to the garbage list + ipoint = igarb0 + DO i = 1, nmesh +! LIST EXHAUSTED + IF (ipoint==nil) THEN +! WVK was not found in the mesh: + iplace = 0 + RETURN + END IF +! Compare WVK with this element + DO j = 1, 3 + IF (abs(wvk(j)-rlist(j,ipoint))>delta1) GO TO 315 + END DO +! WVK was located in the garbage list + iplace = i + RETURN +! Next element of list +315 CONTINUE + ihash = ipoint + ipoint = list(ihash) + END DO +! List too long + CALL stop_prg('GARBAG','LIST TOO LONG') + END SUBROUTINE garbag +!------------------------------------------------------------------------------! + SUBROUTINE bzrduc(wvk,a1,a2,a3,b1,b2,b3,rsdir,nrsdir,nplane,delta) +!------------------------------------------------------------------------------! +! REDUCE WVK TO LIE ENTIRELY WITHIN THE 1ST BRILLOUIN ZONE +! BY ADDING B-VECTORS +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: nrsdir, nplane + REAL (dbl) :: wvk(3), a1(3), a2(3), a3(3), b1(3), b2(3), b3(3), & + rsdir(4,nrsdir), delta +!------------------------------------------------------------------------------! +! Variables +! Look around +/- "NZONES" to locate vector +! NZONES may need to be increased for very anisotropic zones + INTEGER, PARAMETER :: nzones = 4, nnn = 2*nzones + 1, nn = nzones + 1 + INTEGER, PARAMETER :: yes = 1 + REAL (dbl) :: wva(3), wb(3) + INTEGER :: nn1, nn2, nn3, n1, i1, n2, i2, n3, i3, i +!------------------------------------------------------------------------------! +! WVK already inside 1Bz + IF (inbz(wvk,rsdir,nrsdir,nplane,delta)==yes) RETURN +! Express WVK in the basis of B1,2,3. +! This permits an estimate of how far WVK is from the 1Bz. + wb(1) = wvk(1)*a1(1) + wvk(2)*a1(2) + wvk(3)*a1(3) + wb(2) = wvk(1)*a2(1) + wvk(2)*a2(2) + wvk(3)*a2(3) + wb(3) = wvk(1)*a3(1) + wvk(2)*a3(2) + wvk(3)*a3(3) + nn1 = nint(wb(1)) + nn2 = nint(wb(2)) + nn3 = nint(wb(3)) +! Look around the estimated vector for the one truly inside the 1Bz + DO n1 = 1, nnn + i1 = nn - n1 - nn1 + DO n2 = 1, nnn + i2 = nn - n2 - nn2 + DO n3 = 1, nnn + i3 = nn - n3 - nn3 + DO i = 1, 3 + wva(i) = wvk(i) + dble(i1)*b1(i) + dble(i2)*b2(i) + & + dble(i3)*b3(i) + END DO + IF (inbz(wva,rsdir,nrsdir,nplane,delta)==yes) GO TO 210 + END DO + END DO + END DO +!------------------------------------------------------------------------------! +! Fatal error + WRITE (*,'(A,/,A,3F10.4,A)') ' SUBROUTINE BZRDUC *** FATAL ERROR ***', & + ' WAVEVECTOR ', wvk, ' COULD NOT BE REDUCED TO THE 1BZ' + CALL stop_prg('BZRDUC','WARNING') +!------------------------------------------------------------------------------! +! The reduced vector +210 CONTINUE + DO i = 1, 3 + wvk(i) = wva(i) + END DO + END SUBROUTINE bzrduc +!------------------------------------------------------------------------------! + FUNCTION inbz(wvk,rsdir,nrsdir,nplane,delta) +!------------------------------------------------------------------------------! +! IS WVK IN THE 1ST BRILLOUIN ZONE ? +! CHECK WHETHER WVK LIES INSIDE ALL THE PLANES +! THAT DEFINE THE 1BZ. +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: nrsdir, nplane + REAL (dbl) :: wvk(3), rsdir(4,nrsdir), delta + INTEGER :: inbz +! Variables + INTEGER, PARAMETER :: yes = 1, no = 0 + INTEGER :: n + REAL (dbl) :: projct +!------------------------------------------------------------------------------! + inbz = no + DO n = 1, nplane + projct = (rsdir(1,n)*wvk(1)+rsdir(2,n)*wvk(2)+rsdir(3,n)*wvk(3))/ & + rsdir(4,n) +! WVK is outside the Bz + IF (abs(projct)>0.5D0+delta) RETURN + END DO + inbz = yes + END FUNCTION inbz +!------------------------------------------------------------------------------! + SUBROUTINE bzdefi(iout,b1,b2,b3,rsdir,nrsdir,nplane,delta) +!------------------------------------------------------------------------------! +! FIND THE VECTORS WHOSE HALVES DEFINE THE 1ST BRILLOUIN ZONE +! OUTPUT: +! NPLANE TELLS HOW MANY ELEMENTS OF RSDIR CONTAIN +! NORMAL VECTORS DEFINING THE PLANES +! METHOD: STARTING WITH THE PARALLELOPIPED SPANNED BY B1,2,3 +! AROUND THE ORIGIN, VECTORS INSIDE A SUFFICIENTLY LARGE +! SPHERE ARE TESTED TO SEE WHETHER THE PLANES AT 1/2*B WILL +! FURTHER CONFINE THE 1BZ. +! THE RESULTING VECTORS ARE NOT CLEANED TO AVOID REDUNDANT +! PLANES. +! DELTA REQUIRED ACCURACY (1.D-6 IS A GOOD VALUE) +!------------------------------------------------------------------------------! + IMPLICIT NONE +! Arguments + INTEGER :: iout, nrsdir, nplane + REAL (dbl) :: b1(3), b2(3), b3(3), rsdir(4,nrsdir), delta +! Variables + REAL (dbl) :: bvec(3), b1len, b2len, b3len, bmax, projct + INTEGER :: nb1, nb2, nb3, i, j, nnb1, nnb2, nnb3, n1, i1, n2, i2, n3, & + i3, n, initlz + DATA initlz/0/ +!------------------------------------------------------------------------------! + IF (initlz/=0) RETURN +! Once initialized, we do not repeat the calculation + initlz = 1 + b1len = b1(1)**2 + b1(2)**2 + b1(3)**2 + b2len = b2(1)**2 + b2(2)**2 + b2(3)**2 + b3len = b3(1)**2 + b3(2)**2 + b3(3)**2 +! Lattice containing entirely the brillouin zone + bmax = b1len + b2len + b3len + nb1 = int(sqrt(bmax/b1len)+delta) + 1 + nb2 = int(sqrt(bmax/b2len)+delta) + 1 + nb3 = int(sqrt(bmax/b3len)+delta) + 1 +! PRINT *,'NB1,2,3 = ',NB1,NB2,NB3 + DO i = 1, nrsdir + DO j = 1, 4 + rsdir(j,i) = 0._dbl + END DO + END DO +! 1Bz is certainly confined inside the 1/2(B1,B2,B3) parallelopiped + DO i = 1, 3 + rsdir(i,1) = b1(i) + rsdir(i,2) = b2(i) + rsdir(i,3) = b3(i) + END DO + rsdir(4,1) = b1len + rsdir(4,2) = b2len + rsdir(4,3) = b3len +! Starting confinement: 3 planes + nplane = 3 + nnb1 = 2*nb1 + 1 + nnb2 = 2*nb2 + 1 + nnb3 = 2*nb3 + 1 + DO n1 = 1, nnb1 + i1 = nb1 + 1 - n1 + DO n2 = 1, nnb2 + i2 = nb2 + 1 - n2 + DO n3 = 1, nnb3 + i3 = nb3 + 1 - n3 + IF (i1==0 .AND. i2==0 .AND. i3==0) GO TO 150 + DO i = 1, 3 + bvec(i) = dble(i1)*b1(i) + dble(i2)*b2(i) + dble(i3)*b3(i) + END DO +! Does the plane of 1/2*BVEC narrow down the 1Bz ? + DO n = 1, nplane + projct = 0.5D0*(rsdir(1,n)*bvec(1)+rsdir(2,n)*bvec(2)+rsdir(3, & + n)*bvec(3))/rsdir(4,n) +! 1/2*BVEC is outside the Bz - skip this direction +! The 1.D-6 takes care of single points touching the Bz, +! and of the -(plane) + IF (abs(projct)>0.5D0-delta) GO TO 150 + END DO +! 1/2*BVEC further confines the 1Bz - include into RSDIR + nplane = nplane + 1 +! PRINT *,NPLANE,' PLANE INCLUDED, I1,2,3 = ',I1,I2,I3 + IF (nplane>nrsdir) GO TO 470 + DO i = 1, 3 + rsdir(i,nplane) = bvec(i) + END DO +! Length squared + rsdir(4,nplane) = bvec(1)**2 + bvec(2)**2 + bvec(3)**2 +150 CONTINUE + END DO + END DO + END DO +!------------------------------------------------------------------------------! +! Print information + IF (iout>0) WRITE (iout,'(A,I3,A,/,A,/,100(1X,3F10.4,/))') & + ' THE 1ST BRILLOUIN ZONE IS CONFINED BY (AT MOST)', nplane, & + ' PLANES', ' AS DEFINED BY THE +/- HALVES OF THE VECTORS:', & + ((rsdir(i,n),i=1,3),n=1,nplane) + RETURN +!------------------------------------------------------------------------------! +! Error messages +470 CONTINUE + IF (iout>0) THEN + WRITE (iout,'(A)') ' SUBROUTINE BZDEFI *** FATAL ERROR ***' + WRITE (iout,'(" TOO MANY PLANES, NRSDIR = ",I5)') nrsdir + END IF + CALL stop_prg('BZDEFI','WARNING') + END SUBROUTINE bzdefi +!------------------------------------------------------------------------------! + SUBROUTINE invmat(a,info) +! returns inverse of matrix using the lapack routines DGETRF and DGETRI + IMPLICIT NONE + REAL (dbl), INTENT (INOUT) :: a(:,:) + INTEGER, INTENT (OUT) :: info + INTEGER, ALLOCATABLE :: ipiv(:) + REAL (dbl), ALLOCATABLE :: work(:) + INTEGER :: n, lwork + + n = size(a(:,1)) + lwork = 20*n + ALLOCATE (ipiv(n),STAT=info) + IF (info/=0) CALL stop_memory('info','ipiv',n) + ALLOCATE (work(lwork),STAT=info) + IF (info/=0) CALL stop_memory('info','work',lwork) + info = 0 + CALL dgetrf(n,n,a,n,ipiv,info) + IF (info==0) THEN + CALL dgetri(n,a,n,ipiv,work,lwork,info) + END IF + DEALLOCATE (ipiv,STAT=info) + IF (info/=0) CALL stop_memory('info','ipiv') + DEALLOCATE (work,STAT=info) + IF (info/=0) CALL stop_memory('info','work') + END SUBROUTINE invmat +!------------------------------------------------------------------------------! + END MODULE k290 +!------------------------------------------------------------------------------! diff --git a/src/kpoint_initialization.F b/src/kpoint_initialization.F new file mode 100644 index 0000000000..9c46c4872e --- /dev/null +++ b/src/kpoint_initialization.F @@ -0,0 +1,64 @@ +!------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!------------------------------------------------------------------------------! +! + MODULE kpoint_initialization +! +!------------------------------------------------------------------------------! + USE kinds, ONLY : dbl + USE brillouin, ONLY : kpoint_type + USE stop_program, ONLY : stop_memory + USE particle_types, ONLY : particle_type + USE global_types, ONLY : global_environment_type + USE k290, ONLY : set_k290, set_k290_atoms, kp_sym_gen +! + IMPLICIT NONE +! + PRIVATE +! + PUBLIC :: initialize_kpoints +!------------------------------------------------------------------------------! +! + CONTAINS +! +!------------------------------------------------------------------------------! + SUBROUTINE initialize_kpoints(inpar,kp,symm,hmat,part) + + IMPLICIT NONE + + TYPE (global_environment_type) :: inpar + TYPE (kpoint_type) :: kp + LOGICAL, INTENT (IN) :: symm + REAL (dbl), INTENT (IN) :: hmat(:,:) + TYPE (particle_type), INTENT (IN) :: part(:) + + REAL (dbl), ALLOCATABLE :: coor(:,:) + INTEGER, ALLOCATABLE :: types(:) + INTEGER :: i, nat, isos + + IF (symm .OR. kp%scheme=='MONKHORST-PACK' .OR. kp%scheme=='MACDONALD') & + THEN + CALL set_k290(hmat,kp%nk,shift=kp%shift,symm=kp%symmetry, & + unit=inpar%scr) + nat = size(part) + ALLOCATE (coor(3,nat),STAT=isos) + IF (isos/=0) CALL stop_memory('initialize_kpoints','coor',3*nat) + ALLOCATE (types(nat),STAT=isos) + IF (isos/=0) CALL stop_memory('initialize_kpoints','types',nat) + DO i = 1, nat + coor(:,i) = part(i) %r + types(i) = part(i) %prop%ptype + END DO + CALL set_k290_atoms(coor,types) + DEALLOCATE (coor,STAT=isos) + IF (isos/=0) CALL stop_memory('initialize_kpoints','coor') + DEALLOCATE (types,STAT=isos) + IF (isos/=0) CALL stop_memory('initialize_kpoints','types') + CALL kp_sym_gen + END IF + + END SUBROUTINE initialize_kpoints +!------------------------------------------------------------------------------! + END MODULE kpoint_initialization +!------------------------------------------------------------------------------! diff --git a/src/kpoints.F b/src/kpoints.F new file mode 100644 index 0000000000..55986f7866 --- /dev/null +++ b/src/kpoints.F @@ -0,0 +1,15 @@ + +MODULE kpoints + + USE kinds, ONLY : dbl + + IMPLICIT NONE + + TYPE kpts_type + REAL ( dbl ), DIMENSION ( :, : ), POINTER :: xkpt + REAL ( dbl ), DIMENSION ( : ), POINTER :: wkpt + END TYPE kpts_type + + TYPE ( kpts_type ) :: kset + +END MODULE kpoints diff --git a/src/lib/Makefile b/src/lib/Makefile new file mode 100644 index 0000000000..f6e03d9d97 --- /dev/null +++ b/src/lib/Makefile @@ -0,0 +1,25 @@ +.SUFFIXES: .o .F + +include ../MACHINEDEFS + +OBJECTS_fftsg = mltfftsg.o ctrig.o fftstp.o fftpre.o fftrot.o + +################################# + +LIB1 = fftsg + +all: $(LIB1) + +$(LIB1): $(OBJECTS_fftsg) + $(AR) libfftsg.a $(OBJECTS_fftsg) + +%.o : %.F + $(FC) -c $(FFLAGS) $*.F + +clean: + rm -f *.o *.mod + +realclean: + rm -f *.a *.o *.mod *~ F*.f *.lst + +#################### diff --git a/src/lib/ctrig.F b/src/lib/ctrig.F new file mode 100644 index 0000000000..f644cab43e --- /dev/null +++ b/src/lib/ctrig.F @@ -0,0 +1,111 @@ +!-----------------------------------------------------------------------------! +! Copyright by Stefan Goedecker, Lausanne, Switzerland, August 1, 1991 +! modified by Stefan Goedecker, Cornell, Ithaca, USA, March 25, 1994 +! modified by Stefan Goedecker, Stuttgart, Germany, October 6, 1995 +! Commercial use is prohibited +! without the explicit permission of the author. +!-----------------------------------------------------------------------------! + +SUBROUTINE ctrig ( n, trig, after, before, now, isign, ic ) + + IMPLICIT NONE + + INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 ) + + INTEGER, INTENT ( IN ) :: n + INTEGER, INTENT ( IN ) :: isign + INTEGER, INTENT ( OUT ) :: ic + INTEGER, DIMENSION ( 7 ), INTENT ( OUT ) :: after, before, now + REAL ( dbl ) , DIMENSION ( 2, 1024 ), INTENT ( OUT ) :: trig + + INTEGER :: i, j, itt + REAL ( dbl ) :: twopi, angle + INTEGER, PARAMETER :: nt = 82 + INTEGER, DIMENSION ( 7, nt ), PARAMETER :: idata = RESHAPE ((/ & + 3, 3, 1, 1, 1, 1, 1, 4, 4, 1, 1, 1, 1, 1, & + 5, 5, 1, 1, 1, 1, 1, 6, 6, 1, 1, 1, 1, 1, & + 8, 8, 1, 1, 1, 1, 1, 9, 3, 3, 1, 1, 1, 1, & + 12, 4, 3, 1, 1, 1, 1, 15, 5, 3, 1, 1, 1, 1, & + 16, 4, 4, 1, 1, 1, 1, 18, 6, 3, 1, 1, 1, 1, & + 20, 5, 4, 1, 1, 1, 1, 24, 8, 3, 1, 1, 1, 1, & + 25, 5, 5, 1, 1, 1, 1, 27, 3, 3, 3, 1, 1, 1, & + 30, 6, 5, 1, 1, 1, 1, 32, 8, 4, 1, 1, 1, 1, & + 36, 4, 3, 3, 1, 1, 1, 40, 8, 5, 1, 1, 1, 1, & + 45, 5, 3, 3, 1, 1, 1, 48, 4, 4, 3, 1, 1, 1, & + 54, 6, 3, 3, 1, 1, 1, 60, 5, 4, 3, 1, 1, 1, & + 64, 4, 4, 4, 1, 1, 1, 72, 8, 3, 3, 1, 1, 1, & + 75, 5, 5, 3, 1, 1, 1, 80, 5, 4, 4, 1, 1, 1, & + 81, 3, 3, 3, 3, 1, 1, 90, 6, 5, 3, 1, 1, 1, & + 96, 8, 4, 3, 1, 1, 1, 100, 5, 5, 4, 1, 1, 1, & + 108, 4, 3, 3, 3, 1, 1, 120, 8, 5, 3, 1, 1, 1, & + 125, 5, 5, 5, 1, 1, 1, 128, 8, 4, 4, 1, 1, 1, & + 135, 5, 3, 3, 3, 1, 1, 144, 4, 4, 3, 3, 1, 1, & + 150, 6, 5, 5, 1, 1, 1, 160, 8, 5, 4, 1, 1, 1, & + 162, 6, 3, 3, 3, 1, 1, 180, 5, 4, 3, 3, 1, 1, & + 192, 4, 4, 4, 3, 1, 1, 200, 8, 5, 5, 1, 1, 1, & + 216, 8, 3, 3, 3, 1, 1, 225, 5, 5, 3, 3, 1, 1, & + 240, 5, 4, 4, 3, 1, 1, 243, 3, 3, 3, 3, 3, 1, & + 256, 4, 4, 4, 4, 1, 1, 270, 6, 5, 3, 3, 1, 1, & + 288, 8, 4, 3, 3, 1, 1, 300, 5, 5, 4, 3, 1, 1, & + 320, 5, 4, 4, 4, 1, 1, 324, 4, 3, 3, 3, 3, 1, & + 360, 8, 5, 3, 3, 1, 1, 375, 5, 5, 5, 3, 1, 1, & + 384, 8, 4, 4, 3, 1, 1, 400, 5, 5, 4, 4, 1, 1, & + 405, 5, 3, 3, 3, 3, 1, 432, 4, 4, 3, 3, 3, 1, & + 450, 6, 5, 5, 3, 1, 1, 480, 8, 5, 4, 3, 1, 1, & + 486, 6, 3, 3, 3, 3, 1, 500, 5, 5, 5, 4, 1, 1, & + 512, 8, 4, 4, 4, 1, 1, 540, 5, 4, 3, 3, 3, 1, & + 576, 4, 4, 4, 3, 3, 1, 600, 8, 5, 5, 3, 1, 1, & + 625, 5, 5, 5, 5, 1, 1, 640, 8, 5, 4, 4, 1, 1, & + 648, 8, 3, 3, 3, 3, 1, 675, 5, 5, 3, 3, 3, 1, & + 720, 5, 4, 4, 3, 3, 1, 729, 3, 3, 3, 3, 3, 3, & + 750, 6, 5, 5, 5, 1, 1, 768, 4, 4, 4, 4, 3, 1, & + 800, 8, 5, 5, 4, 1, 1, 810, 6, 5, 3, 3, 3, 1, & + 864, 8, 4, 3, 3, 3, 1, 900, 5, 5, 4, 3, 3, 1, & + 960, 5, 4, 4, 4, 3, 1, 972, 4, 3, 3, 3, 3, 3, & + 1000, 8, 5, 5, 5, 1, 1, 1024, 4, 4, 4, 4, 4, 1 /),(/7,nt/)) + +!-----------------------------------------------------------------------------! + + mloop: DO i = 1, nt + IF ( n == idata ( 1, i ) ) THEN + ic=0 + DO j = 1, 6 + itt = idata ( 1 + j, i ) + IF ( itt > 1 ) THEN + ic = ic + 1 + now ( j ) = idata ( 1 + j, i ) + ELSE + EXIT mloop + END IF + END DO + EXIT mloop + END IF + IF ( i == nt ) THEN + WRITE ( *, '(A,i5,A)' ) " Value of ",n, & + " not allowed for fft, allowed values are:" + WRITE ( *, '(15i5)' ) ( idata ( 1, j ), j = 1, nt ) + stop 'ctrig' + END IF + END DO mloop + + after ( 1 ) = 1 + before ( ic ) = 1 + DO i = 2, ic + after ( i ) = after ( i - 1 ) * now ( i - 1 ) + before ( ic - i + 1 ) = before ( ic - i + 2 ) * now ( ic - i + 2 ) + END DO + + twopi = 8._dbl * ATAN ( 1._dbl ) + angle = isign * twopi / REAL ( n, dbl ) + trig ( 1, 1 ) = 1._dbl + trig ( 2, 1 ) = 0._dbl + DO i = 1, n - 1 + trig ( 1, i + 1 ) = cos ( REAL ( i, dbl ) * angle ) + trig ( 2, i + 1 ) = sin ( REAL ( i, dbl ) * angle ) + END DO + +!-----------------------------------------------------------------------------! + + END SUBROUTINE ctrig + +!-----------------------------------------------------------------------------! diff --git a/src/lib/fftpre.F b/src/lib/fftpre.F new file mode 100644 index 0000000000..f0c20624f7 --- /dev/null +++ b/src/lib/fftpre.F @@ -0,0 +1,1051 @@ +!-----------------------------------------------------------------------------! +!Copyright by Stefan Goedecker, Cornell, Ithaca, USA, March 25, 1994 +!modified by Stefan Goedecker, Stuttgart, Germany, October 15, 1995 +!Commercial use is prohibited without the explicit permission of the author. +!-----------------------------------------------------------------------------! + +SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, & + trig, now, after, before, isign ) + + IMPLICIT NONE + + INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 ) + +! Arguments + INTEGER, INTENT ( IN ) :: mm, nfft, m, nn, n, now, after, before, isign + REAL ( dbl ), DIMENSION ( 2, 1024 ), INTENT ( IN ) :: trig + REAL ( dbl ), DIMENSION ( 2, m, mm ), INTENT ( IN ) :: zin + REAL ( dbl ), DIMENSION ( 2, nn, n ), INTENT ( OUT ) :: zout + + INTEGER :: atn, atb, ia, ib, nin1, nin2, nin3, nin4, nin5, nin6, nin7, nin8 + INTEGER :: nout1, nout2, nout3, nout4, nout5, nout6, nout7, nout8, & + i, j, ias, itt, itrig + REAL ( dbl ) :: s, s1, s2, s3, s4, s5, s6, s7, s8, & + r, r1, r2, r3, r4, r5, r6, r7, r8, cr2, cr3, cr4, cr5, & + ci2, ci3, ci4, ci5, ur1, ur2, ur3, ui1, ui2, ui3, & + vr1, vr2, vr3, vi1, vi2, vi3, cm, cp, dm, dp, & + am, ap, bm, bp,s25, s34, r34, r25, sin2, sin4 + REAL ( dbl ), PARAMETER :: rt2i = 0.7071067811865475_dbl ! sqrt(0.5) + REAL ( dbl ), PARAMETER :: bb = 0.8660254037844387_dbl ! sqrt(3)/2 + REAL ( dbl ), PARAMETER :: cos2 = 0.3090169943749474_dbl ! cos(2*pi/5) + REAL ( dbl ), PARAMETER :: cos4 = - 0.8090169943749474_dbl ! cos(4*pi/5) + REAL ( dbl ), PARAMETER :: sin2p = 0.9510565162951536_dbl ! sin(2*pi/5) + REAL ( dbl ), PARAMETER :: sin4p = 0.5877852522924731_dbl ! sin(4*pi/5) + +!-----------------------------------------------------------------------------! + + atn = after * now + atb = after * before + + IF ( now == 4 ) THEN + IF ( isign == 1 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r2 = zin ( 1, nin2, j ) + s2 = zin ( 2, nin2, j ) + r3 = zin ( 1, nin3, j ) + s3 = zin ( 2, nin3, j ) + r4 = zin ( 1, nin4, j ) + s4 = zin ( 2, nin4, j ) + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout4 ) = r + s + r = s1 + s3 + s = s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 2*ias == after ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r = zin ( 1, nin2, j ) + s = zin ( 2, nin2, j ) + r2 = ( r - s ) * rt2i + s2 = ( r + s ) * rt2i + r3 = - zin ( 2, nin3, j ) + s3 = zin ( 1, nin3, j ) + r = zin ( 1, nin4, j ) + s = zin ( 2, nin4, j ) + r4 = - ( r + s ) * rt2i + s4 = ( r - s ) * rt2i + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout4 ) = r + s + r = s1 + s3 + s = s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + ELSE + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + itrig = itrig + itt + cr4 = trig ( 1, itrig ) + ci4 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r = zin ( 1, nin2, j ) + s = zin ( 2, nin2, j ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, nin3, j ) + s = zin ( 2, nin3, j ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = zin ( 1, nin4, j ) + s = zin ( 2, nin4, j ) + r4 = r * cr4 - s * ci4 + s4 = r * ci4 + s * cr4 + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout4 ) = r + s + r = s1 + s3 + s = s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + END IF + END DO + ELSE + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r2 = zin ( 1, nin2, j ) + s2 = zin ( 2, nin2, j ) + r3 = zin ( 1, nin3, j ) + s3 = zin ( 2, nin3, j ) + r4 = zin ( 1, nin4, j ) + s4 = zin ( 2, nin4, j ) + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r + s + zout ( 1, j, nout4 ) = r - s + r = s1 + s3 + s = s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r - s + zout ( 2, j, nout4 ) = r + s + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 2 * ias == after ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r = zin ( 1, nin2, j ) + s = zin ( 2, nin2, j ) + r2 = ( r + s ) * rt2i + s2 = ( s - r ) * rt2i + r3 = zin ( 2, nin3, j ) + s3 = - zin ( 1, nin3, j ) + r = zin ( 1, nin4, j ) + s = zin ( 2, nin4, j ) + r4 = ( s - r ) * rt2i + s4 = - ( r + s ) * rt2i + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r + s + zout ( 1, j, nout4 ) = r - s + r =s1 + s3 + s =s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r - s + zout ( 2, j, nout4 ) = r + s + END DO + END DO + ELSE + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + itrig = itrig + itt + cr4 = trig ( 1, itrig ) + ci4 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r = zin ( 1, nin2, j ) + s = zin ( 2, nin2, j ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, nin3, j ) + s = zin ( 2, nin3, j ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = zin ( 1, nin4, j ) + s = zin ( 2, nin4, j ) + r4 = r * cr4 - s * ci4 + s4 = r * ci4 + s * cr4 + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r + s + zout ( 1, j, nout4 ) = r - s + r = s1 + s3 + s = s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r - s + zout ( 2, j, nout4 ) = r + s + END DO + END DO + END IF + END DO + END IF + ELSE IF ( now == 8 ) THEN + IF ( isign == -1 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nin6 = nin5 + atb + nin7 = nin6 + atb + nin8 = nin7 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + nout6 = nout5 + after + nout7 = nout6 + after + nout8 = nout7 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r2 = zin ( 1, nin2, j ) + s2 = zin ( 2, nin2, j ) + r3 = zin ( 1, nin3, j ) + s3 = zin ( 2, nin3, j ) + r4 = zin ( 1, nin4, j ) + s4 = zin ( 2, nin4, j ) + r5 = zin ( 1, nin5, j ) + s5 = zin ( 2, nin5, j ) + r6 = zin ( 1, nin6, j ) + s6 = zin ( 2, nin6, j ) + r7 = zin ( 1, nin7, j ) + s7 = zin ( 2, nin7, j ) + r8 = zin ( 1, nin8, j ) + s8 = zin ( 2, nin8, j ) + r = r1 + r5 + s = r3 + r7 + ap = r + s + am = r - s + r = r2 + r6 + s = r4 + r8 + bp = r + s + bm = r - s + r = s1 + s5 + s = s3 + s7 + cp = r + s + cm = r - s + r = s2 + s6 + s = s4 + s8 + dp = r + s + dm = r - s + zout ( 1, j, nout1 ) = ap + bp + zout ( 2, j, nout1 ) = cp + dp + zout ( 1, j, nout5 ) = ap - bp + zout ( 2, j, nout5 ) = cp - dp + zout ( 1, j, nout3 ) = am + dm + zout ( 2, j, nout3 ) = cm - bm + zout ( 1, j, nout7 ) = am - dm + zout ( 2, j, nout7 ) = cm + bm + r = r1 - r5 + s = s3 - s7 + ap = r + s + am = r - s + r = s1 - s5 + s = r3 - r7 + bp = r + s + bm = r - s + r = s4 - s8 + s = r2 - r6 + cp = r + s + cm = r - s + r = s2 - s6 + s = r4 - r8 + dp = r + s + dm = r - s + r = ( cp + dm ) * rt2i + s = (-cp + dm ) * rt2i + cp = ( cm + dp ) * rt2i + dp = ( cm - dp ) * rt2i + zout ( 1, j, nout2 ) = ap + r + zout ( 2, j, nout2 ) = bm + s + zout ( 1, j, nout6 ) = ap - r + zout ( 2, j, nout6 ) = bm - s + zout ( 1, j, nout4 ) = am + cp + zout ( 2, j, nout4 ) = bp + dp + zout ( 1, j, nout8 ) = am - cp + zout ( 2, j, nout8 ) = bp - dp + END DO + END DO + ELSE + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nin6 = nin5 + atb + nin7 = nin6 + atb + nin8 = nin7 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + nout6 = nout5 + after + nout7 = nout6 + after + nout8 = nout7 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r2 = zin ( 1, nin2, j ) + s2 = zin ( 2, nin2, j ) + r3 = zin ( 1, nin3, j ) + s3 = zin ( 2, nin3, j ) + r4 = zin ( 1, nin4, j ) + s4 = zin ( 2, nin4, j ) + r5 = zin ( 1, nin5, j ) + s5 = zin ( 2, nin5, j ) + r6 = zin ( 1, nin6, j ) + s6 = zin ( 2, nin6, j ) + r7 = zin ( 1, nin7, j ) + s7 = zin ( 2, nin7, j ) + r8 = zin ( 1, nin8, j ) + s8 = zin ( 2, nin8, j ) + r = r1 + r5 + s = r3 + r7 + ap = r + s + am = r - s + r = r2 + r6 + s = r4 + r8 + bp = r + s + bm = r - s + r = s1 + s5 + s = s3 + s7 + cp = r + s + cm = r - s + r = s2 + s6 + s = s4 + s8 + dp = r + s + dm = r - s + zout ( 1, j, nout1 ) = ap + bp + zout ( 2, j, nout1 ) = cp + dp + zout ( 1, j, nout5 ) = ap - bp + zout ( 2, j, nout5 ) = cp - dp + zout ( 1, j, nout3 ) = am - dm + zout ( 2, j, nout3 ) = cm + bm + zout ( 1, j, nout7 ) = am + dm + zout ( 2, j, nout7 ) = cm - bm + r = r1 - r5 + s = -s3 + s7 + ap = r + s + am = r - s + r = s1 - s5 + s = r7 - r3 + bp = r + s + bm = r - s + r = -s4 + s8 + s = r2 - r6 + cp = r + s + cm = r - s + r = -s2 + s6 + s = r4 - r8 + dp = r + s + dm = r - s + r = ( cp + dm ) * rt2i + s = ( cp - dm ) * rt2i + cp = ( cm + dp ) * rt2i + dp = (-cm + dp ) * rt2i + zout ( 1, j, nout2 ) = ap + r + zout ( 2, j, nout2 ) = bm + s + zout ( 1, j, nout6 ) = ap - r + zout ( 2, j, nout6 ) = bm - s + zout ( 1, j, nout4 ) = am + cp + zout ( 2, j, nout4 ) = bp + dp + zout ( 1, j, nout8 ) = am - cp + zout ( 2, j, nout8 ) = bp - dp + END DO + END DO + END IF + ELSE IF ( now == 3 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r2 = zin ( 1, nin2, j ) + s2 = zin ( 2, nin2, j ) + r3 = zin ( 1, nin3, j ) + s3 = zin ( 2, nin3, j ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 4*ias == 3*after ) THEN + IF ( isign == 1 ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2=nin1+atb + nin3=nin2+atb + nout1=nout1+atn + nout2=nout1+after + nout3=nout2+after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r2 = -zin ( 2, nin2, j ) + s2 = zin ( 1, nin2, j ) + r3 = -zin ( 1, nin3, j ) + s3 = -zin ( 2, nin3, j ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb*(r2-r3) + s2 = bb*(s2-s3) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + ELSE + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r2 = zin ( 2, nin2, j ) + s2 = -zin ( 1, nin2, j ) + r3 = -zin ( 1, nin3, j ) + s3 = -zin ( 2, nin3, j ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + END IF + ELSE IF ( 8 * ias == 3 * after ) THEN + IF ( isign == 1 ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r = zin ( 1, nin2, j ) + s = zin ( 2, nin2, j ) + r2 = ( r - s ) * rt2i + s2 = ( r + s ) * rt2i + r3 = -zin ( 2, nin3, j ) + s3 = zin ( 1, nin3, j ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + ELSE + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r = zin ( 1, nin2, j ) + s = zin ( 2, nin2, j ) + r2 = ( r + s ) * rt2i + s2 = ( -r + s ) * rt2i + r3 = zin ( 2, nin3, j ) + s3 = -zin ( 1, nin3, j ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + END IF + ELSE + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r = zin ( 1, nin2, j ) + s = zin ( 2, nin2, j ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, nin3, j ) + s = zin ( 2, nin3, j ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + END IF + END DO + ELSE IF ( now == 5 ) THEN + sin2 = isign * sin2p + sin4 = isign * sin4p + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r2 = zin ( 1, nin2, j ) + s2 = zin ( 2, nin2, j ) + r3 = zin ( 1, nin3, j ) + s3 = zin ( 2, nin3, j ) + r4 = zin ( 1, nin4, j ) + s4 = zin ( 2, nin4, j ) + r5 = zin ( 1, nin5, j ) + s5 = zin ( 2, nin5, j ) + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, j, nout1 ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout5 ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, j, nout3 ) = r - s + zout ( 1, j, nout4 ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, j, nout1 ) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout5 ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, j, nout3 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 8 * ias == 5 * after ) THEN + IF ( isign == 1 ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r = zin ( 1, nin2, j ) + s = zin ( 2, nin2, j ) + r2 = ( r - s ) * rt2i + s2 = ( r + s ) * rt2i + r3 = -zin ( 2, nin3, j ) + s3 = zin ( 1, nin3, j ) + r = zin ( 1, nin4, j ) + s = zin ( 2, nin4, j ) + r4 = -( r + s ) * rt2i + s4 = ( r - s ) * rt2i + r5 = -zin ( 1, nin5, j ) + s5 = -zin ( 2, nin5, j ) + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, j, nout1 ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout5 ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, j, nout3 ) = r - s + zout ( 1, j, nout4 ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, j, nout1 ) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout5 ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, j, nout3 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + ELSE + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r = zin ( 1, nin2, j ) + s = zin ( 2, nin2, j ) + r2 = ( r + s ) * rt2i + s2 = ( -r + s ) * rt2i + r3 = zin ( 2, nin3, j ) + s3 = -zin ( 1, nin3, j ) + r = zin ( 1, nin4, j ) + s = zin ( 2, nin4, j ) + r4 = ( s - r ) * rt2i + s4 = - ( r + s ) * rt2i + r5 = -zin ( 1, nin5, j ) + s5 = -zin ( 2, nin5, j ) + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, j, nout1 ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout5 ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, j, nout3 ) = r - s + zout ( 1, j, nout4 ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, j, nout1) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout5 ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, j, nout3 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + END IF + ELSE + ias = ia - 1 + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + itrig = itrig + itt + cr4 = trig ( 1, itrig ) + ci4 = trig ( 2, itrig ) + itrig = itrig + itt + cr5 = trig ( 1, itrig ) + ci5 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + r = zin ( 1, nin2, j ) + s = zin ( 2, nin2, j ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, nin3, j ) + s = zin ( 2, nin3, j ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = zin ( 1, nin4, j ) + s = zin ( 2, nin4, j ) + r4 = r * cr4 - s * ci4 + s4 = r * ci4 + s * cr4 + r = zin ( 1, nin5, j ) + s = zin ( 2, nin5, j ) + r5 = r * cr5 - s * ci5 + s5 = r * ci5 + s * cr5 + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, j, nout1 ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout5 ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, j, nout3 ) = r - s + zout ( 1, j, nout4 ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, j, nout1 ) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout5 ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, j, nout3 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + END IF + END DO + ELSE IF ( now == 6 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nin6 = nin5 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + nout6 = nout5 + after + DO j = 1, nfft + r2 = zin ( 1, nin3, j ) + s2 = zin ( 2, nin3, j ) + r3 = zin ( 1, nin5, j ) + s3 = zin ( 2, nin5, j ) + r = r2 + r3 + s = s2 + s3 + r1 = zin ( 1, nin1, j ) + s1 = zin ( 2, nin1, j ) + ur1 = r + r1 + ui1 = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r = r2 - r3 + s = s2 - s3 + ur2 = r1 - s * bb + ui2 = s1 + r * bb + ur3 = r1 + s * bb + ui3 = s1 - r * bb + + r2 = zin ( 1, nin6, j ) + s2 = zin ( 2, nin6, j ) + r3 = zin ( 1, nin2, j ) + s3 = zin ( 2, nin2, j ) + r = r2 + r3 + s = s2 + s3 + r1 = zin ( 1, nin4, j ) + s1 = zin ( 2, nin4, j ) + vr1 = r + r1 + vi1 = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r = r2 - r3 + s = s2 - s3 + vr2 = r1 - s * bb + vi2 = s1 + r * bb + vr3 = r1 + s * bb + vi3 = s1 - r * bb + + zout ( 1, j, nout1 ) = ur1 + vr1 + zout ( 2, j, nout1 ) = ui1 + vi1 + zout ( 1, j, nout5 ) = ur2 + vr2 + zout ( 2, j, nout5 ) = ui2 + vi2 + zout ( 1, j, nout3 ) = ur3 + vr3 + zout ( 2, j, nout3 ) = ui3 + vi3 + zout ( 1, j, nout4 ) = ur1 - vr1 + zout ( 2, j, nout4 ) = ui1 - vi1 + zout ( 1, j, nout2 ) = ur2 - vr2 + zout ( 2, j, nout2 ) = ui2 - vi2 + zout ( 1, j, nout6 ) = ur3 - vr3 + zout ( 2, j, nout6 ) = ui3 - vi3 + END DO + END DO + ELSE + STOP 'Error fftpre' + END If + +!-----------------------------------------------------------------------------! + +END SUBROUTINE fftpre + +!-----------------------------------------------------------------------------! diff --git a/src/lib/fftrot.F b/src/lib/fftrot.F new file mode 100644 index 0000000000..865779ef90 --- /dev/null +++ b/src/lib/fftrot.F @@ -0,0 +1,1051 @@ +!-----------------------------------------------------------------------------! +!Copyright by Stefan Goedecker, Cornell, Ithaca, USA, March 25, 1994 +!modified by Stefan Goedecker, Stuttgart, Germany, October 15, 1995 +!Commercial use is prohibited without the explicit permission of the author. +!-----------------------------------------------------------------------------! + +SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, & + trig, now, after, before, isign ) + + IMPLICIT NONE + + INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 ) + +! Arguments + INTEGER, INTENT ( IN ) :: mm, nfft, m, nn, n, now, after, before, isign + REAL ( dbl ), DIMENSION ( 2, 1024 ), INTENT ( IN ) :: trig + REAL ( dbl ), DIMENSION ( 2, mm, m ), INTENT ( IN ) :: zin + REAL ( dbl ), DIMENSION ( 2, n, nn ), INTENT ( OUT ) :: zout + + INTEGER :: atn, atb, ia, ib, nin1, nin2, nin3, nin4, nin5, nin6, nin7, nin8 + INTEGER :: nout1, nout2, nout3, nout4, nout5, nout6, nout7, nout8, & + i, j, ias, itt, itrig + REAL ( dbl ) :: s, s1, s2, s3, s4, s5, s6, s7, s8, & + r, r1, r2, r3, r4, r5, r6, r7, r8, cr2, cr3, cr4, cr5, & + ci2, ci3, ci4, ci5, ur1, ur2, ur3, ui1, ui2, ui3, & + vr1, vr2, vr3, vi1, vi2, vi3, cm, cp, dm, dp, & + am, ap, bm, bp,s25, s34, r34, r25, sin2, sin4 + REAL ( dbl ), PARAMETER :: rt2i = 0.7071067811865475_dbl ! sqrt(0.5) + REAL ( dbl ), PARAMETER :: bb = 0.8660254037844387_dbl ! sqrt(3)/2 + REAL ( dbl ), PARAMETER :: cos2 = 0.3090169943749474_dbl ! cos(2*pi/5) + REAL ( dbl ), PARAMETER :: cos4 = - 0.8090169943749474_dbl ! cos(4*pi/5) + REAL ( dbl ), PARAMETER :: sin2p = 0.9510565162951536_dbl ! sin(2*pi/5) + REAL ( dbl ), PARAMETER :: sin4p = 0.5877852522924731_dbl ! sin(4*pi/5) + +!-----------------------------------------------------------------------------! + + atn = after * now + atb = after * before + + IF ( now == 4 ) THEN + IF ( isign == 1 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r4 = zin ( 1, j, nin4 ) + s4 = zin ( 2, j, nin4 ) + r = r1 + r3 + s = r2 + r4 + zout ( 1, nout1, j ) = r + s + zout ( 1, nout3, j ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, nout2, j ) = r - s + zout ( 1, nout4, j ) = r + s + r = s1 + s3 + s = s2 + s4 + zout ( 2, nout1, j ) = r + s + zout ( 2, nout3, j ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, nout2, j ) = r + s + zout ( 2, nout4, j ) = r - s + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 2*ias == after ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r - s ) * rt2i + s2 = ( r + s ) * rt2i + r3 = - zin ( 2, j, nin3 ) + s3 = zin ( 1, j, nin3 ) + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = - ( r + s ) * rt2i + s4 = ( r - s ) * rt2i + r = r1 + r3 + s = r2 + r4 + zout ( 1, nout1, j ) = r + s + zout ( 1, nout3, j ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, nout2, j ) = r - s + zout ( 1, nout4, j ) = r + s + r = s1 + s3 + s = s2 + s4 + zout ( 2, nout1, j ) = r + s + zout ( 2, nout3, j ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, nout2, j ) = r + s + zout ( 2, nout4, j ) = r - s + END DO + END DO + ELSE + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + itrig = itrig + itt + cr4 = trig ( 1, itrig ) + ci4 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, j, nin3 ) + s = zin ( 2, j, nin3 ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = r * cr4 - s * ci4 + s4 = r * ci4 + s * cr4 + r = r1 + r3 + s = r2 + r4 + zout ( 1, nout1, j ) = r + s + zout ( 1, nout3, j ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, nout2, j ) = r - s + zout ( 1, nout4, j ) = r + s + r = s1 + s3 + s = s2 + s4 + zout ( 2, nout1, j ) = r + s + zout ( 2, nout3, j ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, nout2, j ) = r + s + zout ( 2, nout4, j ) = r - s + END DO + END DO + END IF + END DO + ELSE + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r4 = zin ( 1, j, nin4 ) + s4 = zin ( 2, j, nin4 ) + r = r1 + r3 + s = r2 + r4 + zout ( 1, nout1, j ) = r + s + zout ( 1, nout3, j ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, nout2, j ) = r + s + zout ( 1, nout4, j ) = r - s + r = s1 + s3 + s = s2 + s4 + zout ( 2, nout1, j ) = r + s + zout ( 2, nout3, j ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, nout2, j ) = r - s + zout ( 2, nout4, j ) = r + s + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 2 * ias == after ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r + s ) * rt2i + s2 = ( s - r ) * rt2i + r3 = zin ( 2, j, nin3 ) + s3 = - zin ( 1, j, nin3 ) + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = ( s - r ) * rt2i + s4 = - ( r + s ) * rt2i + r = r1 + r3 + s = r2 + r4 + zout ( 1, nout1, j ) = r + s + zout ( 1, nout3, j ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, nout2, j ) = r + s + zout ( 1, nout4, j ) = r - s + r =s1 + s3 + s =s2 + s4 + zout ( 2, nout1, j ) = r + s + zout ( 2, nout3, j ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, nout2, j ) = r - s + zout ( 2, nout4, j ) = r + s + END DO + END DO + ELSE + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + itrig = itrig + itt + cr4 = trig ( 1, itrig ) + ci4 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, j, nin3 ) + s = zin ( 2, j, nin3 ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = r * cr4 - s * ci4 + s4 = r * ci4 + s * cr4 + r = r1 + r3 + s = r2 + r4 + zout ( 1, nout1, j ) = r + s + zout ( 1, nout3, j ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, nout2, j ) = r + s + zout ( 1, nout4, j ) = r - s + r = s1 + s3 + s = s2 + s4 + zout ( 2, nout1, j ) = r + s + zout ( 2, nout3, j ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, nout2, j ) = r - s + zout ( 2, nout4, j ) = r + s + END DO + END DO + END IF + END DO + END IF + ELSE IF ( now == 8 ) THEN + IF ( isign == -1 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nin6 = nin5 + atb + nin7 = nin6 + atb + nin8 = nin7 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + nout6 = nout5 + after + nout7 = nout6 + after + nout8 = nout7 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r4 = zin ( 1, j, nin4 ) + s4 = zin ( 2, j, nin4 ) + r5 = zin ( 1, j, nin5 ) + s5 = zin ( 2, j, nin5 ) + r6 = zin ( 1, j, nin6 ) + s6 = zin ( 2, j, nin6 ) + r7 = zin ( 1, j, nin7 ) + s7 = zin ( 2, j, nin7 ) + r8 = zin ( 1, j, nin8 ) + s8 = zin ( 2, j, nin8 ) + r = r1 + r5 + s = r3 + r7 + ap = r + s + am = r - s + r = r2 + r6 + s = r4 + r8 + bp = r + s + bm = r - s + r = s1 + s5 + s = s3 + s7 + cp = r + s + cm = r - s + r = s2 + s6 + s = s4 + s8 + dp = r + s + dm = r - s + zout ( 1, nout1, j ) = ap + bp + zout ( 2, nout1, j ) = cp + dp + zout ( 1, nout5, j ) = ap - bp + zout ( 2, nout5, j ) = cp - dp + zout ( 1, nout3, j ) = am + dm + zout ( 2, nout3, j ) = cm - bm + zout ( 1, nout7, j ) = am - dm + zout ( 2, nout7, j ) = cm + bm + r = r1 - r5 + s = s3 - s7 + ap = r + s + am = r - s + r = s1 - s5 + s = r3 - r7 + bp = r + s + bm = r - s + r = s4 - s8 + s = r2 - r6 + cp = r + s + cm = r - s + r = s2 - s6 + s = r4 - r8 + dp = r + s + dm = r - s + r = ( cp + dm ) * rt2i + s = (-cp + dm ) * rt2i + cp = ( cm + dp ) * rt2i + dp = ( cm - dp ) * rt2i + zout ( 1, nout2, j ) = ap + r + zout ( 2, nout2, j ) = bm + s + zout ( 1, nout6, j ) = ap - r + zout ( 2, nout6, j ) = bm - s + zout ( 1, nout4, j ) = am + cp + zout ( 2, nout4, j ) = bp + dp + zout ( 1, nout8, j ) = am - cp + zout ( 2, nout8, j ) = bp - dp + END DO + END DO + ELSE + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nin6 = nin5 + atb + nin7 = nin6 + atb + nin8 = nin7 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + nout6 = nout5 + after + nout7 = nout6 + after + nout8 = nout7 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r4 = zin ( 1, j, nin4 ) + s4 = zin ( 2, j, nin4 ) + r5 = zin ( 1, j, nin5 ) + s5 = zin ( 2, j, nin5 ) + r6 = zin ( 1, j, nin6 ) + s6 = zin ( 2, j, nin6 ) + r7 = zin ( 1, j, nin7 ) + s7 = zin ( 2, j, nin7 ) + r8 = zin ( 1, j, nin8 ) + s8 = zin ( 2, j, nin8 ) + r = r1 + r5 + s = r3 + r7 + ap = r + s + am = r - s + r = r2 + r6 + s = r4 + r8 + bp = r + s + bm = r - s + r = s1 + s5 + s = s3 + s7 + cp = r + s + cm = r - s + r = s2 + s6 + s = s4 + s8 + dp = r + s + dm = r - s + zout ( 1, nout1, j ) = ap + bp + zout ( 2, nout1, j ) = cp + dp + zout ( 1, nout5, j ) = ap - bp + zout ( 2, nout5, j ) = cp - dp + zout ( 1, nout3, j ) = am - dm + zout ( 2, nout3, j ) = cm + bm + zout ( 1, nout7, j ) = am + dm + zout ( 2, nout7, j ) = cm - bm + r = r1 - r5 + s = -s3 + s7 + ap = r + s + am = r - s + r = s1 - s5 + s = r7 - r3 + bp = r + s + bm = r - s + r = -s4 + s8 + s = r2 - r6 + cp = r + s + cm = r - s + r = -s2 + s6 + s = r4 - r8 + dp = r + s + dm = r - s + r = ( cp + dm ) * rt2i + s = ( cp - dm ) * rt2i + cp = ( cm + dp ) * rt2i + dp = (-cm + dp ) * rt2i + zout ( 1, nout2, j ) = ap + r + zout ( 2, nout2, j ) = bm + s + zout ( 1, nout6, j ) = ap - r + zout ( 2, nout6, j ) = bm - s + zout ( 1, nout4, j ) = am + cp + zout ( 2, nout4, j ) = bp + dp + zout ( 1, nout8, j ) = am - cp + zout ( 2, nout8, j ) = bp - dp + END DO + END DO + END IF + ELSE IF ( now == 3 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, nout1, j ) = r + r1 + zout ( 2, nout1, j ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, nout2, j ) = r1 - s2 + zout ( 2, nout2, j ) = s1 + r2 + zout ( 1, nout3, j ) = r1 + s2 + zout ( 2, nout3, j ) = s1 - r2 + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 4*ias == 3*after ) THEN + IF ( isign == 1 ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2=nin1+atb + nin3=nin2+atb + nout1=nout1+atn + nout2=nout1+after + nout3=nout2+after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = -zin ( 2, j, nin2 ) + s2 = zin ( 1, j, nin2 ) + r3 = -zin ( 1, j, nin3 ) + s3 = -zin ( 2, j, nin3 ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, nout1, j ) = r + r1 + zout ( 2, nout1, j ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb*(r2-r3) + s2 = bb*(s2-s3) + zout ( 1, nout2, j ) = r1 - s2 + zout ( 2, nout2, j ) = s1 + r2 + zout ( 1, nout3, j ) = r1 + s2 + zout ( 2, nout3, j ) = s1 - r2 + END DO + END DO + ELSE + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 2, j, nin2 ) + s2 = -zin ( 1, j, nin2 ) + r3 = -zin ( 1, j, nin3 ) + s3 = -zin ( 2, j, nin3 ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, nout1, j ) = r + r1 + zout ( 2, nout1, j ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, nout2, j ) = r1 - s2 + zout ( 2, nout2, j ) = s1 + r2 + zout ( 1, nout3, j ) = r1 + s2 + zout ( 2, nout3, j ) = s1 - r2 + END DO + END DO + END IF + ELSE IF ( 8 * ias == 3 * after ) THEN + IF ( isign == 1 ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r - s ) * rt2i + s2 = ( r + s ) * rt2i + r3 = -zin ( 2, j, nin3 ) + s3 = zin ( 1, j, nin3 ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, nout1, j ) = r + r1 + zout ( 2, nout1, j ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, nout2, j ) = r1 - s2 + zout ( 2, nout2, j ) = s1 + r2 + zout ( 1, nout3, j ) = r1 + s2 + zout ( 2, nout3, j ) = s1 - r2 + END DO + END DO + ELSE + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r + s ) * rt2i + s2 = ( -r + s ) * rt2i + r3 = zin ( 2, j, nin3 ) + s3 = -zin ( 1, j, nin3 ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, nout1, j ) = r + r1 + zout ( 2, nout1, j ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, nout2, j ) = r1 - s2 + zout ( 2, nout2, j ) = s1 + r2 + zout ( 1, nout3, j ) = r1 + s2 + zout ( 2, nout3, j ) = s1 - r2 + END DO + END DO + END IF + ELSE + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, j, nin3 ) + s = zin ( 2, j, nin3 ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = r2 + r3 + s = s2 + s3 + zout ( 1, nout1, j ) = r + r1 + zout ( 2, nout1, j ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, nout2, j ) = r1 - s2 + zout ( 2, nout2, j ) = s1 + r2 + zout ( 1, nout3, j ) = r1 + s2 + zout ( 2, nout3, j ) = s1 - r2 + END DO + END DO + END IF + END DO + ELSE IF ( now == 5 ) THEN + sin2 = isign * sin2p + sin4 = isign * sin4p + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r4 = zin ( 1, j, nin4 ) + s4 = zin ( 2, j, nin4 ) + r5 = zin ( 1, j, nin5 ) + s5 = zin ( 2, j, nin5 ) + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, nout1, j ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, nout2, j ) = r - s + zout ( 1, nout5, j ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, nout3, j ) = r - s + zout ( 1, nout4, j ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, nout1, j ) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, nout2, j ) = r + s + zout ( 2, nout5, j ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, nout3, j ) = r + s + zout ( 2, nout4, j ) = r - s + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 8 * ias == 5 * after ) THEN + IF ( isign == 1 ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r - s ) * rt2i + s2 = ( r + s ) * rt2i + r3 = -zin ( 2, j, nin3 ) + s3 = zin ( 1, j, nin3 ) + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = -( r + s ) * rt2i + s4 = ( r - s ) * rt2i + r5 = -zin ( 1, j, nin5 ) + s5 = -zin ( 2, j, nin5 ) + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, nout1, j ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, nout2, j ) = r - s + zout ( 1, nout5, j ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, nout3, j ) = r - s + zout ( 1, nout4, j ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, nout1, j ) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, nout2, j ) = r + s + zout ( 2, nout5, j ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, nout3, j ) = r + s + zout ( 2, nout4, j ) = r - s + END DO + END DO + ELSE + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r + s ) * rt2i + s2 = ( -r + s ) * rt2i + r3 = zin ( 2, j, nin3 ) + s3 = -zin ( 1, j, nin3 ) + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = ( s - r ) * rt2i + s4 = - ( r + s ) * rt2i + r5 = -zin ( 1, j, nin5 ) + s5 = -zin ( 2, j, nin5 ) + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, nout1, j ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, nout2, j ) = r - s + zout ( 1, nout5, j ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, nout3, j ) = r - s + zout ( 1, nout4, j ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, nout1, j ) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, nout2, j ) = r + s + zout ( 2, nout5, j ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, nout3, j ) = r + s + zout ( 2, nout4, j ) = r - s + END DO + END DO + END IF + ELSE + ias = ia - 1 + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + itrig = itrig + itt + cr4 = trig ( 1, itrig ) + ci4 = trig ( 2, itrig ) + itrig = itrig + itt + cr5 = trig ( 1, itrig ) + ci5 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, j, nin3 ) + s = zin ( 2, j, nin3 ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = r * cr4 - s * ci4 + s4 = r * ci4 + s * cr4 + r = zin ( 1, j, nin5 ) + s = zin ( 2, j, nin5 ) + r5 = r * cr5 - s * ci5 + s5 = r * ci5 + s * cr5 + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, nout1, j ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, nout2, j ) = r - s + zout ( 1, nout5, j ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, nout3, j ) = r - s + zout ( 1, nout4, j ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, nout1, j ) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, nout2, j ) = r + s + zout ( 2, nout5, j ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, nout3, j ) = r + s + zout ( 2, nout4, j ) = r - s + END DO + END DO + END IF + END DO + ELSE IF ( now == 6 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nin6 = nin5 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + nout6 = nout5 + after + DO j = 1, nfft + r2 = zin ( 1, j, nin3 ) + s2 = zin ( 2, j, nin3 ) + r3 = zin ( 1, j, nin5 ) + s3 = zin ( 2, j, nin5 ) + r = r2 + r3 + s = s2 + s3 + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + ur1 = r + r1 + ui1 = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r = r2 - r3 + s = s2 - s3 + ur2 = r1 - s * bb + ui2 = s1 + r * bb + ur3 = r1 + s * bb + ui3 = s1 - r * bb + + r2 = zin ( 1, j, nin6 ) + s2 = zin ( 2, j, nin6 ) + r3 = zin ( 1, j, nin2 ) + s3 = zin ( 2, j, nin2 ) + r = r2 + r3 + s = s2 + s3 + r1 = zin ( 1, j, nin4 ) + s1 = zin ( 2, j, nin4 ) + vr1 = r + r1 + vi1 = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r = r2 - r3 + s = s2 - s3 + vr2 = r1 - s * bb + vi2 = s1 + r * bb + vr3 = r1 + s * bb + vi3 = s1 - r * bb + + zout ( 1, nout1, j ) = ur1 + vr1 + zout ( 2, nout1, j ) = ui1 + vi1 + zout ( 1, nout5, j ) = ur2 + vr2 + zout ( 2, nout5, j ) = ui2 + vi2 + zout ( 1, nout3, j ) = ur3 + vr3 + zout ( 2, nout3, j ) = ui3 + vi3 + zout ( 1, nout4, j ) = ur1 - vr1 + zout ( 2, nout4, j ) = ui1 - vi1 + zout ( 1, nout2, j ) = ur2 - vr2 + zout ( 2, nout2, j ) = ui2 - vi2 + zout ( 1, nout6, j ) = ur3 - vr3 + zout ( 2, nout6, j ) = ui3 - vi3 + END DO + END DO + ELSE + STOP 'Error fftrot' + END If + +!-----------------------------------------------------------------------------! + +END SUBROUTINE fftrot + +!-----------------------------------------------------------------------------! diff --git a/src/lib/fftstp.F b/src/lib/fftstp.F new file mode 100644 index 0000000000..18bea9e93c --- /dev/null +++ b/src/lib/fftstp.F @@ -0,0 +1,1051 @@ +!-----------------------------------------------------------------------------! +!Copyright by Stefan Goedecker, Cornell, Ithaca, USA, March 25, 1994 +!modified by Stefan Goedecker, Stuttgart, Germany, October 15, 1995 +!Commercial use is prohibited without the explicit permission of the author. +!-----------------------------------------------------------------------------! + +SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, & + trig, now, after, before, isign ) + + IMPLICIT NONE + + INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 ) + +! Arguments + INTEGER, INTENT ( IN ) :: mm, nfft, m, nn, n, now, after, before, isign + REAL ( dbl ), DIMENSION ( 2, 1024 ), INTENT ( IN ) :: trig + REAL ( dbl ), DIMENSION ( 2, mm, m ), INTENT ( IN ) :: zin + REAL ( dbl ), DIMENSION ( 2, nn, n ), INTENT ( OUT ) :: zout + + INTEGER :: atn, atb, ia, ib, nin1, nin2, nin3, nin4, nin5, nin6, nin7, nin8 + INTEGER :: nout1, nout2, nout3, nout4, nout5, nout6, nout7, nout8, & + i, j, ias, itt, itrig + REAL ( dbl ) :: s, s1, s2, s3, s4, s5, s6, s7, s8, & + r, r1, r2, r3, r4, r5, r6, r7, r8, cr2, cr3, cr4, cr5, & + ci2, ci3, ci4, ci5, ur1, ur2, ur3, ui1, ui2, ui3, & + vr1, vr2, vr3, vi1, vi2, vi3, cm, cp, dm, dp, & + am, ap, bm, bp,s25, s34, r34, r25, sin2, sin4 + REAL ( dbl ), PARAMETER :: rt2i = 0.7071067811865475_dbl ! sqrt(0.5) + REAL ( dbl ), PARAMETER :: bb = 0.8660254037844387_dbl ! sqrt(3)/2 + REAL ( dbl ), PARAMETER :: cos2 = 0.3090169943749474_dbl ! cos(2*pi/5) + REAL ( dbl ), PARAMETER :: cos4 = - 0.8090169943749474_dbl ! cos(4*pi/5) + REAL ( dbl ), PARAMETER :: sin2p = 0.9510565162951536_dbl ! sin(2*pi/5) + REAL ( dbl ), PARAMETER :: sin4p = 0.5877852522924731_dbl ! sin(4*pi/5) + +!-----------------------------------------------------------------------------! + + atn = after * now + atb = after * before + + IF ( now == 4 ) THEN + IF ( isign == 1 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r4 = zin ( 1, j, nin4 ) + s4 = zin ( 2, j, nin4 ) + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout4 ) = r + s + r = s1 + s3 + s = s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 2*ias == after ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r - s ) * rt2i + s2 = ( r + s ) * rt2i + r3 = - zin ( 2, j, nin3 ) + s3 = zin ( 1, j, nin3 ) + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = - ( r + s ) * rt2i + s4 = ( r - s ) * rt2i + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout4 ) = r + s + r = s1 + s3 + s = s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + ELSE + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + itrig = itrig + itt + cr4 = trig ( 1, itrig ) + ci4 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, j, nin3 ) + s = zin ( 2, j, nin3 ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = r * cr4 - s * ci4 + s4 = r * ci4 + s * cr4 + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout4 ) = r + s + r = s1 + s3 + s = s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + END IF + END DO + ELSE + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r4 = zin ( 1, j, nin4 ) + s4 = zin ( 2, j, nin4 ) + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r + s + zout ( 1, j, nout4 ) = r - s + r = s1 + s3 + s = s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r - s + zout ( 2, j, nout4 ) = r + s + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 2 * ias == after ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r + s ) * rt2i + s2 = ( s - r ) * rt2i + r3 = zin ( 2, j, nin3 ) + s3 = - zin ( 1, j, nin3 ) + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = ( s - r ) * rt2i + s4 = - ( r + s ) * rt2i + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r + s + zout ( 1, j, nout4 ) = r - s + r =s1 + s3 + s =s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r - s + zout ( 2, j, nout4 ) = r + s + END DO + END DO + ELSE + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + itrig = itrig + itt + cr4 = trig ( 1, itrig ) + ci4 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, j, nin3 ) + s = zin ( 2, j, nin3 ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = r * cr4 - s * ci4 + s4 = r * ci4 + s * cr4 + r = r1 + r3 + s = r2 + r4 + zout ( 1, j, nout1 ) = r + s + zout ( 1, j, nout3 ) = r - s + r = r1 - r3 + s = s2 - s4 + zout ( 1, j, nout2 ) = r + s + zout ( 1, j, nout4 ) = r - s + r = s1 + s3 + s = s2 + s4 + zout ( 2, j, nout1 ) = r + s + zout ( 2, j, nout3 ) = r - s + r = s1 - s3 + s = r2 - r4 + zout ( 2, j, nout2 ) = r - s + zout ( 2, j, nout4 ) = r + s + END DO + END DO + END IF + END DO + END IF + ELSE IF ( now == 8 ) THEN + IF ( isign == -1 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nin6 = nin5 + atb + nin7 = nin6 + atb + nin8 = nin7 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + nout6 = nout5 + after + nout7 = nout6 + after + nout8 = nout7 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r4 = zin ( 1, j, nin4 ) + s4 = zin ( 2, j, nin4 ) + r5 = zin ( 1, j, nin5 ) + s5 = zin ( 2, j, nin5 ) + r6 = zin ( 1, j, nin6 ) + s6 = zin ( 2, j, nin6 ) + r7 = zin ( 1, j, nin7 ) + s7 = zin ( 2, j, nin7 ) + r8 = zin ( 1, j, nin8 ) + s8 = zin ( 2, j, nin8 ) + r = r1 + r5 + s = r3 + r7 + ap = r + s + am = r - s + r = r2 + r6 + s = r4 + r8 + bp = r + s + bm = r - s + r = s1 + s5 + s = s3 + s7 + cp = r + s + cm = r - s + r = s2 + s6 + s = s4 + s8 + dp = r + s + dm = r - s + zout ( 1, j, nout1 ) = ap + bp + zout ( 2, j, nout1 ) = cp + dp + zout ( 1, j, nout5 ) = ap - bp + zout ( 2, j, nout5 ) = cp - dp + zout ( 1, j, nout3 ) = am + dm + zout ( 2, j, nout3 ) = cm - bm + zout ( 1, j, nout7 ) = am - dm + zout ( 2, j, nout7 ) = cm + bm + r = r1 - r5 + s = s3 - s7 + ap = r + s + am = r - s + r = s1 - s5 + s = r3 - r7 + bp = r + s + bm = r - s + r = s4 - s8 + s = r2 - r6 + cp = r + s + cm = r - s + r = s2 - s6 + s = r4 - r8 + dp = r + s + dm = r - s + r = ( cp + dm ) * rt2i + s = (-cp + dm ) * rt2i + cp = ( cm + dp ) * rt2i + dp = ( cm - dp ) * rt2i + zout ( 1, j, nout2 ) = ap + r + zout ( 2, j, nout2 ) = bm + s + zout ( 1, j, nout6 ) = ap - r + zout ( 2, j, nout6 ) = bm - s + zout ( 1, j, nout4 ) = am + cp + zout ( 2, j, nout4 ) = bp + dp + zout ( 1, j, nout8 ) = am - cp + zout ( 2, j, nout8 ) = bp - dp + END DO + END DO + ELSE + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nin6 = nin5 + atb + nin7 = nin6 + atb + nin8 = nin7 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + nout6 = nout5 + after + nout7 = nout6 + after + nout8 = nout7 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r4 = zin ( 1, j, nin4 ) + s4 = zin ( 2, j, nin4 ) + r5 = zin ( 1, j, nin5 ) + s5 = zin ( 2, j, nin5 ) + r6 = zin ( 1, j, nin6 ) + s6 = zin ( 2, j, nin6 ) + r7 = zin ( 1, j, nin7 ) + s7 = zin ( 2, j, nin7 ) + r8 = zin ( 1, j, nin8 ) + s8 = zin ( 2, j, nin8 ) + r = r1 + r5 + s = r3 + r7 + ap = r + s + am = r - s + r = r2 + r6 + s = r4 + r8 + bp = r + s + bm = r - s + r = s1 + s5 + s = s3 + s7 + cp = r + s + cm = r - s + r = s2 + s6 + s = s4 + s8 + dp = r + s + dm = r - s + zout ( 1, j, nout1 ) = ap + bp + zout ( 2, j, nout1 ) = cp + dp + zout ( 1, j, nout5 ) = ap - bp + zout ( 2, j, nout5 ) = cp - dp + zout ( 1, j, nout3 ) = am - dm + zout ( 2, j, nout3 ) = cm + bm + zout ( 1, j, nout7 ) = am + dm + zout ( 2, j, nout7 ) = cm - bm + r = r1 - r5 + s = -s3 + s7 + ap = r + s + am = r - s + r = s1 - s5 + s = r7 - r3 + bp = r + s + bm = r - s + r = -s4 + s8 + s = r2 - r6 + cp = r + s + cm = r - s + r = -s2 + s6 + s = r4 - r8 + dp = r + s + dm = r - s + r = ( cp + dm ) * rt2i + s = ( cp - dm ) * rt2i + cp = ( cm + dp ) * rt2i + dp = (-cm + dp ) * rt2i + zout ( 1, j, nout2 ) = ap + r + zout ( 2, j, nout2 ) = bm + s + zout ( 1, j, nout6 ) = ap - r + zout ( 2, j, nout6 ) = bm - s + zout ( 1, j, nout4 ) = am + cp + zout ( 2, j, nout4 ) = bp + dp + zout ( 1, j, nout8 ) = am - cp + zout ( 2, j, nout8 ) = bp - dp + END DO + END DO + END IF + ELSE IF ( now == 3 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 4*ias == 3*after ) THEN + IF ( isign == 1 ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2=nin1+atb + nin3=nin2+atb + nout1=nout1+atn + nout2=nout1+after + nout3=nout2+after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = -zin ( 2, j, nin2 ) + s2 = zin ( 1, j, nin2 ) + r3 = -zin ( 1, j, nin3 ) + s3 = -zin ( 2, j, nin3 ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb*(r2-r3) + s2 = bb*(s2-s3) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + ELSE + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 2, j, nin2 ) + s2 = -zin ( 1, j, nin2 ) + r3 = -zin ( 1, j, nin3 ) + s3 = -zin ( 2, j, nin3 ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + END IF + ELSE IF ( 8 * ias == 3 * after ) THEN + IF ( isign == 1 ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r - s ) * rt2i + s2 = ( r + s ) * rt2i + r3 = -zin ( 2, j, nin3 ) + s3 = zin ( 1, j, nin3 ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + ELSE + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r + s ) * rt2i + s2 = ( -r + s ) * rt2i + r3 = zin ( 2, j, nin3 ) + s3 = -zin ( 1, j, nin3 ) + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + END IF + ELSE + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, j, nin3 ) + s = zin ( 2, j, nin3 ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = r2 + r3 + s = s2 + s3 + zout ( 1, j, nout1 ) = r + r1 + zout ( 2, j, nout1 ) = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r2 = bb * ( r2 - r3 ) + s2 = bb * ( s2 - s3 ) + zout ( 1, j, nout2 ) = r1 - s2 + zout ( 2, j, nout2 ) = s1 + r2 + zout ( 1, j, nout3 ) = r1 + s2 + zout ( 2, j, nout3 ) = s1 - r2 + END DO + END DO + END IF + END DO + ELSE IF ( now == 5 ) THEN + sin2 = isign * sin2p + sin4 = isign * sin4p + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r2 = zin ( 1, j, nin2 ) + s2 = zin ( 2, j, nin2 ) + r3 = zin ( 1, j, nin3 ) + s3 = zin ( 2, j, nin3 ) + r4 = zin ( 1, j, nin4 ) + s4 = zin ( 2, j, nin4 ) + r5 = zin ( 1, j, nin5 ) + s5 = zin ( 2, j, nin5 ) + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, j, nout1 ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout5 ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, j, nout3 ) = r - s + zout ( 1, j, nout4 ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, j, nout1 ) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout5 ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, j, nout3 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + DO ia = 2, after + ias = ia - 1 + IF ( 8 * ias == 5 * after ) THEN + IF ( isign == 1 ) THEN + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r - s ) * rt2i + s2 = ( r + s ) * rt2i + r3 = -zin ( 2, j, nin3 ) + s3 = zin ( 1, j, nin3 ) + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = -( r + s ) * rt2i + s4 = ( r - s ) * rt2i + r5 = -zin ( 1, j, nin5 ) + s5 = -zin ( 2, j, nin5 ) + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, j, nout1 ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout5 ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, j, nout3 ) = r - s + zout ( 1, j, nout4 ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, j, nout1 ) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout5 ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, j, nout3 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + ELSE + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = ( r + s ) * rt2i + s2 = ( -r + s ) * rt2i + r3 = zin ( 2, j, nin3 ) + s3 = -zin ( 1, j, nin3 ) + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = ( s - r ) * rt2i + s4 = - ( r + s ) * rt2i + r5 = -zin ( 1, j, nin5 ) + s5 = -zin ( 2, j, nin5 ) + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, j, nout1 ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout5 ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, j, nout3 ) = r - s + zout ( 1, j, nout4 ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, j, nout1) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout5 ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, j, nout3 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + END IF + ELSE + ias = ia - 1 + itt = ias * before + itrig = itt + 1 + cr2 = trig ( 1, itrig ) + ci2 = trig ( 2, itrig ) + itrig = itrig + itt + cr3 = trig ( 1, itrig ) + ci3 = trig ( 2, itrig ) + itrig = itrig + itt + cr4 = trig ( 1, itrig ) + ci4 = trig ( 2, itrig ) + itrig = itrig + itt + cr5 = trig ( 1, itrig ) + ci5 = trig ( 2, itrig ) + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + DO j = 1, nfft + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + r = zin ( 1, j, nin2 ) + s = zin ( 2, j, nin2 ) + r2 = r * cr2 - s * ci2 + s2 = r * ci2 + s * cr2 + r = zin ( 1, j, nin3 ) + s = zin ( 2, j, nin3 ) + r3 = r * cr3 - s * ci3 + s3 = r * ci3 + s * cr3 + r = zin ( 1, j, nin4 ) + s = zin ( 2, j, nin4 ) + r4 = r * cr4 - s * ci4 + s4 = r * ci4 + s * cr4 + r = zin ( 1, j, nin5 ) + s = zin ( 2, j, nin5 ) + r5 = r * cr5 - s * ci5 + s5 = r * ci5 + s * cr5 + r25 = r2 + r5 + r34 = r3 + r4 + s25 = s2 - s5 + s34 = s3 - s4 + zout ( 1, j, nout1 ) = r1 + r25 + r34 + r = cos2 * r25 + cos4 * r34 + r1 + s = sin2 * s25 + sin4 * s34 + zout ( 1, j, nout2 ) = r - s + zout ( 1, j, nout5 ) = r + s + r = cos4 * r25 + cos2 * r34 + r1 + s = sin4 * s25 - sin2 * s34 + zout ( 1, j, nout3 ) = r - s + zout ( 1, j, nout4 ) = r + s + r25 = r2 - r5 + r34 = r3 - r4 + s25 = s2 + s5 + s34 = s3 + s4 + zout ( 2, j, nout1 ) = s1 + s25 + s34 + r = cos2 * s25 + cos4 * s34 + s1 + s = sin2 * r25 + sin4 * r34 + zout ( 2, j, nout2 ) = r + s + zout ( 2, j, nout5 ) = r - s + r = cos4 * s25 + cos2 * s34 + s1 + s = sin4 * r25 - sin2 * r34 + zout ( 2, j, nout3 ) = r + s + zout ( 2, j, nout4 ) = r - s + END DO + END DO + END IF + END DO + ELSE IF ( now == 6 ) THEN + ia = 1 + nin1 = ia - after + nout1 = ia - atn + DO ib = 1, before + nin1 = nin1 + after + nin2 = nin1 + atb + nin3 = nin2 + atb + nin4 = nin3 + atb + nin5 = nin4 + atb + nin6 = nin5 + atb + nout1 = nout1 + atn + nout2 = nout1 + after + nout3 = nout2 + after + nout4 = nout3 + after + nout5 = nout4 + after + nout6 = nout5 + after + DO j = 1, nfft + r2 = zin ( 1, j, nin3 ) + s2 = zin ( 2, j, nin3 ) + r3 = zin ( 1, j, nin5 ) + s3 = zin ( 2, j, nin5 ) + r = r2 + r3 + s = s2 + s3 + r1 = zin ( 1, j, nin1 ) + s1 = zin ( 2, j, nin1 ) + ur1 = r + r1 + ui1 = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r = r2 - r3 + s = s2 - s3 + ur2 = r1 - s * bb + ui2 = s1 + r * bb + ur3 = r1 + s * bb + ui3 = s1 - r * bb + + r2 = zin ( 1, j, nin6 ) + s2 = zin ( 2, j, nin6 ) + r3 = zin ( 1, j, nin2 ) + s3 = zin ( 2, j, nin2 ) + r = r2 + r3 + s = s2 + s3 + r1 = zin ( 1, j, nin4 ) + s1 = zin ( 2, j, nin4 ) + vr1 = r + r1 + vi1 = s + s1 + r1 = r1 - 0.5_dbl * r + s1 = s1 - 0.5_dbl * s + r = r2 - r3 + s = s2 - s3 + vr2 = r1 - s * bb + vi2 = s1 + r * bb + vr3 = r1 + s * bb + vi3 = s1 - r * bb + + zout ( 1, j, nout1 ) = ur1 + vr1 + zout ( 2, j, nout1 ) = ui1 + vi1 + zout ( 1, j, nout5 ) = ur2 + vr2 + zout ( 2, j, nout5 ) = ui2 + vi2 + zout ( 1, j, nout3 ) = ur3 + vr3 + zout ( 2, j, nout3 ) = ui3 + vi3 + zout ( 1, j, nout4 ) = ur1 - vr1 + zout ( 2, j, nout4 ) = ui1 - vi1 + zout ( 1, j, nout2 ) = ur2 - vr2 + zout ( 2, j, nout2 ) = ui2 - vi2 + zout ( 1, j, nout6 ) = ur3 - vr3 + zout ( 2, j, nout6 ) = ui3 - vi3 + END DO + END DO + ELSE + STOP 'Error fftstp' + END If + +!-----------------------------------------------------------------------------! + +END SUBROUTINE fftstp + +!-----------------------------------------------------------------------------! diff --git a/src/lib/mltfftsg.F b/src/lib/mltfftsg.F new file mode 100644 index 0000000000..c63ff79b4e --- /dev/null +++ b/src/lib/mltfftsg.F @@ -0,0 +1,133 @@ +!-----------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!-----------------------------------------------------------------------------! + +SUBROUTINE mltfftsg ( transa, transb, a, ldax, lday, b, ldbx, ldby, & + n, m, isign, scale ) + + IMPLICIT NONE + + INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 ) + +! Arguments + CHARACTER ( LEN = 1 ), INTENT ( IN ) :: transa*1, transb*1 + INTEGER, INTENT ( IN ) :: ldax, lday, ldbx, ldby, n, m, isign + COMPLEX ( dbl ), INTENT ( INOUT ) :: a ( ldax, lday ), b ( ldbx, ldby ) + REAL ( dbl ), INTENT ( IN ) :: scale + +! Variables + INTEGER, SAVE :: ncache + INTEGER :: after ( 20 ), now ( 20 ), before ( 20 ) + REAL ( dbl ) :: trig ( 2, 1024 ) + LOGICAL :: tscal + COMPLEX ( dbl ), DIMENSION ( :, : ), ALLOCATABLE, SAVE :: z + INTEGER :: length, isig, ic, lot, itr, nfft, i, inzee, j + +!-----------------------------------------------------------------------------! + + IF( .NOT. ALLOCATED ( Z ) ) THEN + ncache = get_cache_size ( ) + LENGTH = 2 * ( NCACHE / 4 + 1 ) + ALLOCATE ( Z ( LENGTH, 2 ) ) + END IF + + ISIG = -ISIGN + TSCAL = ( ABS ( SCALE -1._dbl ) > 1.e-12_dbl ) + CALL CTRIG ( N, TRIG, AFTER, BEFORE, NOW, ISIG, IC ) + LOT = NCACHE / ( 4 * N ) + LOT = LOT - MOD ( LOT + 1, 2 ) + LOT = MAX ( 1, LOT ) + DO ITR = 1, M, LOT + NFFT = MIN ( M - ITR + 1, LOT ) + IF ( TRANSA == 'N' .OR. TRANSA == 'n' ) THEN + CALL FFTPRE ( NFFT, NFFT, LDAX, LOT, N, A ( 1, ITR ), Z ( 1, 1 ), & + TRIG, NOW ( 1 ), AFTER ( 1 ), BEFORE ( 1 ), ISIG ) + ELSE + CALL FFTSTP ( LDAX, NFFT, N, LOT, N, A ( ITR, 1 ), Z ( 1, 1 ), & + TRIG, NOW ( 1 ), AFTER ( 1 ), BEFORE ( 1 ), ISIG ) + ENDIF + IF ( TSCAL ) THEN + IF ( LOT == NFFT ) THEN + CALL DSCAL ( 2 * LOT * N, SCALE, Z ( 1, 1 ), 1 ) + ELSE + DO I = 1, N + CALL DSCAL ( 2 * NFFT, SCALE, Z ( LOT * ( I - 1 ) + 1, 1 ), 1 ) + END DO + END IF + END IF + IF(IC.EQ.1) THEN + IF(TRANSB == 'N'.OR.TRANSB == 'n') THEN + CALL ZGETMO(Z(1,1),LOT,NFFT,N,B(1,ITR),LDBX) + ELSE + CALL MATMOV(NFFT,N,Z(1,1),LOT,B(ITR,1),LDBX) + ENDIF + ELSE + INZEE=1 + DO I=2,IC-1 + CALL FFTSTP(LOT,NFFT,N,LOT,N,Z(1,INZEE), & + Z(1,3-INZEE),TRIG,NOW(I),AFTER(I), & + BEFORE(I),ISIG) + INZEE=3-INZEE + ENDDO + IF(TRANSB == 'N'.OR.TRANSB == 'n') THEN + CALL FFTROT(LOT,NFFT,N,NFFT,LDBX,Z(1,INZEE), & + B(1,ITR),TRIG,NOW(IC),AFTER(IC),BEFORE(IC),ISIG) + ELSE + CALL FFTSTP(LOT,NFFT,N,LDBX,N,Z(1,INZEE), & + B(ITR,1),TRIG,NOW(IC),AFTER(IC),BEFORE(IC),ISIG) + ENDIF + ENDIF + ENDDO + IF(TRANSB == 'N'.OR.TRANSB == 'n') THEN + B(1:LDBX,M+1:LDBY) = CMPLX(0._dbl,0._dbl,dbl) + B(N+1:LDBX,1:M) = CMPLX(0._dbl,0._dbl,dbl) + ELSE + B(1:LDBX,N+1:LDBY) = CMPLX(0._dbl,0._dbl,dbl) + B(M+1:LDBX,1:M) = CMPLX(0._dbl,0._dbl,dbl) + ENDIF + +!****************************************************************************** + + CONTAINS + +!****************************************************************************** + + SUBROUTINE matmov ( n, m, a, lda, b, ldb ) + IMPLICIT NONE + INTEGER :: n, m, lda, ldb + COMPLEX (dbl) :: a ( lda, * ), b ( ldb, * ) + b ( 1:n , 1:m ) = a ( 1:n, 1:m ) + END SUBROUTINE matmov + + SUBROUTINE zgetmo ( a, lda, m, n, b, ldb ) + IMPLICIT NONE + INTEGER :: lda, m, n, ldb + COMPLEX(dbl) :: a ( lda, n ), b ( ldb, m ) + b ( 1:n, 1:m ) = TRANSPOSE ( a ( 1:m, 1:n ) ) + END SUBROUTINE zgetmo + + FUNCTION get_cache_size ( ) RESULT ( ncache ) + IMPLICIT NONE + INTEGER ncache +#if defined ( __T3E ) + ncache = 1024*8 +#elif defined ( __SX5 ) || defined ( __T90 ) + ncache = 1024*128 +#elif defined ( __ALPHA ) + ncache = 1024*8 +#elif defined ( __SGI ) + ncache = 1024*4 +#elif defined ( __POWER2 ) + ncache = 1024*10 +#elif defined ( __HP ) + ncache = 1024*64 +#else + ncache = 1024*2 +#endif + + END FUNCTION get_cache_size + +!****************************************************************************** + +END SUBROUTINE mltfftsg diff --git a/src/library_tests.F b/src/library_tests.F new file mode 100644 index 0000000000..a4e9311bc2 --- /dev/null +++ b/src/library_tests.F @@ -0,0 +1,352 @@ +!-----------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!-----------------------------------------------------------------------------! + +MODULE library_tests + + USE kinds, ONLY : dbl + USE fft_tools, ONLY : init_fft, get_fft_library, fft3d, & + fft_radix_operations, FWFFT, BWFFT, FFT_RADIX_CLOSEST + USE global_types, ONLY : global_environment_type + USE machine, ONLY : m_cputime + USE stop_program, ONLY : stop_memory + + IMPLICIT NONE + + PRIVATE + PUBLIC :: lib_test + + INTEGER :: runtest ( 100 ) + +!****************************************************************************** + +CONTAINS + +!****************************************************************************** + +SUBROUTINE lib_test ( globenv ) + + TYPE ( global_environment_type ), INTENT ( IN ) :: globenv + + INTEGER :: iw + + iw = globenv % scr + IF ( globenv % ionode ) THEN + WRITE ( iw, '(T2,79("*"))' ) + WRITE ( iw, '(A,T31,A,T80,A)' ) ' *',' PERFORMANCE TESTS ','*' + WRITE ( iw, '(T2,79("*"))' ) + END IF +! +! CALL test_input ( globenv ) + runtest = 0 + runtest ( 3 ) = 1 +! + IF ( runtest ( 1 ) == 1 ) CALL copy_test ( globenv ) +! + IF ( runtest ( 2 ) == 1 ) CALL matmul_test ( globenv ) +! + IF ( runtest ( 3 ) == 1 ) CALL fft_test ( globenv ) + +END SUBROUTINE lib_test + +!****************************************************************************** + +SUBROUTINE copy_test ( globenv ) + + TYPE ( global_environment_type ), INTENT ( IN ) :: globenv + + REAL ( dbl ), DIMENSION ( : ), ALLOCATABLE :: ca, cb + INTEGER :: len, ntim, iw, ierr, i, j + REAL ( dbl ) :: perf, tstart, tend, t + +! test for copy --> Cache size + iw = globenv % scr + IF ( globenv % ionode ) WRITE ( iw, '(//,A,/)' ) " Test of copy ( F95 ) " + DO i = 6, 24 + len = 2**i + ALLOCATE ( ca ( len ), STAT = ierr ) + IF ( ierr /= 0 ) EXIT + ALLOCATE ( cb ( len ), STAT = ierr ) + IF ( ierr /= 0 ) EXIT + + CALL random_number ( ca ) + ntim = NINT ( 1.e7_dbl / REAL ( len, dbl ) ) + ntim = MAX ( ntim, 1 ) + ntim = MIN ( ntim, 50000 ) + + tstart = m_cputime ( ) + DO j = 1, ntim + cb ( : ) = ca ( : ) + ca ( 1 ) = REAL ( j, dbl ) + END DO + tend = m_cputime ( ) + t = tend - tstart + perf = REAL ( ntim, dbl ) * REAL ( len, dbl ) * 1.e-6_dbl / t + + IF ( globenv % ionode ) THEN + WRITE ( iw, '(A,i2,i10,A,T59,F14.4,A)' ) " Copy test: Size = 2^",i, & + len/1024," Kwords",perf," Mcopy/s" + END IF + + DEALLOCATE ( ca , STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "ca" ) + DEALLOCATE ( cb , STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "cb" ) + END DO + +END SUBROUTINE copy_test + +!****************************************************************************** + +SUBROUTINE matmul_test ( globenv ) + + TYPE ( global_environment_type ), INTENT ( IN ) :: globenv + + REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: ma, mb, mc + INTEGER :: len, ntim, iw, ierr, i, j + REAL ( dbl ) :: perf, tstart, tend, t + +! test for matrix multpies + iw = globenv % scr + IF ( globenv % ionode ) WRITE ( iw, '(//,A,/)' ) " Test of matmul ( F95 ) " + DO i = 4, 10, 2 + len = 2**i + 1 + ALLOCATE ( ma ( len, len ), STAT = ierr ) + IF ( ierr /= 0 ) EXIT + ALLOCATE ( mb ( len, len ), STAT = ierr ) + IF ( ierr /= 0 ) EXIT + ALLOCATE ( mc ( len, len ), STAT = ierr ) + IF ( ierr /= 0 ) EXIT + + CALL random_number ( ma ) + CALL random_number ( mb ) + ntim = NINT ( 1.e8_dbl / ( 2._dbl * REAL ( len, dbl )**3 ) ) + ntim = MAX ( ntim, 1 ) + ntim = MIN ( ntim, 1000 ) + + tstart = m_cputime ( ) + DO j = 1, ntim + mc = matmul ( ma, mb ) + ma ( 1, 1 ) = REAL ( j, dbl ) + END DO + tend = m_cputime ( ) + t = tend - tstart + perf = REAL ( ntim, dbl ) * 2._dbl * REAL ( len, dbl )**3 * 1.e-6_dbl / t + + IF ( globenv % ionode ) THEN + WRITE ( iw, '(A,i6,T59,F14.4,A)' ) & + " Matrix multiply test: c = a * b Size = ",len, perf," Mflop/s" + END IF + + tstart = m_cputime ( ) + DO j = 1, ntim + ma = matmul ( ma, mb ) + ma ( 1, 1 ) = REAL ( j, dbl ) + END DO + tend = m_cputime ( ) + t = tend - tstart + perf = REAL ( ntim, dbl ) * 2._dbl * REAL ( len, dbl )**3 * 1.e-6_dbl / t + + IF ( globenv % ionode ) THEN + WRITE ( iw, '(A,i6,T59,F14.4,A)' ) & + " Matrix multiply test: a = a * b Size = ",len, perf," Mflop/s" + END IF + + tstart = m_cputime ( ) + DO j = 1, ntim + mc = matmul ( ma, transpose ( mb ) ) + ma ( 1, 1 ) = REAL ( j, dbl ) + END DO + tend = m_cputime ( ) + t = tend - tstart + perf = REAL ( ntim, dbl ) * 2._dbl * REAL ( len, dbl )**3 * 1.e-6_dbl / t + + IF ( globenv % ionode ) THEN + WRITE ( iw, '(A,i6,T59,F14.4,A)' ) & + " Matrix multiply test: c = a * b(T) Size = ",len, perf," Mflop/s" + END IF + + tstart = m_cputime ( ) + DO j = 1, ntim + mc = matmul ( transpose ( ma ), mb ) + ma ( 1, 1 ) = REAL ( j, dbl ) + END DO + tend = m_cputime ( ) + t = tend - tstart + perf = REAL ( ntim, dbl ) * 2._dbl * REAL ( len, dbl )**3 * 1.e-6_dbl / t + + IF ( globenv % ionode ) THEN + WRITE ( iw, '(A,i6,T59,F14.4,A)' ) & + " Matrix multiply test: c = a(T) * b Size = ",len, perf," Mflop/s" + END IF + + DEALLOCATE ( ma , STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "ma" ) + DEALLOCATE ( mb , STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "mb" ) + DEALLOCATE ( mc , STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "mc" ) + END DO + +! test for matrix multpies + IF ( globenv % ionode ) WRITE ( iw, '(//,A,/)' ) " Test of matmul ( BLAS ) " + DO i = 4, 10, 2 + len = 2**i + 1 + ALLOCATE ( ma ( len, len ), STAT = ierr ) + IF ( ierr /= 0 ) EXIT + ALLOCATE ( mb ( len, len ), STAT = ierr ) + IF ( ierr /= 0 ) EXIT + ALLOCATE ( mc ( len, len ), STAT = ierr ) + IF ( ierr /= 0 ) EXIT + + CALL random_number ( ma ) + CALL random_number ( mb ) + ntim = NINT ( 1.e8_dbl / ( 2._dbl * REAL ( len, dbl )**3 ) ) + ntim = MAX ( ntim, 1 ) + ntim = MIN ( ntim, 1000 ) + + tstart = m_cputime ( ) + DO j = 1, ntim + CALL DGEMM ( "N", "N", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len ) + END DO + tend = m_cputime ( ) + t = tend - tstart + perf = REAL ( ntim, dbl ) * 2._dbl * REAL ( len, dbl )**3 * 1.e-6_dbl / t + + IF ( globenv % ionode ) THEN + WRITE ( iw, '(A,i6,T59,F14.4,A)' ) & + " Matrix multiply test: c = a * b Size = ",len, perf," Mflop/s" + END IF + + tstart = m_cputime ( ) + DO j = 1, ntim + CALL DGEMM ( "N", "N", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len ) + CALL DCOPY ( len * len , mc, 1, ma, 1) + END DO + tend = m_cputime ( ) + t = tend - tstart + perf = REAL ( ntim, dbl ) * 2._dbl * REAL ( len, dbl )**3 * 1.e-6_dbl / t + + IF ( globenv % ionode ) THEN + WRITE ( iw, '(A,i6,T59,F14.4,A)' ) & + " Matrix multiply test: a = a * b Size = ",len, perf," Mflop/s" + END IF + + tstart = m_cputime ( ) + DO j = 1, ntim + CALL DGEMM ( "N", "T", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len ) + END DO + tend = m_cputime ( ) + t = tend - tstart + perf = REAL ( ntim, dbl ) * 2._dbl * REAL ( len, dbl )**3 * 1.e-6_dbl / t + + IF ( globenv % ionode ) THEN + WRITE ( iw, '(A,i6,T59,F14.4,A)' ) & + " Matrix multiply test: c = a * b(T) Size = ",len, perf," Mflop/s" + END IF + + tstart = m_cputime ( ) + DO j = 1, ntim + CALL DGEMM ( "T", "N", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len ) + END DO + tend = m_cputime ( ) + t = tend - tstart + perf = REAL ( ntim, dbl ) * 2._dbl * REAL ( len, dbl )**3 * 1.e-6_dbl / t + + IF ( globenv % ionode ) THEN + WRITE ( iw, '(A,i6,T59,F14.4,A)' ) & + " Matrix multiply test: c = a(T) * b Size = ",len, perf," Mflop/s" + END IF + + DEALLOCATE ( ma , STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "ma" ) + DEALLOCATE ( mb , STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "mb" ) + DEALLOCATE ( mc , STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "mc" ) + END DO + +END SUBROUTINE matmul_test + +!****************************************************************************** + +SUBROUTINE fft_test ( globenv ) + + TYPE ( global_environment_type ), INTENT ( IN ) :: globenv + + COMPLEX ( dbl ), DIMENSION ( :, :, : ), ALLOCATABLE :: ca, cb + REAL ( dbl ), DIMENSION ( :, :, : ), ALLOCATABLE :: ra + COMPLEX ( dbl ), DIMENSION ( 4, 4, 4 ) :: zz + INTEGER :: len, ntim, iw, ierr, i, j, it, n(3), iall + REAL ( dbl ) :: perf, tstart, tend, t, flops, scale + INTEGER :: radix_in, radix_out, stat + INTEGER :: ndate ( 3 ) = (/ 12, 48, 128 /) + CHARACTER ( LEN = 6 ) :: method + +! test for 3d FFT + iw = globenv % scr + IF ( globenv % ionode ) WRITE ( iw, '(//,A,/)' ) " Test of 3D-FFT " + + DO iall = 1, 100 + SELECT CASE ( iall ) + CASE DEFAULT + EXIT + CASE ( 1 ) + CALL init_fft ( "FFTSG" ) + method = "FFTSG " + CASE ( 2 ) + CALL init_fft ( "FFTW" ) + method = "FFTW " + END SELECT + n = 4 + CALL fft3d ( 1, n, zz, status=stat ) + IF ( stat == 0 ) THEN + DO it = 1, 3 + radix_in = ndate ( it ) + CALL fft_radix_operations ( radix_in, radix_out, FFT_RADIX_CLOSEST ) + len = radix_out + n = len + ALLOCATE ( ra ( len, len, len ), STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "ra", len*len*len ) + ALLOCATE ( ca ( len, len, len ), STAT = ierr ) + IF ( ierr == 0 ) THEN + CALL random_number ( ra ) + ca = ra + CALL random_number ( ra ) + ca = ca + CMPLX ( 0._dbl, 1._dbl ) * ra + flops = REAL ( len**3, dbl ) * 15._dbl * LOG ( REAL ( len, dbl ) ) + ntim = NINT ( 5.e7_dbl / flops ) + ntim = MAX ( ntim, 1 ) + ntim = MIN ( ntim, 1000 ) + scale = 1._dbl / REAL ( len**3, dbl ) + tstart = m_cputime ( ) + DO j = 1, ntim + CALL fft3d ( FWFFT, n, ca ) + CALL fft3d ( BWFFT, n, ca, SCALE = scale ) + END DO + tend = m_cputime ( ) + t = tend - tstart + perf = REAL ( ntim, dbl ) * 2._dbl * flops * 1.e-6_dbl / t + + IF ( globenv % ionode ) THEN + WRITE ( iw, '(T2,A,A,i6,T59,F14.4,A)' ) & + adjustr(method)," test (in-place) Size = ",len, perf," Mflop/s" + END IF + DEALLOCATE ( ca , STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "ca" ) + DEALLOCATE ( ra , STAT = ierr ) + IF ( ierr /= 0 ) CALL stop_memory ( "lib_test", "ra" ) + END IF + END DO + END IF + IF ( globenv % ionode ) WRITE ( iw, * ) + END DO + +END SUBROUTINE fft_test + +!****************************************************************************** + +END MODULE library_tests + +!****************************************************************************** diff --git a/src/linklist_control.F b/src/linklist_control.F index 0a8a0ff841..362ccb2cc5 100644 --- a/src/linklist_control.F +++ b/src/linklist_control.F @@ -19,6 +19,7 @@ MODULE linklist_control USE particle_types, ONLY : particle_type USE simulation_cell, ONLY : cell_type USE stop_program, ONLY : stop_prg, stop_memory + USE timings, ONLY : timeset, timestop IMPLICIT NONE @@ -162,11 +163,13 @@ SUBROUTINE list_control ( pnode, part, box ) REAL ( dbl ), ALLOCATABLE, SAVE :: r_last_update ( :, : ) REAL ( dbl ) :: displace, max_displace LOGICAL :: list_update_flag, ionode - INTEGER :: i, nnodes, isos, iw + INTEGER :: i, nnodes, isos, iw, handle CHARACTER ( LEN = 36 ) :: string !------------------------------------------------------------------------------ + CALL timeset ( 'LIST_CONTROL','I',' ',handle ) + nnodes = SIZE ( pnode ) IF ( .NOT. ALLOCATED ( r_last_update ) ) THEN ALLOCATE ( r_last_update ( 3, nnodes ), STAT = isos ) @@ -234,6 +237,8 @@ SUBROUTINE list_control ( pnode, part, box ) END IF counter = counter + 1 + + CALL timestop ( 0._dbl, handle ) END SUBROUTINE list_control diff --git a/src/linklists.F b/src/linklists.F index 4209b47575..6cf3ab15e6 100644 --- a/src/linklists.F +++ b/src/linklists.F @@ -135,6 +135,7 @@ SUBROUTINE exclusion(molecule,pnode) bond(2) = ll_bond%p2%iatom ! checking to see if jatom is bonded + match=.FALSE. DO ii = 1, 2 IF (jatom==bond(ii)) THEN match = .TRUE. diff --git a/src/machine.F b/src/machine.F index 20b509c653..ae1da17fce 100644 --- a/src/machine.F +++ b/src/machine.F @@ -31,4 +31,16 @@ MODULE machine PUBLIC :: m_walltime, m_cputime, m_datum PUBLIC :: m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg +! +! FUNCTION m_cputime() +! FUNCTION m_walltime() +! SUBROUTINE m_datum(cal_date) +! SUBROUTINE m_hostnm(hname) +! SUBROUTINE m_getcwd(curdir) +! SUBROUTINE m_getlog(user) +! SUBROUTINE m_getuid(uid) +! SUBROUTINE m_getpid(pid) +! SUBROUTINE m_getarg(i,arg) +! + END MODULE machine diff --git a/src/nose.F b/src/nose.F index d701987b63..f23133607a 100644 --- a/src/nose.F +++ b/src/nose.F @@ -799,6 +799,8 @@ SUBROUTINE yoshida_coef ( nhcp, dt ) !------------------------------------------------------------------------------ SELECT CASE (nhcp % nyosh) + CASE DEFAULT + CALL stop_prg ( 'yoshida_coef', 'Value not available' ) CASE (1) yosh_wt(1) = 1.0_dbl CASE (3) @@ -819,8 +821,35 @@ SUBROUTINE yoshida_coef ( nhcp, dt ) yosh_wt(5) = yosh_wt(3) yosh_wt(6) = yosh_wt(2) yosh_wt(7) = yosh_wt(1) + CASE (9) + yosh_wt(1) = 0.192_dbl + yosh_wt(2) = 0.554910818409783619692725006662999_dbl + yosh_wt(3) = 0.124659619941888644216504240951585_dbl + yosh_wt(4) = -0.843182063596933505315033808282941_dbl + yosh_wt(5) = 1.0_dbl - 2.0_dbl*(yosh_wt(1)+yosh_wt(2)+& + yosh_wt(3)+yosh_wt(4)) + yosh_wt(6) = yosh_wt(4) + yosh_wt(7) = yosh_wt(3) + yosh_wt(8) = yosh_wt(2) + yosh_wt(9) = yosh_wt(1) + CASE (15) + yosh_wt(1) = 0.102799849391985_dbl + yosh_wt(2) = -0.196061023297549e1_dbl + yosh_wt(3) = 0.193813913762276e1_dbl + yosh_wt(4) = -0.158240635368243_dbl + yosh_wt(5) = -0.144485223686048e1_dbl + yosh_wt(6) = 0.253693336566229_dbl + yosh_wt(7) = 0.914844246229740_dbl + yosh_wt(8) = 1.0_dbl - 2.0_dbl*(yosh_wt(1)+yosh_wt(2)+& + yosh_wt(3)+yosh_wt(4)+yosh_wt(5)+yosh_wt(6)+yosh_wt(7)) + yosh_wt(9) = yosh_wt(7) + yosh_wt(10) = yosh_wt(6) + yosh_wt(11) = yosh_wt(5) + yosh_wt(12) = yosh_wt(4) + yosh_wt(13) = yosh_wt(3) + yosh_wt(14) = yosh_wt(2) + yosh_wt(15) = yosh_wt(1) END SELECT - nhcp % dt_yosh = dt * yosh_wt / REAL ( nhcp % nc, dbl ) END SUBROUTINE yoshida_coef diff --git a/src/pw_grids.F b/src/pw_grids.F index ee34d04b3d..7f53af413e 100644 --- a/src/pw_grids.F +++ b/src/pw_grids.F @@ -54,11 +54,11 @@ SUBROUTINE pw_grid_setup ( cell, pw_grid, cutoff ) pw_grid % ngpts = PRODUCT ( pw_grid % npts ) - IF ( PRESENT ( cutoff ) ) THEN - write ( 6, '( A, I8 )' ) "pw_grid_setup: #gpts = ", pw_grid % ngpts_cut - ELSE - write ( 6, '( A, I8 )' ) "pw_grid_setup: #gpts = ", pw_grid % ngpts - END IF +! IF ( PRESENT ( cutoff ) ) THEN +! write ( 6, '( A, I8 )' ) " PW_grid_setup| #gpts = ", pw_grid % ngpts_cut +! ELSE +! write ( 6, '( A, I8 )' ) " PW_grid_setup| #gpts = ", pw_grid % ngpts +! END IF ! Allocate the grid fields CALL pw_grid_allocate ( pw_grid ) diff --git a/src/pws.F b/src/pws.F index 2b7e843f12..6f3f8d71b2 100644 --- a/src/pws.F +++ b/src/pws.F @@ -7,7 +7,7 @@ MODULE pws USE coefficient_types, ONLY : coeff_type, coeff_allocate, coeff_deallocate, & SQUARE, SQUAREROOT - USE fft_tools, ONLY : fft3d => fft_wrap, & + USE fft_tools, ONLY : fft3d, & FWFFTu => FWFFT, BWFFTu => BWFFT, FWFFTw => FWFFT, BWFFTw => BWFFT USE kinds, ONLY : dbl USE mathconstants, ONLY : fourpi diff --git a/src/structure_types.F b/src/structure_types.F index d2875cf1bd..624d6ae450 100644 --- a/src/structure_types.F +++ b/src/structure_types.F @@ -9,20 +9,30 @@ MODULE structure_types USE molecule_types, ONLY : molecule_structure_type, particle_node_type USE particle_types, ONLY : particle_type USE simulation_cell, ONLY : cell_type + USE pair_potential, ONLY : potentialparm_type + USE tbmd_types, ONLY : tbatom_param_type, tb_hopping_type IMPLICIT NONE PRIVATE - PUBLIC :: structure_type + PUBLIC :: structure_type, interaction_type + PUBLIC :: cell_type, particle_type, particle_node_type PUBLIC :: molecule_structure_type + PUBLIC :: potentialparm_type, tbatom_param_type, tb_hopping_type TYPE structure_type CHARACTER ( LEN = 30 ) :: name - TYPE (cell_type ) :: box - TYPE (particle_type ), POINTER :: part ( : ) - TYPE (particle_node_type ), POINTER :: pnode ( : ) - TYPE (molecule_structure_type ), POINTER :: molecule ( : ) + TYPE ( cell_type ) :: box + TYPE ( particle_type ), POINTER :: part ( : ) + TYPE ( particle_node_type ), POINTER :: pnode ( : ) + TYPE ( molecule_structure_type ), POINTER :: molecule ( : ) END TYPE structure_type + TYPE interaction_type + TYPE ( potentialparm_type ), DIMENSION ( :, : ), POINTER :: potparm + TYPE ( tbatom_param_type ), DIMENSION ( : ), POINTER :: tbatom + TYPE ( tb_hopping_type ), DIMENSION ( :, : ), POINTER :: tbhop + END TYPE interaction_type + END MODULE structure_types diff --git a/src/tbmd_debug.F b/src/tbmd_debug.F index 269d27a350..70fa6c6679 100644 --- a/src/tbmd_debug.F +++ b/src/tbmd_debug.F @@ -6,21 +6,21 @@ MODULE tbmd_debug USE ewald_parameters_types, ONLY : ewald_parameters_type + USE fist_force_numer, ONLY : force_nonbond_numer, force_recip_numer, & + ptens_numer, pvg_numer, potential_g_numer, de_g_numer, & + energy_recip_numer + USE tbmd_force, ONLY : force_control, debug_variables_type USE global_types, ONLY : global_environment_type USE kinds, ONLY : dbl + USE linklists, ONLY : dist_constraints, g3x3_constraints USE md, ONLY : thermodynamic_type USE molecule_types, ONLY : molecule_structure_type, particle_node_type USE particle_types, ONLY : particle_type USE pair_potential, ONLY : potentialparm_type, ener_coul - USE tbmd_force, ONLY : force_control, debug_variables_type - USE fist_force_numer, ONLY : force_nonbond_numer, force_recip_numer, & - ptens_numer, pvg_numer, potential_g_numer, de_g_numer, & - energy_recip_numer - USE linklists, ONLY : dist_constraints, g3x3_constraints - USE pw_grid_types, ONLY : pw_grid_type - USE pw_grids, ONLY : pw_grid_setup + USE pw_grid_types, ONLY : pw_grid_type, HALFSPACE + USE pw_grids, ONLY : pw_find_cutoff, pw_grid_setup USE simulation_cell, ONLY : cell_type - USE stop_program, ONLY : stop_memory + USE stop_program, ONLY : stop_memory, stop_prg IMPLICIT NONE @@ -51,16 +51,16 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, & ! Locals TYPE ( debug_variables_type ) :: dbg - TYPE ( pw_grid_type ) :: pw_grid - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_numer - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rel, diff - INTEGER :: iflag, i, natoms, isos, iatom, iw, ir + TYPE ( pw_grid_type ) :: ewald_grid + INTEGER :: iflag, i, natoms, isos, iatom, iw, ir, npts_s(3), gmax INTEGER, DIMENSION ( 2 ) :: dum - REAL ( dbl ) :: delta, energy_numer + REAL ( dbl ) :: delta, energy_numer, cutoff REAL ( dbl ) :: e_numer, pv_test ( 3, 3 ) REAL ( dbl ) :: err1, numer, denom1, vec ( 3 ), e_bc, e_real, energy_tot REAL ( dbl ) :: denom2, err2 REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_bc, f_real + REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_numer + REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rel, diff !------------------------------------------------------------------------------ @@ -107,8 +107,8 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, & ELSE WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta END IF - CALL force_nonbond_numer ( pnode, box, potparm, delta, f_numer, & - energy_numer ) + CALL force_nonbond_numer ( ewald_param, pnode, box, potparm, & + delta, f_numer, energy_numer ) WRITE ( iw, '( A, T61, E20.14 )' ) ' NON BOND NUMER ENERGY = ', & energy_numer WRITE ( iw, '( A, T61, E20.14 )' ) ' NON BOND ANAL ENERGY = ', & @@ -144,101 +144,112 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, & END IF ! Debug g-space -! IF ( ewald_param % ewald_type /= 'NONE' ) THEN -! WRITE ( iw, '( A )' ) ' DO YOU WANT TO DEBUG YOUR G-SPACE (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! CALL pw_grid_setup ( box, pw_grid, ewald_param % gmax ) -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE ENERGIES (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! WRITE ( iw, '( A, T71, I10 )' ) 'TOTAL NUMBER OF G-VECTORS= ', & -! pw_grid % ngpts_cut -! WRITE ( iw, '( A, T71, F10.4 )' ) 'ALPHA= ', & -! ewald_param % alpha -! CALL energy_recip_numer ( pnode, box, potparm, pw_grid, & -! energy_numer, pw_grid % ngpts_cut ) -! WRITE ( iw, '( A, T61, G20.14 )' ) 'G-SPACE ANAL ENERGY = ', & -! dbg % pot_g -! WRITE ( iw, '( A, T61, G20.14 )' ) & -! 'G-SPACE NUMERICAL ENERGY = ', energy_numer -! END IF -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE FORCES (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' -! READ ( ir, * ) delta -! IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN -! delta = 1.0E-5_dbl -! WRITE ( iw, '( A, T71, F10.6 )' ) & -! ' DELTA (changed to default) = ', delta -! ELSE -! WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta -! END IF -! -! CALL force_recip_numer ( pnode, box, potparm, gvec, delta, f_numer ) -! + IF ( ewald_param % ewald_type /= 'NONE' ) THEN + WRITE ( iw, '( A )' ) ' DO YOU WANT TO DEBUG YOUR G-SPACE (1=yes)?' + READ ( ir, * ) iflag + IF ( iflag == 1 ) THEN + gmax = ewald_param % gmax + ewald_grid % bounds ( 1, : ) = -gmax / 2 + ewald_grid % bounds ( 2, : ) = +gmax / 2 + npts_s = (/ gmax, gmax, gmax /) + ewald_grid % grid_span = HALFSPACE + + CALL pw_find_cutoff ( npts_s, box, cutoff ) + + CALL pw_grid_setup( box, ewald_grid, cutoff) + + WRITE ( iw, '( A )' ) & + ' DO YOU WANT TO DEBUG YOUR G-SPACE ENERGIES (1=yes)?' + READ ( ir, * ) iflag + IF ( iflag == 1 ) THEN + WRITE ( iw, '( A, T71, I10 )' ) 'TOTAL NUMBER OF G-VECTORS= ', & + ewald_grid % ngpts_cut + WRITE ( iw, '( A, T71, F10.4 )' ) 'ALPHA= ', & + ewald_param % alpha + CALL energy_recip_numer ( ewald_param, pnode, box, & + ewald_grid, energy_numer, ewald_grid % ngpts_cut ) + WRITE ( iw, '( A, T61, G20.14 )' ) 'G-SPACE ANAL ENERGY = ', & + dbg % pot_g + WRITE ( iw, '( A, T61, G20.14 )' ) & + 'G-SPACE NUMERICAL ENERGY = ', energy_numer + END IF + WRITE ( iw, '( A )' ) & + ' DO YOU WANT TO DEBUG YOUR G-SPACE FORCES (1=yes)?' + READ ( ir, * ) iflag + IF ( iflag == 1 ) THEN + WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' + READ ( ir, * ) delta + IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN + delta = 1.0E-5_dbl + WRITE ( iw, '( A, T71, F10.6 )' ) & + ' DELTA (changed to default) = ', delta + ELSE + WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta + END IF + + CALL force_recip_numer ( ewald_param, pnode, box, ewald_grid, & + delta, f_numer ) + ! computing the absolute value of the differences in the forces -! diff = ABS ( dbg % f_g - f_numer ) -! rel = diff / dbg % f_g -! + diff = ABS ( dbg % f_g - f_numer ) + rel = diff / dbg % f_g + ! find the maximum difference and the relative and absolute errors. -! WRITE ( iw, '( A,T61,G20.14 )' ) & -! 'MAXIMUM ABSOLUTE ERROR = ', maxval(diff) -! WRITE ( iw, '( A,T61,G20.14 )' ) & -! 'MAXIMUM RELATIVE ERROR = ', maxval(rel) + WRITE ( iw, '( A,T61,G20.14 )' ) & + 'MAXIMUM ABSOLUTE ERROR = ', maxval(diff) + WRITE ( iw, '( A,T61,G20.14 )' ) & + 'MAXIMUM RELATIVE ERROR = ', maxval(rel) ! -! write out the particle number and forces of -! the max absolute and relative error -! dum = MAXLOC ( diff ) -! WRITE ( iw, '( A,T71,I10 )' ) & -! ' PARTICLE WITH MAX ABSOLUTE ERROR IS ', dum(2) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & -! dbg % f_g(:,dum(2)) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & -! f_numer(:,dum(2)) -! -! dum = MAXLOC ( rel ) -! WRITE ( iw, '( A,T71,I10 )' ) & -! 'PARTICLE WITH MAX RELATIVE ERROR IS ', dum(2) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & -! dbg % f_g(:,dum(2)) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & -! f_numer(:,dum(2)) -! END IF -! -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE VIRIAL (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN +! write out the particle number and forces of the max absolute +! and relative error + dum = MAXLOC ( diff ) + WRITE ( iw, '( A,T71,I10 )' ) & + ' PARTICLE WITH MAX ABSOLUTE ERROR IS ', dum(2) + WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & + dbg % f_g(:,dum(2)) + WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & + f_numer(:,dum(2)) + + dum = MAXLOC ( rel ) + WRITE ( iw, '( A,T71,I10 )' ) & + 'PARTICLE WITH MAX RELATIVE ERROR IS ', dum(2) + WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & + dbg % f_g(:,dum(2)) + WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & + f_numer(:,dum(2)) + END IF + + WRITE ( iw, '( A )' ) & + ' DO YOU WANT TO DEBUG YOUR G-SPACE VIRIAL (1=yes)?' + READ ( ir, * ) iflag + IF ( iflag == 1 ) THEN ! ! get numerical virial -! WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' -! READ ( ir, * ) delta -! IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN -! delta = 1.0E-5_dbl -! WRITE ( iw, '( A,T71,F10.6 )' ) & -! ' DELTA (changed to default) = ', delta -! ELSE -! WRITE ( iw, '( A,T71,F10.6 )' ) ' DELTA = ', delta -! END IF -! CALL pvg_numer ( pnode, box, potparm, gvec, pv_test, delta ) -! + WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' + READ ( ir, * ) delta + IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN + delta = 1.0E-5_dbl + WRITE ( iw, '( A,T71,F10.6 )' ) & + ' DELTA (changed to default) = ', delta + ELSE + WRITE ( iw, '( A,T71,F10.6 )' ) ' DELTA = ', delta + END IF + CALL pvg_numer ( ewald_param, pnode, box, & + ewald_grid, pv_test, delta ) + ! writing out the virials -! WRITE ( iw, '( A )' ) ' PV G-SPACE NUMERICAL' -! DO i = 1, 3 -! WRITE ( iw, '( T21,3G20.14 )' ) pv_test(i,:) -! END DO -! WRITE ( iw, '( A )' ) ' PV G-SPACE' -! DO i = 1, 3 -! WRITE ( iw, '( T21,3G20.14 )' ) dbg % pv_g(i,:) -! END DO -! END IF -! END IF -! END IF -! + WRITE ( iw, '( A )' ) ' PV G-SPACE NUMERICAL' + DO i = 1, 3 + WRITE ( iw, '( T21,3G20.14 )' ) pv_test(i,:) + END DO + WRITE ( iw, '( A )' ) ' PV G-SPACE' + DO i = 1, 3 + WRITE ( iw, '( T21,3G20.14 )' ) dbg % pv_g(i,:) + END DO + END IF + END IF + END IF + ! Debug real-space virial WRITE ( iw, '( A )' ) & ' DO YOU WANT TO DEBUG YOUR NON BOND (REAL SPACE) VIRIAL (1=yes)?' @@ -255,7 +266,7 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, & ELSE WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta END IF - CALL ptens_numer ( pnode, box, potparm, pv_test, delta ) + CALL ptens_numer ( ewald_param, pnode, box, potparm, pv_test, delta ) ! ! writing out the virials WRITE ( iw, '( A )' ) ' PV NUMERICAL' diff --git a/src/tbmd_force.F b/src/tbmd_force.F index 7db0771a89..bb4cdb7c2a 100644 --- a/src/tbmd_force.F +++ b/src/tbmd_force.F @@ -87,12 +87,11 @@ SUBROUTINE force_control ( molecule, pnode, part, box, thermo, & IF ( first_time ) THEN SELECT CASE ( ewald_param % ewald_type ) CASE ( 'EWALD_GAUSS' ) - CALL ewald_initialize ( dg, part, pnode, fc_global % group, & - ewald_param, box, thermo, fc_global % scr, & - ewald_grid = grid_ewald ) + CALL ewald_initialize ( dg, part, pnode, fc_global, & + ewald_param, box, thermo, ewald_grid = grid_ewald ) CASE ( 'PME_GAUSS' ) - CALL ewald_initialize ( dg, part, pnode, fc_global % group, & - ewald_param, box, thermo, fc_global % scr, & + CALL ewald_initialize ( dg, part, pnode, fc_global, & + ewald_param, box, thermo, & pme_small_grid = grid_s, pme_big_grid = grid_b ) END SELECT END IF diff --git a/src/tbmd_initialize.F b/src/tbmd_initialize.F new file mode 100644 index 0000000000..c188fc3998 --- /dev/null +++ b/src/tbmd_initialize.F @@ -0,0 +1,129 @@ +!------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 CP2K developers group ! +!------------------------------------------------------------------------------! +! + MODULE tbmd_initialize +! +!------------------------------------------------------------------------------! + USE kinds, ONLY : dbl + USE stop_program, ONLY : stop_memory + USE tbmd_types, ONLY : tbatom_param_type, tb_hopping_type + USE particle_types, ONLY : particle_type +! + IMPLICIT NONE +! + PRIVATE + PUBLIC :: tbmd_init, tb_get_numel, tb_get_basize +! +!------------------------------------------------------------------------------! +! + CONTAINS +! +!------------------------------------------------------------------------------! + SUBROUTINE tbmd_init(part,tbatom,tbhop) + IMPLICIT NONE + TYPE (particle_type), INTENT (IN) :: part(:) + TYPE (tbatom_param_type), DIMENSION(:), INTENT (INOUT) :: tbatom + TYPE (tb_hopping_type), DIMENSION(:,:), INTENT (INOUT) :: tbhop + INTEGER :: iat, jat, i, j, k, n, ii, ni, nj, is, js, ju, ios + INTEGER :: natom_type +! +! count number of atoms per atom type + natom_type = size(tbatom) + DO iat = 1, natom_type + tbatom(iat) %natoms = 0 + END DO + DO iat = 1, size(part) + i = part(iat) %prop%ptype + tbatom(i) %natoms = tbatom(i) %natoms + 1 + END DO +! count number of basis function per atom type +! set up diagonal part of hamiltonian + DO iat = 1, natom_type + n = tbatom(iat) %bsf(0) + 3*tbatom(iat) %bsf(1) + & + 5*tbatom(iat) %bsf(2) + 7*tbatom(iat) %bsf(3) + tbatom(iat) %nbsf = n + ALLOCATE (tbatom(iat)%h_diag(n),STAT=ios) + IF (ios/=0) CALL stop_memory('tbmd_initialize', & + 'tbatom(iat)%h_diag',n) + ii = 0 + DO i = 0, 3 + DO j = 1, tbatom(iat) %bsf(i) + tbatom(iat) %h_diag(ii+1:ii+2*i+1) = tbatom(iat) & + %orbital_energy(i,j) + ii = ii + 2*i + 1 + END DO + END DO + END DO +! set up shell pointers + DO iat = 1, natom_type + n = tbatom(iat) %bsf(0) + tbatom(iat) %bsf(1) + & + tbatom(iat) %bsf(2) + tbatom(iat) %bsf(3) + ALLOCATE (tbatom(iat)%spoint(n,2),STAT=ios) + IF (ios/=0) CALL stop_memory('tbmd_initialize', & + 'tbatom(iat)%spoint',2*n) + ii = 0 + DO i = 0, 3 + DO j = 1, tbatom(iat) %bsf(i) + ii = ii + 1 + tbatom(iat) %spoint(ii,2) = i + END DO + END DO + tbatom(iat) %spoint(1,1) = 0 + DO j = 2, n + ii = tbatom(iat) %spoint(j-1,2) + tbatom(iat) %spoint(j,1) = tbatom(iat) %spoint(j-1,1) + 2*ii + 1 + END DO + END DO +! pointer: shell pair to hopping potential + DO iat = 1, natom_type + DO jat = 1, natom_type + ni = size(tbatom(iat)%spoint(:,1)) + nj = size(tbatom(jat)%spoint(:,1)) + ALLOCATE (tbhop(iat,jat)%llpoint(ni,nj),STAT=ios) + IF (ios/=0) CALL stop_memory('tbmd_initialize', & + 'tbatom(iat)%llpoint',ni*nj) + k = 0 + DO i = 1, ni + is = tbatom(iat) %spoint(i,2) + ju = 1 + IF (iat==jat) ju = i + DO j = ju, nj + js = tbatom(jat) %spoint(j,2) + tbhop(iat,jat) %llpoint(i,j) = k + 1 + k = k + min(is,js) + END DO + END DO + END DO + END DO +! + END SUBROUTINE tbmd_init +!------------------------------------------------------------------------------! + FUNCTION tb_get_basize(tbatom) RESULT (basis_size) + IMPLICIT NONE + TYPE (tbatom_param_type), DIMENSION(:), INTENT (IN) :: tbatom + INTEGER :: basis_size, i + + basis_size = 0 + DO i = 1, size(tbatom) + basis_size = basis_size + tbatom(i) %nbsf*tbatom(i) %natoms + END DO + END FUNCTION tb_get_basize +!------------------------------------------------------------------------------! + FUNCTION tb_get_numel(tbatom,charge) RESULT (number_of_electrons) + IMPLICIT NONE + TYPE (tbatom_param_type), DIMENSION(:), INTENT (IN) :: tbatom + REAL (dbl) , INTENT(IN) :: charge + INTEGER :: number_of_electrons, i + + number_of_electrons = 0 + DO i = 1, size(tbatom) + number_of_electrons = number_of_electrons + & + tbatom(i) %valence_charge*tbatom(i) %natoms + END DO + number_of_electrons = number_of_electrons + charge + END FUNCTION tb_get_numel +!------------------------------------------------------------------------------! + END MODULE tbmd_initialize +!------------------------------------------------------------------------------! diff --git a/src/tbmd_input.F b/src/tbmd_input.F index ca22b33995..b75dbdcb6f 100644 --- a/src/tbmd_input.F +++ b/src/tbmd_input.F @@ -5,138 +5,27 @@ MODULE tbmd_input !------------------------------------------------------------------------------! USE kinds, ONLY : dbl - USE tbmd_global, ONLY : tbatom, tbhop + USE tbmd_types, ONLY : tbatom_param_type, tb_hopping_type USE stop_program, ONLY : stop_prg, stop_memory USE util, ONLY : get_unit USE string_utilities, ONLY : uppercase, xstring, & str_search, str_comp, make_tuple USE parser, ONLY : parser_init, parser_end, read_line, test_next, & cfield, p_error, get_real, get_int, stop_parser - USE message_passing, ONLY : mp_bcast - USE ewald_parameters_types, ONLY : ewald_parameters_type USE input_types, ONLY : setup_parameters_type USE global_types, ONLY : global_environment_type IMPLICIT NONE ! PRIVATE - PUBLIC :: read_tbmd_section, read_tb_hamiltonian, & - read_tb_hopping_elements + PUBLIC :: read_tb_hamiltonian, read_tb_hopping_elements ! !------------------------------------------------------------------------------! ! CONTAINS ! -!!>----------------------------------------------------------------------------! -!! SECTION: &tbmd ... &end ! -!! ! -!! simulation [energy,md,debug] ! -!! units [atomic] ! -!! periodic [0,1][0,1][0,1] ! -!! set_file "filename" ! -!! input_file "filename" ! -!! ! -!!tmptmptmptmptmp (to be included)???? -!! symmetry [on,off] ! -!!<----------------------------------------------------------------------------! - -SUBROUTINE read_tbmd_section ( setup, ewald_param, tbmdpar ) - - IMPLICIT NONE - -! Arguments - TYPE(setup_parameters_type), INTENT(INOUT) :: setup - TYPE(ewald_parameters_type), INTENT(INOUT) :: ewald_param - TYPE(global_environment_type), INTENT(INOUT) :: tbmdpar - -! Locals - INTEGER :: ierror, ilen, ia, ie, i, j, n, iw, source, group - CHARACTER (len=20) :: string - CHARACTER (len=5) :: label, str2 - CHARACTER (len=3), PARAMETER :: yn(0:1) = (/ ' NO', 'YES'/) - -!------------------------------------------------------------------------------! -!..defaults - setup % run_type = 'ENERGY' - setup % unit_type = 'ATOMIC' - setup % perd = 1 - ewald_param % alpha = 0.4_dbl - ewald_param % gmax = 10 - ewald_param % ns_max = 10 - ewald_param % epsilon = 1.e-6_dbl - ewald_param % ewald_type = 'NONE' - CALL xstring(tbmdpar%project_name,ia,ie) - setup % set_file_name = tbmdpar%project_name(ia:ie) // '.set' - setup % input_file_name = tbmdpar%project_name(ia:ie) // '.dat' - - iw = tbmdpar % scr - -!..parse the input section - label = '&TBMD' - CALL parser_init(tbmdpar%input_file_name,label,ierror,tbmdpar) - IF (ierror/=0) THEN - IF (tbmdpar%ionode) & - WRITE (iw,'(a)') ' No input section &TBMD found ' - ELSE - CALL read_line - DO WHILE (test_next()/='X') - ilen = 8 - CALL cfield(string,ilen) - CALL uppercase(string) - SELECT CASE (string) - CASE DEFAULT - CALL p_error() - CALL stop_parser('read_tbmd','unknown option') - CASE ('SIMULATI') - ilen = 20 - CALL cfield(setup%run_type,ilen) - CALL uppercase(setup%run_type) - CASE ('PRINTLEV') - tbmdpar%print_level = get_int() - CASE ('UNITS') - ilen = 20 - CALL cfield(setup%unit_type,ilen) - CALL uppercase(setup%unit_type) - CASE ('PERIODIC') - setup%perd(1) = get_int() - setup%perd(2) = get_int() - setup%perd(3) = get_int() - CASE ('SET_FILE') - ilen = 20 - CALL cfield(setup%set_file_name,ilen) - CASE ('INP_FILE') - ilen = 20 - CALL cfield(setup%input_file_name,ilen) - END SELECT - CALL read_line - END DO - END IF - CALL parser_end -!..end of parsing the input section -!..write some information to output - IF (tbmdpar%ionode) THEN - IF (tbmdpar%print_level>=0) THEN - WRITE (iw,'(A,T71,A)') ' TBMD| Run type ', adjustr(setup%run_type) - WRITE (iw,'(A,T71,A)') ' TBMD| Unit type ', adjustr(setup%unit_type) - WRITE (iw,'(A,T78,A)') ' TBMD| Periodic in X direction ', & - yn(setup%perd(1)) - WRITE (iw,'(A,T78,A)') ' TBMD| Periodic in Y direction ', & - yn(setup%perd(2)) - WRITE (iw,'(A,T78,A)') ' TBMD| Periodic in Z direction ', & - yn(setup%perd(3)) - WRITE (iw,'(A,T61,A)') ' TBMD| Set file name', & - adjustr(setup%set_file_name) - WRITE (iw,'(A,T61,A)') ' TBMD| Input file name', & - adjustr(setup%input_file_name) - WRITE (iw,'(A,T76,I5)') ' TBMD| Print level ', tbmdpar%print_level - WRITE (iw,*) - END IF - END IF - -END SUBROUTINE read_tbmd_section - !------------------------------------------------------------------------------! -SUBROUTINE read_tb_hamiltonian ( setup, atom_names, tbmdpar ) +SUBROUTINE read_tb_hamiltonian ( setup, atom_names, tbatom, tbmdpar ) IMPLICIT NONE @@ -144,6 +33,8 @@ SUBROUTINE read_tb_hamiltonian ( setup, atom_names, tbmdpar ) TYPE(setup_parameters_type), INTENT(INOUT) :: setup TYPE(global_environment_type), INTENT(IN) :: tbmdpar CHARACTER ( LEN = * ), INTENT(IN) :: atom_names ( : ) + TYPE (tbatom_param_type), DIMENSION (:), POINTER :: tbatom + ! Locals INTEGER :: ierror, ilen, i, j, k, n, iw, source, group, iat, nt, ios, i1 @@ -263,7 +154,7 @@ SUBROUTINE set_basis(basis,bsf) END SUBROUTINE set_basis !------------------------------------------------------------------------------! -SUBROUTINE read_tb_hopping_elements ( setup, atom_names, tbmdpar ) +SUBROUTINE read_tb_hopping_elements ( setup, atom_names, tbatom, tbhop, tbmdpar ) IMPLICIT NONE @@ -271,6 +162,8 @@ SUBROUTINE read_tb_hopping_elements ( setup, atom_names, tbmdpar ) TYPE(setup_parameters_type), INTENT(INOUT) :: setup TYPE(global_environment_type), INTENT(INOUT) :: tbmdpar CHARACTER ( LEN = * ), INTENT(IN) :: atom_names ( : ) + TYPE (tbatom_param_type), DIMENSION (:) :: tbatom + TYPE (tb_hopping_type), DIMENSION (:,:), POINTER :: tbhop INTEGER :: ierror, ilen, i, j, k, l, n, iw, source, group, iat, ios INTEGER :: l1, l2, k1, k2, kk, nk, lu, ku