diff --git a/COPYRIGHT b/COPYRIGHT index a61b7ca..355cea6 100644 --- a/COPYRIGHT +++ b/COPYRIGHT @@ -1,7 +1,7 @@ !-----------------------------------------------------------------------------! ! ! ! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! +! Copyright (C) 2024 CP2K developers group ! ! ! ! This program is free software; you can redistribute it and/or modify ! ! it under the terms of the GNU General Public License as published by ! @@ -21,4 +21,4 @@ -- cp2k@prr.mpi-stuttgart.mpg.de -15. X AD 2000 +15. X AD 2024 \ No newline at end of file diff --git a/INSTALL b/INSTALL index eefbe21..653a95b 100644 --- a/INSTALL +++ b/INSTALL @@ -4,13 +4,13 @@ How to compile CP2K code 1) Extract the archive file: -# gtar zxvf cp2k.tar.gz +# tar xzvf cp2k.tar.gz or if you do not have GNU tar -# gzip -cd cp2k.tar.gz | tar xvf - +# unzip -cd cp2k.tar.gz -This extract the contents of the archive into the directory ./CP2K; please be +This extracts the contents of the archive into the directory ./CP2K; please be careful not to overwrite things in there if it already exists 2) Go to 'CP2K/tools' and do a 'make' (or 'gmake'); this compiles you an diff --git a/Makefile b/Makefile index f363c97..031266f 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -.SUFFIXES: .cpp .d .o +.SUFFIXES: .c .cpp .d .o CP2KHOME = $(HOME)/CP2K ARCH = $(shell $(CP2KHOME)/tools/get_arch_code) diff --git a/src/Makefile b/src/Makefile index 71e95cf..db5fb3f 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,4 +1,4 @@ -.SUFFIXES: .o .cpp .d +.SUFFIXES: .o .c .cpp .d CP2KHOME= ${HOME}/CP2K FORPAR = $(CP2KHOME)/tools/forpar.x -chkint @@ -19,19 +19,25 @@ $(PROG): $(OBJECTS) $(LDR) $(LFLAGS) -o $(PROG) $(OBJECTS) $(LIBS) %.o : %.cpp - $(FC) -c $(FFLAGS) $*.cpp - $(CPP) -P $(CDEFS) $*.cpp $*.cpp + $(CXX) -c $(CXXFLAGS) $*.cpp + $(CPP) -P $(CDEFS) $*.cpp -$(FORPAR) $*.cpp rm -f $*.cpp +%.o : %.c + $(CC) -c $(CFLAGS) $*.c + $(CC) -P $(CDEFS) $*.c + -$(FORPAR) $*.c + rm -f $*.c + parallel_include.o : parallel_include.cpp - $(FCfixed) -c $(FFLAGS) $*.cpp + $(CXXfixed) -c $(CXXFLAGS) $*.cpp $(CPP) -P $(CDEFS) $*.cpp $*.cpp -$(FORPAR) -fix $*.cpp rm -f $*.cpp %.d : %.cpp - $(CPP) -P $(CDEFS) $*.cpp $*.cpp + $(CPP) -P $(CDEFS) $*.cpp $(PERL) $(CP2KHOME)/tools/sfmakedepend -m int -s -f $*.d $*.cpp rm -f $*.cpp $*.d.old @@ -42,7 +48,7 @@ clean: rm -f *.o *.mod realclean: - rm -f $(PROG) *.o *.mod *.d *.int *~ F*.cpp *.lst + rm -f $(PROG) *.o *.mod *.d *.int *~ F*.cpp F*.c *.lst #################### diff --git a/src/amoeba.cpp b/src/amoeba.cpp index 84ae41e..488124b 100644 --- a/src/amoeba.cpp +++ b/src/amoeba.cpp @@ -1,18 +1,20 @@ /*---------------------------------------------------------------------------*/ /* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 1999 MPI fuer Festkoerperforschung, Stuttgart */ +/* Copyright (C) 2024 MPI fuer Festkoerperforschung, Stuttgart */ /*---------------------------------------------------------------------------*/ #include #include +#include +#include #include "amoeba.h" namespace amoeba { -/*---------------------------------------------------------------------------*/ -/* NUMERICAL RECIPIES SUBROUTINE AMOEBA ADAPTED FOR USE IN CP2K */ -/*---------------------------------------------------------------------------*/ +/*----------------------------------------------------------------------------| +| NUMERICAL RECIPIES SUBROUTINE AMOEBA ADAPTED FOR USE IN CP2K | +|----------------------------------------------------------------------------*/ template void amoeba_evaluate(std::vector>& p, std::vector& y, diff --git a/src/atoms_input.cpp b/src/atoms_input.cpp index e78e961..18a8f82 100644 --- a/src/atoms_input.cpp +++ b/src/atoms_input.cpp @@ -1,162 +1,181 @@ #include #include -typedef struct { - double box[3][3]; - char ptype[4]; - char rtype[21]; - int n; - double** c; - double** v; -} system_type; +#include "atoms_input.h" +#include "global_types.h" -void read_coord_vel(system_type* atype, char* filen) { - int ierror, iw, source, allgrp, ia, ie, i, ios; - char label[6]; +/*----------------------------------------------------------------------------| +| CP2K: A general program to perform molecular dynamics simulations | +| Copyright (C) 2024 CP2K developers group | +|----------------------------------------------------------------------------*/ - iw = globenv.scr; +/*>---------------------------------------------------------------------------| +| | +| OPTIONS: either read the section &atoms in the input file or | +| read the coordinates from the file project_name.dat | +| SECTION: &atoms ... &end | +| file: file_name | +| cell: b11 b12 b13 & | +| b21 b22 b23 & | +| b31 b32 b33 | +| | +| | +| | +|<---------------------------------------------------------------------------*/ - //..defaults - //..parse the input section - strcpy(label, "&ATOMS"); - parser_init(globenv.input_file_name, label, &ierror, globenv); - if (ierror != 0) { - if (globenv.ionode) { - printf("ATOM| No input section &ATOMS found\n"); - if (strcmp(filen, " ") == 0) { - ia = strlen(globenv.project_name); - ie = ia; - } else { - ia = strlen(filen); - ie = ia; - } - strcat(filen, ".dat"); - printf("ATOM| Try to read default file %s\n", filen); - read_file(filen, atype); - } - //..broadcast the input data to all nodes - #if defined(__parallel) - source = globenv.source; - allgrp = globenv.group; - mp_bcast(atype->box, source, allgrp); - mp_bcast(atype->ptype, source, allgrp); - mp_bcast(atype->rtype, source, allgrp); - mp_bcast(&atype->n, source, allgrp); - if (!globenv.ionode) { - atype->c = (double**)malloc(3 * sizeof(double*)); - for (i = 0; i < 3; i++) { - atype->c[i] = (double*)malloc(atype->n * sizeof(double)); - } - if (atype->c == NULL) { - stop_memory("ATOM", "atype%c", 3 * atype->n); - } - } - mp_bcast(atype->c, source, allgrp); - if (strcmp(atype->rtype, "POSVEL") == 0) { - if (!globenv.ionode) { - atype->v = (double**)malloc(3 * sizeof(double*)); +void read_coord_vel(system_type *atype, char *filen) { + + int ierror, ilen, iw, source, allgrp, ia, ie, i, ios; + char string[7]; + char label[6]; + + iw = globenv.scr; + + //..defaults + //..parse the input section + strncpy(label, "&ATOMS", 10); + parser_init(globenv.input_file_name, label, &ierror, globenv); + if (ierror != 0) { + if (globenv.ionode) { + printf("ATOM| No input section &ATOMS found\n"); + if (strcmp(filen, " ") == 0) { + ia = strlen(globenv.project_name); + ie = ia; + } else { + ia = strlen(filen); + ie = ia; + } + strcat(filen, ".dat"); + printf("ATOM| Try to read default file %s\n", filen); + read_file(filen, atype); + } + //..broadcast the input data to all nodes + #if defined(__parallel) + source = globenv.source; + allgrp = globenv.group; + mp_bcast(atype->box, source, allgrp); + mp_bcast(atype->ptype, source, allgrp); + mp_bcast(atype->rtype, source, allgrp); + mp_bcast(&atype->n, source, allgrp); + if (!globenv.ionode) { + atype->c = (double **)malloc(3 * sizeof(double *)); for (i = 0; i < 3; i++) { - atype->v[i] = (double*)malloc(atype->n * sizeof(double)); + atype->c[i] = (double *)malloc(atype->n * sizeof(double)); + } + if (atype->c == NULL) { + stop_memory("ATOM", "atype%c", 3 * atype->n); + } + } + mp_bcast(atype->c, source, allgrp); + if (strcmp(atype->rtype, "POSVEL") == 0) { + if (!globenv.ionode) { + atype->v = (double **)malloc(3 * sizeof(double *)); + for (i = 0; i < 3; i++) { + atype->v[i] = (double *)malloc(atype->n * sizeof(double)); + } + if (atype->v == NULL) { + stop_memory("ATOM", "atype%v", 3 * atype->n); + } + } + mp_bcast(atype->v, source, allgrp); + } + #endif + } else { + stop_prg("atom", "this part of the code not yet written"); + } + parser_end(); + //..end of parsing the input section + + //..write some information to output + if (globenv.ionode && globenv.print_level > 0) { + fprintf(iw, "ATOM| Box parameters [Angstrom]\n"); + fprintf(iw, "ATOM| %15.5f %15.5f %15.5f\n", atype->box[0][0], atype->box[0][1], + atype->box[0][2]); + fprintf(iw, "ATOM| %15.5f %15.5f %15.5f\n", atype->box[1][0], atype->box[1][1], + atype->box[1][2]); + fprintf(iw, "ATOM| %15.5f %15.5f %15.5f\n", atype->box[2][0], atype->box[2][1], + atype->box[2][2]); + fprintf(iw, "ATOM| Number of atoms read %d\n", atype->n); + if (globenv.print_level > 4) { + if (strcmp(atype->rtype, "POS") == 0) { + print_c(iw, atype->c); + } else if (strcmp(atype->rtype, "POSVEL") == 0) { + print_cv(iw, atype->c, atype->v); + } + } + printf("\n"); + } +} + +void read_file(char *filen, system_type *atype) { + int iunit, i, j, ios; + int exists; + + exists = access(filen, F_OK) != -1; + if (exists) { + iunit = get_unit(); + FILE *file = fopen(filen, "r"); + fscanf(file, "%d", &atype->n); + + atype->c = (double **)malloc(3 * sizeof(double *)); + for (i = 0; i < 3; i++) { + atype->c[i] = (double *)malloc(atype->n * sizeof(double)); + } + if (atype->c == NULL) { + stop_memory("ATOM", "atype%c", 3 * atype->n); + } + atype->v = NULL; + + if (strcmp(atype->rtype, "POS") == 0) { + for (i = 0; i < atype->n; i++) { + fscanf(file, "%lf %lf %lf", &atype->c[0][i], &atype->c[1][i], &atype->c[2][i]); + } + fscanf(file, "%lf %lf %lf", &atype->box[0][0], &atype->box[0][1], &atype->box[0][2]); + fscanf(file, "%lf %lf %lf", &atype->box[1][0], &atype->box[1][1], &atype->box[1][2]); + fscanf(file, "%lf %lf %lf", &atype->box[2][0], &atype->box[2][1], &atype->box[2][2]); + } else if (strcmp(atype->rtype, "POSVEL") == 0) { + atype->v = (double **)malloc(3 * sizeof(double *)); + for (i = 0; i < 3; i++) { + atype->v[i] = (double *)malloc(atype->n * sizeof(double)); } if (atype->v == NULL) { - stop_memory("ATOM", "atype%v", 3 * atype->n); + stop_memory("ATOM", "atype%v", 3 * atype->n); } - } - mp_bcast(atype->v, source, allgrp); - } - #endif - } else { - stop_prg("atom", "this part of the code not yet written"); - } - parser_end(); - //..end of parsing the input section - //..write some information to output - if (globenv.ionode && globenv.print_level > 0) { - printf("ATOM| Box parameters [Angstrom]\n"); - printf("ATOM| %15.5f %15.5f %15.5f\n", atype->box[0][0], atype->box[0][1], atype->box[0][2]); - printf("ATOM| %15.5f %15.5f %15.5f\n", atype->box[1][0], atype->box[1][1], atype->box[1][2]); - printf("ATOM| %15.5f %15.5f %15.5f\n", atype->box[2][0], atype->box[2][1], atype->box[2][2]); - printf("ATOM| Number of atoms read %d\n", atype->n); - if (globenv.print_level > 4) { - if (strcmp(atype->rtype, "POS") == 0) { - print_c(iw, atype->c); - } else if (strcmp(atype->rtype, "POSVEL") == 0) { - print_cv(iw, atype->c, atype->v); - } - } - printf("\n"); - } + for (i = 0; i < atype->n; i++) { + fscanf(file, "%lf %lf %lf", &atype->c[0][i], &atype->c[1][i], &atype->c[2][i]); + } + fscanf(file, "%lf %lf %lf", &atype->box[0][0], &atype->box[0][1], &atype->box[0][2]); + fscanf(file, "%lf %lf %lf", &atype->box[1][0], &atype->box[1][1], &atype->box[1][2]); + fscanf(file, "%lf %lf %lf", &atype->box[2][0], &atype->box[2][1], &atype->box[2][2]); + for (i = 0; i < atype->n; i++) { + fscanf(file, "%lf %lf %lf", &atype->v[0][i], &atype->v[1][i], &atype->v[2][i]); + } + } else { + stop_prg("ATOM", "this rtype not programmed"); + } + + fclose(file); + } else { + stop_prg("ATOM", "No information on atoms found"); + } } -void read_file(char* filen, system_type* atype) { - int iunit, i, j, ios; - int exists; +void print_c(int iw, double **c, int n) { + int i; - exists = access(filen, F_OK) != -1; - if (exists) { - iunit = get_unit(); - FILE* file = fopen(filen, "r"); - fscanf(file, "%d", &atype->n); - - atype->c = (double**)malloc(3 * sizeof(double*)); - for (i = 0; i < 3; i++) { - atype->c[i] = (double*)malloc(atype->n * sizeof(double)); - } - if (atype->c == NULL) { - stop_memory("ATOM", "atype%c", 3 * atype->n); - } - atype->v = NULL; - - if (strcmp(atype->rtype, "POS") == 0) { - for (i = 0; i < atype->n; i++) { - fscanf(file, "%lf %lf %lf", &atype->c[0][i], &atype->c[1][i], &atype->c[2][i]); - } - fscanf(file, "%lf %lf %lf", &atype->box[0][0], &atype->box[0][1], &atype->box[0][2]); - fscanf(file, "%lf %lf %lf", &atype->box[1][0], &atype->box[1][1], &atype->box[1][2]); - fscanf(file, "%lf %lf %lf", &atype->box[2][0], &atype->box[2][1], &atype->box[2][2]); - } else if (strcmp(atype->rtype, "POSVEL") == 0) { - atype->v = (double**)malloc(3 * sizeof(double*)); - for (i = 0; i < 3; i++) { - atype->v[i] = (double*)malloc(atype->n * sizeof(double)); - } - if (atype->v == NULL) { - stop_memory("ATOM", "atype%v", 3 * atype->n); - } - - for (i = 0; i < atype->n; i++) { - fscanf(file, "%lf %lf %lf", &atype->c[0][i], &atype->c[1][i], &atype->c[2][i]); - } - fscanf(file, "%lf %lf %lf", &atype->box[0][0], &atype->box[0][1], &atype->box[0][2]); - fscanf(file, "%lf %lf %lf", &atype->box[1][0], &atype->box[1][1], &atype->box[1][2]); - fscanf(file, "%lf %lf %lf", &atype->box[2][0], &atype->box[2][1], &atype->box[2][2]); - for (i = 0; i < atype->n; i++) { - fscanf(file, "%lf %lf %lf", &atype->v[0][i], &atype->v[1][i], &atype->v[2][i]); - } - } else { - stop_prg("ATOM", "this rtype not programmed"); - } - - fclose(file); - } else { - stop_prg("ATOM", "No information on atoms found"); - } + printf("ATOM| Atom coordinates [Angstrom]\n"); + for (i = 0; i < n; i++) { + printf("ATOM| %d %15.5f %15.5f %15.5f\n", i, c[0][i], c[1][i], c[2][i]); + } } -void print_c(int iw, double** c, int n) { - int i; +void print_cv(int iw, double **c, double **v, int n) { + int i; - printf("ATOM| Atom coordinates [Angstrom]\n"); - for (i = 0; i < n; i++) { - printf("ATOM| %d %15.5f %15.5f %15.5f\n", i, c[0][i], c[1][i], c[2][i]); - } -} - -void print_cv(int iw, double** c, double** v, int n) { - int i; - - printf("ATOM| Atom coordinates [Angstrom]\n"); - for (i = 0; i < n; i++) { - printf("ATOM| %d %10.4f %10.4f %10.4f %10.4f %10.4f %10.4f\n", i, c[0][i], c[1][i], c[2][i], v[0][i], v[1][i], v[2][i]); - } + printf("ATOM| Atom coordinates [Angstrom]\n"); + for (i = 0; i < n; i++) { + printf("ATOM| %d %10.4f %10.4f %10.4f %10.4f %10.4f %10.4f\n", i, c[0][i], c[1][i], + c[2][i], v[0][i], v[1][i], v[2][i]); + } } diff --git a/src/atoms_input.h b/src/atoms_input.h new file mode 100644 index 0000000..799a584 --- /dev/null +++ b/src/atoms_input.h @@ -0,0 +1,33 @@ +#ifndef _ATOMS_INPUT_H +#define _ATOMS_INPUT_H + +#ifdef __cplusplus +namespace CP2K_NS { +#include +#include +#else +#include +#include +#endif + +typedef struct system_type { + double box[3][3]; + char ptype[4]; + char rtype[21]; + int n; + double** c; + double** v; +} system_type; + +void read_coord_vel(system_type, char*, global_environment_type); + +void read_file(FILE); +void read_file(FILE, bool); +void print_c(int, std::vector>); +void print_cv(int, std::vector>, std::vector>); + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/coefficient_types.F b/src/coefficient_types.F deleted file mode 100644 index a07ba90..0000000 --- a/src/coefficient_types.F +++ /dev/null @@ -1,164 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE coefficient_types - - USE kinds, ONLY : dbl - USE pw_grid_types, ONLY : pw_grid_type - USE pw_types, ONLY : pw_type, pw_zero, pw_allocate, pw_deallocate, & - REALDATA1D, COMPLEXDATA1D, REALDATA3D, COMPLEXDATA3D - USE stop_program, ONLY : stop_prg - - IMPLICIT NONE - - PRIVATE - PUBLIC :: coeff_type, coeff_allocate, coeff_deallocate, coeff_zero - PUBLIC :: PLANEWAVES, GAUSSIAN - PUBLIC :: PW_REALDATA1D, PW_COMPLEXDATA1D, PW_REALDATA3D, PW_COMPLEXDATA3D - - !! 'group_id' to grid? - TYPE coeff_type - TYPE ( pw_type ) :: pw -! TYPE ( gaussian_type ) :: gaussian - - INTEGER :: in_use - END TYPE coeff_type - - !! Flags for the structure member 'in_use' - INTEGER, PARAMETER :: PLANEWAVES = 401, GAUSSIAN = 402 - - INTERFACE coeff_allocate - MODULE PROCEDURE & - coeff_allocate_from_coeff, coeff_allocate_from_grid - END INTERFACE - - !! Flags for 'integral' - PUBLIC :: SQUARE, SQUAREROOT - INTEGER, PARAMETER :: SQUARE = 391, SQUAREROOT = 392 - - INTEGER, PARAMETER :: PW_REALDATA1D = REALDATA1D - INTEGER, PARAMETER :: PW_COMPLEXDATA1D = COMPLEXDATA1D - INTEGER, PARAMETER :: PW_REALDATA3D = REALDATA3D - INTEGER, PARAMETER :: PW_COMPLEXDATA3D = COMPLEXDATA3D - -CONTAINS - -!****************************************************************************** - -SUBROUTINE coeff_allocate_from_coeff ( c_out, c_model, use_basis ) - - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( IN ), TARGET :: c_model - TYPE ( coeff_type ), INTENT ( OUT ) :: c_out - INTEGER, INTENT ( IN ), OPTIONAL :: use_basis - -! Locals - INTEGER :: use_data - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( use_basis ) ) THEN - IF ( use_basis == PLANEWAVES ) THEN - c_out % in_use = PLANEWAVES - CALL pw_allocate ( c_out % pw, c_model % pw % pw_grid, & - use_data = c_model % pw % in_use ) - - ELSE IF ( use_basis == PW_REALDATA1D .or. use_basis == PW_COMPLEXDATA1D & - .or. use_basis == PW_REALDATA3D .or. use_basis == PW_COMPLEXDATA3D & - ) THEN - - c_out % in_use = PLANEWAVES - - CALL pw_allocate ( c_out % pw, c_model % pw % pw_grid, & - use_data = use_basis ) - - ELSE - CALL stop_prg ( "coeff_allocate_from_coeff", & - "no suitable data with use_basis" ) - - END IF - - ELSE - use_data = c_model % pw % in_use - IF ( use_data == PW_REALDATA1D .or. use_data == PW_COMPLEXDATA1D .or. & - use_data == PW_REALDATA3D .or. use_data == PW_COMPLEXDATA3D ) THEN - - c_out % in_use = PLANEWAVES - CALL pw_allocate ( c_out % pw, c_model % pw % pw_grid, & - use_data = c_model % pw % in_use ) - - ELSE - CALL stop_prg ( "coeff_allocate_from_coeff", & - "no suitable data without use_basis" ) - END IF - END IF - -END SUBROUTINE coeff_allocate_from_coeff - -!****************************************************************************** - -SUBROUTINE coeff_allocate_from_grid ( c_out, pw_grid, use_data ) - - IMPLICIT NONE - -! Arguments - TYPE ( pw_grid_type ), INTENT ( IN ), OPTIONAL :: pw_grid - INTEGER, INTENT ( IN ) :: use_data - TYPE ( coeff_type ), INTENT ( OUT ) :: c_out - -! Locals - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( pw_grid ) ) THEN - c_out % in_use = PLANEWAVES - CALL pw_allocate ( c_out % pw, pw_grid, use_data ) - ELSE - CALL stop_prg ( "coeff_allocate_from_grid", "no suitable grid" ) - END IF - -END SUBROUTINE coeff_allocate_from_grid - -!****************************************************************************** - -SUBROUTINE coeff_deallocate ( coeff ) - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( INOUT ) :: coeff - -!------------------------------------------------------------------------------ - - IF ( coeff % in_use == PLANEWAVES ) THEN - CALL pw_deallocate ( coeff % pw ) - ELSE - CALL stop_prg ( "coeff_deallocate", "no valid data type" ) - END IF - -END SUBROUTINE coeff_deallocate - -!****************************************************************************** - -SUBROUTINE coeff_zero ( coeff ) - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( INOUT ) :: coeff - -!------------------------------------------------------------------------------ - - IF ( coeff % in_use == PLANEWAVES ) THEN - CALL pw_zero ( coeff % pw ) - ELSE - CALL stop_prg ( "coeff_zero", "no valid data type" ) - END IF - -END SUBROUTINE coeff_zero - -!****************************************************************************** - -END MODULE coefficient_types diff --git a/src/coefficient_types.cpp b/src/coefficient_types.cpp new file mode 100644 index 0000000..ae31e90 --- /dev/null +++ b/src/coefficient_types.cpp @@ -0,0 +1,60 @@ +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ + +#include "coefficients.h" + +using namespace CP2K_NS; + +void coeff_allocate_from_coeff(coeff_type c_out, coeff_type c_model, int use_basis) { + + int use_data; + + if (use_basis > 0) { + if (use_basis == PLANEWAVES) { + c_out.in_use = PLANEWAVES; + pw_allocate(c_out.pw, c_model.pw.pw_grid, c_model.pw.in_use); + } else if (use_basis == PW_REALDATA1D || use_basis == PW_COMPLEXDATA1D || + use_basis == PW_REALDATA3D || use_basis == PW_COMPLEXDATA3D) { + c_out.in_use = PLANEWAVES; + pw_allocate(c_out.pw, c_model.pw.pw_grid, use_basis); + } else { + stop_prg ("coeff_allocate_from_coeff", "no suitable data with use_basis"); + } + } else { + use_data = c_model.pw.in_use; + if ( use_data == PW_REALDATA1D || use_data == PW_COMPLEXDATA1D || + use_data == PW_REALDATA3D || use_data == PW_COMPLEXDATA3D ) { + c_out.in_use = PLANEWAVES; + pw_allocate(c_out.pw, c_model.pw.pw_grid, c_model.pw.in_use); + } else { + stop_prg("coeff_allocate_from_coeff", "no suitable data without use_basis"); + } + } +} + +void coeff_allocate_from_grid(coeff_type c_out, pw_grid_type pw_grid, int use_data) { + if (pw_grid) { + c_out.in_use = PLANEWAVES; + pw_allocate(c_out.pw, pw_grid, use_data); + } else { + stop_prg("coeff_allocate_from_grid", "no suitable grid"); + } +} + +void coeff_deallocate(coeff_type coeff) { + if (coeff.in_use == PLANEWAVES) { + pw_deallocate(coeff.pw); + } else { + stop_prg("coeff_deallocate", "no valid data type"); + } +} + +void coeff_zero(coeff_type coeff) { + if (coeff.in_use == PLANEWAVES) { + pw_zero(coeff.pw); + } else { + stop_prg("coeff_zero", "no valid data type"); + } +} diff --git a/src/coefficients.F b/src/coefficients.F deleted file mode 100644 index f7753cc..0000000 --- a/src/coefficients.F +++ /dev/null @@ -1,63 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE coefficients - - USE coefficient_types, ONLY : coeff_type, PLANEWAVES - USE kinds, ONLY : dbl - USE pws, ONLY : pw_integral_a, pw_integral_ab - - IMPLICIT NONE - - PRIVATE - PUBLIC :: integral - - INTERFACE integral - MODULE PROCEDURE integral_a, integral_ab - END INTERFACE - -CONTAINS - -!****************************************************************************** - -FUNCTION integral_a ( coeff, flag ) RESULT ( integral_value ) - - TYPE ( coeff_type ), INTENT ( IN ) :: coeff - INTEGER, INTENT ( IN ), OPTIONAL :: flag - - REAL ( dbl ) :: integral_value - -!------------------------------------------------------------------------------ - - IF ( coeff % in_use == PLANEWAVES ) THEN - integral_value = pw_integral_a ( coeff % pw, flag ) - ELSE - stop "integral_a, not defined" - END IF - -END FUNCTION integral_a - -!****************************************************************************** - -FUNCTION integral_ab ( coeff1, coeff2, flag ) RESULT ( integral_value ) - - TYPE ( coeff_type ), INTENT ( IN ) :: coeff1, coeff2 - INTEGER, INTENT ( IN ), OPTIONAL :: flag - - REAL ( dbl ) :: integral_value - -!------------------------------------------------------------------------------ - - IF ( coeff1 % in_use == PLANEWAVES .AND. coeff2 % in_use == PLANEWAVES ) THEN - integral_value = pw_integral_ab ( coeff1 % pw, coeff2 % pw, flag ) - ELSE - stop "integral_ab, not defined" - END IF - -END FUNCTION integral_ab - -!****************************************************************************** - -END MODULE coefficients diff --git a/src/coefficients.cpp b/src/coefficients.cpp new file mode 100644 index 0000000..7efaece --- /dev/null +++ b/src/coefficients.cpp @@ -0,0 +1,28 @@ +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ + +#include "coefficients.h" + +double integral_a(coeff_type *coeff, int flag) { + if (strncpy(coeff->in_use, PLANEWAVES, 256)) { + integral_value = pw_integral_a(coeff->pw, flag); + } else { + printf("integral_a, not defined"); + exit(1); + } + + return integral_value; +} + +double integral_ab(coeff_type *coeff1, coeff_type *coeff2, int flag) { + if (strncpy(coeff1->in_use, PLANEWAVES, 256) && strncpy(coeff2->in_use, PLANEWAVES, 256)) { + integral_value = pw_integral_ab(coeff1->pw, coeff2->pw, flag); + } else { + printf("integral_ab, not defined"); + exit(1); + } + + return integral_value; +} diff --git a/src/coefficients.h b/src/coefficients.h new file mode 100644 index 0000000..34fb29e --- /dev/null +++ b/src/coefficients.h @@ -0,0 +1,36 @@ +#ifndef _COEFF_H +#define _COEFF_H + +#include "pw.h" +#include "stop.h" + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + +const int PLANEWAVES = 401; +const int GAUSSIAN = 402; + +const int SQUARE = 391; +const int SQUAREROOT = 392; + +const int PW_REALDATA1D = REALDATA1D; +const int PW_COMPLEXDATA1D = COMPLEXDATA1D; +const int PW_REALDATA3D = REALDATA3D; +const int PW_COMPLEXDATA3D = COMPLEXDATA3D; + +typedef struct coeff_type { + struct pw_type pw; + int in_use; +} coeff_type; + +void coeff_allocate_from_coeff(coeff_type, coeff_type, int); +void coeff_allocate_from_grid(coeff_type, pw_grid_type, int); +void coeff_deallocate(coeff_type); +void coeff_zero(coeff_type); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/src/complex.h b/src/complex.h new file mode 100644 index 0000000..5940c86 --- /dev/null +++ b/src/complex.h @@ -0,0 +1,9 @@ +#ifndef _COMPLEX_H +#define _COMPLEX_H + +typedef struct complex { + double real; + double imag; +} complex; + +#endif \ No newline at end of file diff --git a/src/constraint.F b/src/constraint.c similarity index 77% rename from src/constraint.F rename to src/constraint.c index 62f6ab1..cc0fe6b 100644 --- a/src/constraint.F +++ b/src/constraint.c @@ -1,189 +1,97 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! +/*-----------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*-----------------------------------------------------------------------------*/ -MODULE constraint - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE md, ONLY : simulation_parameters_type, thermodynamic_type - USE molecule_types, ONLY : molecule_structure_type, & - linklist_dist_constraints, linklist_g3x3_constraints - USE mp, ONLY : mp_sum - USE stop_program, ONLY : stop_prg - USE timings, ONLY : timeset, timestop - USE util, ONLY : getinv3x3, dotprod_3d, matvec_3x3, matmul_3x3, transpose_3d - - IMPLICIT NONE - - PRIVATE - PUBLIC :: shake_control, rattle_control, pv_constraint, getold - PUBLIC :: roll, initialize_roll, shake_roll_control, rattle_roll_control - - REAL ( dbl ) :: scale - REAL ( dbl ), DIMENSION (3,3) :: r_rattle - -CONTAINS +#include "md.h" +#include "molecule.h" -!****************************************************************************** +double scale; +double r_rattle[3][3]; -SUBROUTINE shake_control(molecule,simpar) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: & - molecule - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - -! Locals - REAL ( dbl ) :: max_sigma - INTEGER :: imol, iconst, ishake, nmol, handle - -!------------------------------------------------------------------------------ - -! initialize locals - CALL timeset ( 'SHAKE_CONTROL', 'I', ' ', handle ) - - nmol = SIZE ( molecule ) - MOL: DO imol = 1, nmol - -! 3x3 - IF (molecule(imol)%ng3x3const_mol /= 0 ) THEN - CALL shake_3x3(molecule(imol),simpar,ishake) - END IF - - ishake = 0 - -! dist - IF (molecule(imol)%ndistconst_mol /= 0 ) THEN - max_sigma = -1.0E+10_dbl - CONS: DO WHILE (abs(max_sigma)>=simpar%shake_tol) - max_sigma = 0._dbl - ishake = ishake + 1 - CALL shake(molecule(imol),simpar,max_sigma,ishake) - END DO CONS - END IF - END DO MOL - - CALL timestop ( 0.0_dbl, handle ) - -END SUBROUTINE shake_control +void shake_control(molecule_structure_type *molecule, simulation_parameters_type simpar) { + int nmol = sizeof(molecule) / sizeof(molecule[0]); + for (int imol = 0; imol < nmol; imol++) { + if (molecule[imol].ng3x3const_mol != 0) { + shake_3x3(&molecule[imol], simpar); + } + int ishake = 0; + if (molecule[imol].ndistconst_mol != 0) { + double max_sigma = -1.0E+10; + while (fabs(max_sigma) >= simpar.shake_tol) { + max_sigma = 0.0; + ishake++; + shake(&molecule[imol], simpar, &max_sigma, ishake); + } + } + } +} -!****************************************************************************** +void rattle_control(molecule_structure_type *molecule, simulation_parameters_type simpar) { + int nmol = sizeof(molecule) / sizeof(molecule[0]); + for (int imol = 0; imol < nmol; imol++) { + if (molecule[imol].ng3x3const_mol != 0) { + rattle_3x3(&molecule[imol], simpar); + } + int irattle = 0; + if (molecule[imol].ndistconst_mol != 0) { + double max_sigma = -1.0E+10; + while (fabs(max_sigma) >= simpar.shake_tol) { + max_sigma = 0.0; + irattle++; + rattle(&molecule[imol], simpar, &max_sigma, irattle); + } + } + } +} -SUBROUTINE rattle_control ( molecule, simpar ) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: & - molecule - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - -! Locals - REAL ( dbl ) :: max_sigma - INTEGER :: imol, iconst, nmol, irattle, handle - -!------------------------------------------------------------------------------ - - CALL timeset ( 'RATTLE_CONTROL', 'I', ' ', handle ) -! initialize locals - nmol = SIZE ( molecule ) - - MOL: DO imol = 1, nmol -! 3x3 - IF ( molecule ( imol ) % ng3x3const_mol /= 0 ) THEN - CALL rattle_3x3 ( molecule ( imol ), simpar ) - END IF - irattle = 0 - -! dist - IF ( molecule ( imol ) % ndistconst_mol /= 0 ) THEN - max_sigma = -1.0E+10_dbl - CONS: DO WHILE ( ABS ( max_sigma ) >= simpar % shake_tol ) - max_sigma = 0.0_dbl - irattle = irattle + 1 - CALL rattle ( molecule ( imol ), simpar, max_sigma, irattle ) - END DO CONS - END IF - END DO MOL - - CALL timestop ( 0.0_dbl, handle ) - -END SUBROUTINE rattle_control +void shake_roll_control(molecule_structure_type *molecule, simulation_parameters_type simpar, thermodynamic_type *thermo, double *vector, double *roll_tol, int *iroll, int group, double **u) { -!****************************************************************************** + double max_sigma; + int imol, iconst, ishake, nmol, handle; + double r_shake[3][3]; -SUBROUTINE shake_roll_control ( molecule, simpar, thermo, roll_tol, iroll, & - vector, group, u ) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_structure_type ), INTENT ( INOUT ), DIMENSION ( : ) :: & - molecule - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE ( thermodynamic_type ), INTENT ( INOUT ), OPTIONAL :: thermo - REAL ( dbl ), INTENT ( IN ), DIMENSION ( : ) :: vector - REAL ( dbl ), INTENT ( OUT ) :: roll_tol - INTEGER, INTENT ( INOUT ) :: iroll - INTEGER, INTENT ( IN ) :: group - REAL ( dbl ), INTENT ( IN ), OPTIONAL, DIMENSION ( :, : ) :: u - -! Locals - REAL ( dbl ) :: max_sigma - INTEGER :: imol, iconst, ishake, nmol, handle - REAL ( dbl ), DIMENSION ( 3, 3 ) :: r_shake - -!------------------------------------------------------------------------------ - - CALL timeset ( 'SHAKE_ROLL', 'I', ' ', handle ) - -! setting up for roll - IF ( simpar % ensemble == 'NPT_I' ) THEN - CALL get_r_shake ( r_shake, vector ) - ELSE IF ( simpar % ensemble == 'NPT_F' ) THEN - CALL get_r_shake ( r_shake, vector, u ) - END IF - -! initialize locals - nmol = SIZE ( molecule ) - MOL: DO imol = 1, nmol - -! 3x3 - IF (molecule(imol)%ng3x3const_mol /= 0 ) THEN - CALL shake_roll_3x3(molecule(imol),simpar,r_shake,ishake) - END IF - ishake = 0 - -! dist - IF (molecule(imol)%ndistconst_mol /= 0 ) THEN - max_sigma = -1.0E+10_dbl - CONS: DO WHILE (abs(max_sigma)>=simpar%shake_tol) - ishake = ishake + 1 - max_sigma = 0._dbl - CALL shake_roll(molecule(imol),simpar,r_shake,max_sigma,ishake) - END DO CONS - END IF - END DO MOL - - IF ( simpar % ensemble == 'NPT_I' ) & - CALL check_tol ( roll_tol, iroll, 'SHAKE', vector ) - CALL pv_constraint ( molecule, thermo, 'FULL', group ) - - CALL timestop ( 0.0_dbl, handle ) - -END SUBROUTINE shake_roll_control + nmol = sizeof(molecule) / sizeof(molecule[0]); + + // setting up for roll + if (strcmp(simpar.ensemble, "NPT_I") == 0) { + get_r_shake(r_shake, vector); + } else if (strcmp(simpar.ensemble, "NPT_F") == 0) { + get_r_shake(r_shake, vector, u); + } + + // initialize locals + for (int imol = 0; imol < nmol; imol++) { + // 3x3 + if (molecule[imol].ng3x3const_mol != 0) { + shake_roll_3x3(&molecule[imol], simpar, r_shake, ishake); + } + ishake = 0; + + // dist + if (molecule[imol].ndistconst_mol != 0) { + double max_sigma = -1.0E+10; + while (fabs(max_sigma) >= simpar.shake_tol) { + ishake++; + max_sigma = 0.0; + shake_roll(&molecule[imol], simpar, r_shake, &max_sigma, &ishake); + } + } + } + + if (strcmp(simpar.ensemble, "NPT_I") == 0) { + check_tol(roll_tol, iroll, "SHAKE", vector); + } + pv_constraint(molecule, thermo, "FULL", group); +} !****************************************************************************** SUBROUTINE rattle_roll_control ( molecule, simpar, thermo, veps, & roll_tol, iroll, group ) - + IMPLICIT NONE - + ! Arguments TYPE ( molecule_structure_type ), INTENT ( INOUT ), DIMENSION ( : ) :: & molecule @@ -193,59 +101,59 @@ SUBROUTINE rattle_roll_control ( molecule, simpar, thermo, veps, & REAL ( dbl ), INTENT ( OUT ) :: roll_tol INTEGER, INTENT ( INOUT ) :: iroll INTEGER, INTENT ( IN ) :: group - + ! Locals REAL ( dbl ) :: max_sigma, feps INTEGER :: imol, iconst, irattle, nmol, handle - + !------------------------------------------------------------------------------ - + CALL timeset( 'RATTLE_ROLL','I',' ',handle) - + ! initialize locals irattle = 0 nmol = SIZE ( molecule ) - max_sigma = -1.0E+10_dbl - + max_sigma = -1.0E+10 + ! Initialize scale and r_rattle CONS: DO WHILE (abs(max_sigma)>=simpar%shake_tol) irattle = irattle + 1 - max_sigma = 0._dbl + max_sigma = 0. MOL: DO imol = 1, nmol IF (molecule(imol)%ndistconst_mol /= 0 ) THEN - + ! dist CALL rattle_roll(molecule(imol),simpar,veps,max_sigma,irattle) ELSE IF (molecule(imol)%ng3x3const_mol /= 0 ) THEN - + ! 3x3 CALL rattle_roll_3x3(molecule(imol),simpar,veps,max_sigma,irattle) END IF END DO MOL - + ! update veps IF ( irattle /= 1 ) CALL update_veps ( molecule, & veps, thermo, simpar % ensemble, group ) END DO CONS - + CALL check_tol ( roll_tol, iroll, 'RATTLE', molecule = molecule ) CALL pv_constraint ( molecule, thermo, 'FULL', group ) - - CALL timestop ( 0.0_dbl, handle ) - + + CALL timestop ( 0.0, handle ) + END SUBROUTINE rattle_roll_control !****************************************************************************** SUBROUTINE shake_3x3 ( molecule, simpar, ishake ) - + IMPLICIT NONE - + ! Arguments TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar INTEGER, INTENT ( OUT ) :: ishake - + ! Locals REAL ( dbl ) :: idtsq, dtsqby2, dtby2, imass1, imass2, imass3 REAL ( dbl ) :: sigma, max_sigma @@ -255,26 +163,26 @@ SUBROUTINE shake_3x3 ( molecule, simpar, ishake ) REAL ( dbl ), DIMENSION(3,3) :: amat, ainv TYPE (linklist_g3x3_constraints), POINTER :: llconst INTEGER :: info, iconst - + !------------------------------------------------------------------------------ - + ! define local variables - dtsqby2 = simpar%dt*simpar%dt*.5_dbl - idtsq = 1._dbl/simpar%dt/simpar%dt - dtby2 = simpar%dt*.5_dbl + dtsqby2 = simpar%dt*simpar%dt*.5 + idtsq = 1./simpar%dt/simpar%dt + dtby2 = simpar%dt*.5 llconst => molecule%ll_g3x3_const DO iconst = 1, molecule%ng3x3const_mol ishake=0 r0_12=llconst%p1%r-llconst%p2%r r0_13=llconst%p1%r-llconst%p3%r r0_23=llconst%p2%r-llconst%p3%r - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass - imass3 = 1._dbl/llconst%p3%prop%mass - llconst%fc1 = -2._dbl*(llconst%rold1-llconst%rold2) - llconst%fc2 = -2._dbl*(llconst%rold1-llconst%rold3) - llconst%fc3 = -2._dbl*(llconst%rold2-llconst%rold3) - + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass + imass3 = 1./llconst%p3%prop%mass + llconst%fc1 = -2.*(llconst%rold1-llconst%rold2) + llconst%fc2 = -2.*(llconst%rold1-llconst%rold3) + llconst%fc3 = -2.*(llconst%rold2-llconst%rold3) + ! construct matrix amat(1,1)=(imass1+imass2)*DOTPROD_3D(r0_12,llconst%fc1) amat(1,2)=imass1*DOTPROD_3D(r0_12,llconst%fc2) @@ -285,11 +193,11 @@ SUBROUTINE shake_3x3 ( molecule, simpar, ishake ) amat(3,1)=-imass2*DOTPROD_3D(r0_23,llconst%fc1) amat(3,2)=imass3*DOTPROD_3D(r0_23,llconst%fc2) amat(3,3)=(imass3+imass2)*DOTPROD_3D(r0_23,llconst%fc3) - + ! Iterate until convergence: - max_sigma = -1.0E+10_dbl + max_sigma = -1.0E+10 CONS: DO WHILE (abs(max_sigma)>=simpar%shake_tol) - max_sigma=0._dbl + max_sigma=0. ishake=ishake+1 vec= llconst%lambda(1)*llconst%fc1*(imass1+imass2) + & llconst%lambda(2)*imass1*llconst%fc2 - & @@ -307,10 +215,10 @@ SUBROUTINE shake_3x3 ( molecule, simpar, ishake ) bvec(3)=llconst%d23*llconst%d23-dtsqby2*dtsqby2*DOTPROD_3D(vec,vec) & -DOTPROD_3D(r0_23,r0_23) bvec = bvec * idtsq - + ! find inverse of amat CALL getinv3x3 ( amat, ainv ) - + ! get lambda llconst%lambda ( : )=MATVEC_3x3(ainv,bvec) fc1=llconst%lambda(1)*llconst%fc1+ & @@ -328,43 +236,43 @@ SUBROUTINE shake_3x3 ( molecule, simpar, ishake ) r12=r1-r2 r13=r1-r3 r23=r2-r3 - + ! compute the tolerance: - sigma = dot_product(r12,r12) - llconst%d12*llconst%d12 + sigma = dot_product(r12,r12) - llconst%d12*llconst%d12 max_sigma=MAX(max_sigma,ABS(sigma)) - sigma = dot_product(r13,r13) - llconst%d13*llconst%d13 + sigma = dot_product(r13,r13) - llconst%d13*llconst%d13 max_sigma=MAX(max_sigma,ABS(sigma)) - sigma = dot_product(r23,r23) - llconst%d23*llconst%d23 + sigma = dot_product(r23,r23) - llconst%d23*llconst%d23 max_sigma=MAX(max_sigma,ABS(sigma)) END DO CONS - + ! update positions with full multiplier llconst%p1%r = r1 llconst%p2%r = r2 llconst%p3%r = r3 - + ! update velocites with full multiplier llconst%p1%v = v1 llconst%p2%v = v2 llconst%p3%v = v3 llconst => llconst%next - + END DO - + END SUBROUTINE shake_3x3 !****************************************************************************** SUBROUTINE shake_roll_3x3(molecule,simpar,r_shake,ishake) - + IMPLICIT NONE - + ! Arguments TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ) :: r_shake INTEGER, INTENT ( OUT ) :: ishake - + ! Locals REAL ( dbl ) :: idtsq, dtsqby2, dtby2, imass1, imass2, imass3 REAL ( dbl ) :: sigma, max_sigma @@ -375,32 +283,32 @@ SUBROUTINE shake_roll_3x3(molecule,simpar,r_shake,ishake) REAL ( dbl ), DIMENSION(3,3) :: amat, ainv TYPE (linklist_g3x3_constraints), POINTER :: llconst INTEGER :: info, iconst - + !------------------------------------------------------------------------------ - + ! define local variables - dtsqby2 = simpar%dt*simpar%dt*.5_dbl - idtsq = 1._dbl/simpar%dt/simpar%dt - dtby2 = simpar%dt*.5_dbl + dtsqby2 = simpar%dt*simpar%dt*.5 + idtsq = 1./simpar%dt/simpar%dt + dtby2 = simpar%dt*.5 llconst => molecule%ll_g3x3_const - + DO iconst = 1, molecule%ng3x3const_mol ishake=0 r0_12=llconst%p1%r-llconst%p2%r r0_13=llconst%p1%r-llconst%p3%r r0_23=llconst%p2%r-llconst%p3%r - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass - imass3 = 1._dbl/llconst%p3%prop%mass - llconst%fc1 = -2._dbl*(llconst%rold1-llconst%rold2) - llconst%fc2 = -2._dbl*(llconst%rold1-llconst%rold3) - llconst%fc3 = -2._dbl*(llconst%rold2-llconst%rold3) - -! rotate fconst: + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass + imass3 = 1./llconst%p3%prop%mass + llconst%fc1 = -2.*(llconst%rold1-llconst%rold2) + llconst%fc2 = -2.*(llconst%rold1-llconst%rold3) + llconst%fc3 = -2.*(llconst%rold2-llconst%rold3) + +! rotate fconst: f_roll1 = matvec_3x3(r_shake,llconst%fc1) f_roll2 = matvec_3x3(r_shake,llconst%fc2) f_roll3 = matvec_3x3(r_shake,llconst%fc3) - + ! construct matrix amat(1,1)=(imass1+imass2)*DOTPROD_3D(r0_12,f_roll1) amat(1,2)=imass1*DOTPROD_3D(r0_12,f_roll2) @@ -411,11 +319,11 @@ SUBROUTINE shake_roll_3x3(molecule,simpar,r_shake,ishake) amat(3,1)=-imass2*DOTPROD_3D(r0_23,f_roll1) amat(3,2)=imass3*DOTPROD_3D(r0_23,f_roll2) amat(3,3)=(imass3+imass2)*DOTPROD_3D(r0_23,f_roll3) - + ! Iterate until convergence: - max_sigma = -1.0E+10_dbl + max_sigma = -1.0E+10 CONS: DO WHILE (abs(max_sigma)>=simpar%shake_tol) - max_sigma=0._dbl + max_sigma=0. ishake=ishake+1 vec= llconst%lambda(1)*f_roll1*(imass1+imass2) + & llconst%lambda(2)*imass1*f_roll2 - & @@ -433,10 +341,10 @@ SUBROUTINE shake_roll_3x3(molecule,simpar,r_shake,ishake) bvec(3)=llconst%d23*llconst%d23-dtsqby2*dtsqby2*DOTPROD_3D(vec,vec) & -DOTPROD_3D(r0_23,r0_23) bvec=bvec*idtsq - + ! find inverse of amat CALL getinv3x3 ( amat, ainv ) - + ! get lambda llconst%lambda ( : )=MATVEC_3x3(ainv,bvec) fc1=llconst%lambda(1)*f_roll1+ & @@ -454,44 +362,44 @@ SUBROUTINE shake_roll_3x3(molecule,simpar,r_shake,ishake) r12=r1-r2 r13=r1-r3 r23=r2-r3 - + ! compute the tolerance: - sigma = dot_product(r12,r12) - llconst%d12*llconst%d12 + sigma = dot_product(r12,r12) - llconst%d12*llconst%d12 max_sigma=MAX(max_sigma,ABS(sigma)) - sigma = dot_product(r13,r13) - llconst%d13*llconst%d13 + sigma = dot_product(r13,r13) - llconst%d13*llconst%d13 max_sigma=MAX(max_sigma,ABS(sigma)) - sigma = dot_product(r23,r23) - llconst%d23*llconst%d23 + sigma = dot_product(r23,r23) - llconst%d23*llconst%d23 max_sigma=MAX(max_sigma,ABS(sigma)) END DO CONS - + ! update positions with full multiplier llconst%p1%r = r1 llconst%p2%r = r2 llconst%p3%r = r3 - + ! update velocites with full multiplier llconst%p1%v = v1 llconst%p2%v = v2 llconst%p3%v = v3 llconst => llconst%next - + END DO - + END SUBROUTINE shake_roll_3x3 !****************************************************************************** SUBROUTINE rattle_roll_3x3(molecule,simpar,veps,max_sigma,irattle) - + IMPLICIT NONE - + ! Arguments TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar REAL ( dbl ), INTENT ( INOUT ) :: max_sigma INTEGER, INTENT ( IN ) :: irattle REAL ( dbl ), INTENT ( IN ), DIMENSION ( :, : ) :: veps - + ! Locals INTEGER :: iconst, info REAL ( dbl ) :: idt, dtby2, imass1, imass2, imass3, sigma_dot @@ -504,21 +412,21 @@ SUBROUTINE rattle_roll_3x3(molecule,simpar,veps,max_sigma,irattle) REAL ( dbl ), DIMENSION(3) :: fc1, fc2, fc3, lambda REAL ( dbl ), DIMENSION(3,3) :: amat, ainv TYPE (linklist_g3x3_constraints), POINTER :: llconst - + !------------------------------------------------------------------------------ - + ! define local variables - idt = 1._dbl/simpar%dt - dtby2 = simpar%dt*.5_dbl + idt = 1./simpar%dt + dtby2 = simpar%dt*.5 IF (irattle==1) THEN llconst => molecule%ll_g3x3_const DO iconst = 1, molecule%ng3x3const_mol llconst%vold1=llconst%p1%v llconst%vold2=llconst%p2%v llconst%vold3=llconst%p3%v - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass - imass3 = 1._dbl/llconst%p3%prop%mass + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass + imass3 = 1./llconst%p3%prop%mass fc1=llconst%lambda(1)*llconst%fc1+ & llconst%lambda(2)*llconst%fc2 fc2=-llconst%lambda(1)*llconst%fc1+ & @@ -530,10 +438,10 @@ SUBROUTINE rattle_roll_3x3(molecule,simpar,veps,max_sigma,irattle) llconst%p3%v=llconst%p3%v+imass3*dtby2*fc3 llconst => llconst%next END DO - max_sigma = -1.0E+10_dbl - + max_sigma = -1.0E+10 + ELSE - + llconst => molecule%ll_g3x3_const DO iconst = 1, molecule%ng3x3const_mol v12_0=llconst%vold1-llconst%vold2 @@ -542,7 +450,7 @@ SUBROUTINE rattle_roll_3x3(molecule,simpar,veps,max_sigma,irattle) r12=llconst%p1%r-llconst%p2%r r13=llconst%p1%r-llconst%p3%r r23=llconst%p2%r-llconst%p3%r - + ! roll the local velocities v12_0=matvec_3x3(r_rattle,v12_0)*llconst%scale v13_0=matvec_3x3(r_rattle,v13_0)*llconst%scale @@ -550,18 +458,18 @@ SUBROUTINE rattle_roll_3x3(molecule,simpar,veps,max_sigma,irattle) v1_0=matvec_3x3(r_rattle,llconst%vold1)*llconst%scale v2_0=matvec_3x3(r_rattle,llconst%vold2)*llconst%scale v3_0=matvec_3x3(r_rattle,llconst%vold3)*llconst%scale - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass - imass3 = 1._dbl/llconst%p3%prop%mass - llconst%fc1 = -2._dbl*(llconst%p1%r-llconst%p2%r) - llconst%fc2 = -2._dbl*(llconst%p1%r-llconst%p3%r) - llconst%fc3 = -2._dbl*(llconst%p2%r-llconst%p3%r) - + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass + imass3 = 1./llconst%p3%prop%mass + llconst%fc1 = -2.*(llconst%p1%r-llconst%p2%r) + llconst%fc2 = -2.*(llconst%p1%r-llconst%p3%r) + llconst%fc3 = -2.*(llconst%p2%r-llconst%p3%r) + ! roll the fc f_roll1=matvec_3x3(r_rattle,llconst%fc1)*llconst%scale f_roll2=matvec_3x3(r_rattle,llconst%fc2)*llconst%scale f_roll3=matvec_3x3(r_rattle,llconst%fc3)*llconst%scale - + ! construct matrix amat(1,1)=(imass1+imass2)*DOTPROD_3D(r12,f_roll1) amat(1,2)=imass1*DOTPROD_3D(r12,f_roll2) @@ -572,20 +480,20 @@ SUBROUTINE rattle_roll_3x3(molecule,simpar,veps,max_sigma,irattle) amat(3,1)=-imass2*DOTPROD_3D(r23,f_roll1) amat(3,2)=imass3*DOTPROD_3D(r23,f_roll2) amat(3,3)=(imass2+imass3)*DOTPROD_3D(r23,f_roll3) - + ! construct solution vector bvec(1)=DOTPROD_3D(r12,v12_0+MATVEC_3X3(veps,r12)) bvec(2)=DOTPROD_3D(r13,v13_0+MATVEC_3X3(veps,r13)) bvec(3)=DOTPROD_3D(r23,v23_0+MATVEC_3X3(veps,r23)) - bvec = -bvec * 2.0_dbl * idt - + bvec = -bvec * 2.0 * idt + ! find inverse of amat CALL getinv3x3 ( amat, ainv ) - + ! get lambda lambda ( : )=MATVEC_3X3(ainv,bvec) llconst%del_lam=lambda-llconst%lambda - + ! update local velocities for calculation of sigma_dot ! NOTE: use full multiplier because always starting ! from reference velocity, v1_0, v2_0, v3_0. @@ -598,7 +506,7 @@ SUBROUTINE rattle_roll_3x3(molecule,simpar,veps,max_sigma,irattle) v1=v1_0+imass1*dtby2*fc1 v2=v2_0+imass2*dtby2*fc2 v3=v3_0+imass3*dtby2*fc3 - + ! update true velocities fc1=llconst%del_lam(1)*llconst%fc1+ & llconst%del_lam(2)*llconst%fc2 @@ -609,35 +517,35 @@ SUBROUTINE rattle_roll_3x3(molecule,simpar,veps,max_sigma,irattle) llconst%p1%v=llconst%p1%v+imass1*dtby2*fc1 llconst%p2%v=llconst%p2%v+imass2*dtby2*fc2 llconst%p3%v=llconst%p3%v+imass3*dtby2*fc3 - + ! computing the convergence of the sigma_dot v12=v1-v2 - sigma_dot=2._dbl*DOTPROD_3D(r12,v12+MATVEC_3X3(veps,r12)) + sigma_dot=2.*DOTPROD_3D(r12,v12+MATVEC_3X3(veps,r12)) max_sigma = MAX(abs(sigma_dot),max_sigma) v13=v1-v3 - sigma_dot=2._dbl*DOTPROD_3D(r13,v13+MATVEC_3X3(veps,r13)) + sigma_dot=2.*DOTPROD_3D(r13,v13+MATVEC_3X3(veps,r13)) max_sigma = MAX(abs(sigma_dot),max_sigma) v23=v2-v3 - sigma_dot=2._dbl*DOTPROD_3D(r23,v23+MATVEC_3X3(veps,r23)) + sigma_dot=2.*DOTPROD_3D(r23,v23+MATVEC_3X3(veps,r23)) max_sigma = MAX(abs(sigma_dot),max_sigma) llconst%lambda=lambda llconst => llconst%next END DO - + END IF - + END SUBROUTINE rattle_roll_3x3 !****************************************************************************** SUBROUTINE rattle_3x3(molecule,simpar) - + IMPLICIT NONE - + ! Arguments TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - + ! Locals INTEGER :: iconst, info REAL ( dbl ) :: idt, dtby2, imass1, imass2, imass3 @@ -646,12 +554,12 @@ SUBROUTINE rattle_3x3(molecule,simpar) REAL ( dbl ), DIMENSION(3) :: fc1, fc2, fc3 REAL ( dbl ), DIMENSION(3,3) :: amat, ainv TYPE (linklist_g3x3_constraints), POINTER :: llconst - + !------------------------------------------------------------------------------ - + ! define local variables - idt = 1._dbl/simpar%dt - dtby2 = simpar%dt*.5_dbl + idt = 1./simpar%dt + dtby2 = simpar%dt*.5 llconst => molecule%ll_g3x3_const DO iconst = 1, molecule%ng3x3const_mol v12=llconst%p1%v-llconst%p2%v @@ -660,13 +568,13 @@ SUBROUTINE rattle_3x3(molecule,simpar) r12=llconst%p1%r-llconst%p2%r r13=llconst%p1%r-llconst%p3%r r23=llconst%p2%r-llconst%p3%r - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass - imass3 = 1._dbl/llconst%p3%prop%mass - llconst%fc1 = -2._dbl*(llconst%p1%r-llconst%p2%r) - llconst%fc2 = -2._dbl*(llconst%p1%r-llconst%p3%r) - llconst%fc3 = -2._dbl*(llconst%p2%r-llconst%p3%r) - + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass + imass3 = 1./llconst%p3%prop%mass + llconst%fc1 = -2.*(llconst%p1%r-llconst%p2%r) + llconst%fc2 = -2.*(llconst%p1%r-llconst%p3%r) + llconst%fc3 = -2.*(llconst%p2%r-llconst%p3%r) + ! construct matrix amat(1,1)=(imass1+imass2)*DOTPROD_3D(r12,llconst%fc1) amat(1,2)=imass1*DOTPROD_3D(r12,llconst%fc2) @@ -677,16 +585,16 @@ SUBROUTINE rattle_3x3(molecule,simpar) amat(3,1)=-imass2*DOTPROD_3D(r23,llconst%fc1) amat(3,2)=imass3*DOTPROD_3D(r23,llconst%fc2) amat(3,3)=(imass2+imass3)*DOTPROD_3D(r23,llconst%fc3) - + ! construct solution vector bvec(1)=DOTPROD_3D(r12,v12) bvec(2)=DOTPROD_3D(r13,v13) bvec(3)=DOTPROD_3D(r23,v23) - bvec=-bvec*2._dbl*idt - + bvec=-bvec*2.*idt + ! find inverse of amat CALL getinv3x3(amat,ainv) - + ! get lambda llconst%lambda ( : )=MATVEC_3X3(ainv,bvec) fc1=llconst%lambda(1)*llconst%fc1+ & @@ -700,16 +608,16 @@ SUBROUTINE rattle_3x3(molecule,simpar) llconst%p3%v=llconst%p3%v+imass3*dtby2*fc3 llconst => llconst%next END DO - + END SUBROUTINE rattle_3x3 !****************************************************************************** SUBROUTINE shake(molecule,simpar,max_sigma,ishake) - + ! updates the multiplier one molecule type at a time IMPLICIT NONE - + ! Arguments TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar @@ -719,25 +627,25 @@ SUBROUTINE shake(molecule,simpar,max_sigma,ishake) REAL ( dbl ), DIMENSION (3) :: fc_t, r12 TYPE (linklist_dist_constraints), POINTER :: llconst INTEGER :: imol, iconst - + !------------------------------------------------------------------------------ - + ! define local variables - dtsqby2 = simpar%dt*simpar%dt*.5_dbl - dtby2 = simpar%dt*.5_dbl + dtsqby2 = simpar%dt*simpar%dt*.5 + dtby2 = simpar%dt*.5 IF (ishake==1) THEN llconst => molecule%ll_dist_const DO iconst = 1, molecule%ndistconst_mol - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass - llconst%fc = -2._dbl*(llconst%rold1-llconst%rold2) - + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass + llconst%fc = -2.*(llconst%rold1-llconst%rold2) + ! update positions with full multiplier llconst%p1%r = llconst%p1%r + imass1*dtsqby2*llconst%lambda* & llconst%fc llconst%p2%r = llconst%p2%r - imass2*dtsqby2*llconst%lambda* & llconst%fc - + ! update velocites with full multiplier llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%lambda*llconst% & fc @@ -745,38 +653,38 @@ SUBROUTINE shake(molecule,simpar,max_sigma,ishake) fc llconst => llconst%next END DO - + ELSE - + llconst => molecule%ll_dist_const DO iconst = 1, molecule%ndistconst_mol - + ! computing the constraint r12 = llconst%p1%r - llconst%p2%r llconst%sigma = dot_product(r12,r12) - llconst%distance*llconst% & distance - + ! computing fc(dt) - fc_t = -2._dbl*(llconst%p1%r-llconst%p2%r) - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass + fc_t = -2.*(llconst%p1%r-llconst%p2%r) + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass fdotf = dot_product(llconst%fc,fc_t) fdotf_sum = fdotf*imass1 + fdotf*imass2 - del_lam = 2._dbl*llconst%sigma/(simpar%dt*simpar%dt*fdotf_sum) + del_lam = 2.*llconst%sigma/(simpar%dt*simpar%dt*fdotf_sum) llconst%lambda = llconst%lambda + del_lam - + ! update positions by delta_lam llconst%p1%r = llconst%p1%r + imass1*dtsqby2*del_lam*llconst%fc llconst%p2%r = llconst%p2%r - imass2*dtsqby2*del_lam*llconst%fc - + ! update velocites by delta_lam llconst%p1%v = llconst%p1%v + imass1*dtby2*del_lam*llconst%fc llconst%p2%v = llconst%p2%v - imass2*dtby2*del_lam*llconst%fc llconst => llconst%next END DO END IF - -! computing the constraint and value of tolerance + +! computing the constraint and value of tolerance llconst => molecule%ll_dist_const DO iconst = 1, molecule%ndistconst_mol r12 = llconst%p1%r - llconst%p2%r @@ -785,40 +693,40 @@ SUBROUTINE shake(molecule,simpar,max_sigma,ishake) max_sigma = max(abs(llconst%sigma),max_sigma) llconst => llconst%next END DO - + END SUBROUTINE shake !****************************************************************************** SUBROUTINE rattle ( molecule, simpar, max_sigma, irattle ) - + ! updates the multiplier one molecule type at a time IMPLICIT NONE - + ! Arguments TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar REAL ( dbl ), INTENT ( INOUT ) :: max_sigma INTEGER, INTENT ( IN ) :: irattle - + ! Locals REAL ( dbl ) :: dtby2, imass1, imass2, fdotf, fdotf_sum, del_lam REAL ( dbl ), DIMENSION (3) :: r12, v12 TYPE (linklist_dist_constraints), POINTER :: llconst INTEGER :: imol, iconst - + !------------------------------------------------------------------------------ - + ! define local variables - dtby2 = simpar%dt*.5_dbl + dtby2 = simpar%dt*.5 IF (irattle==1) THEN llconst => molecule%ll_dist_const ! if statement to catch molecule types with no constraints.: DO iconst = 1, molecule%ndistconst_mol - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass - llconst%fc = -2._dbl*(llconst%p1%r-llconst%p2%r) - + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass + llconst%fc = -2.*(llconst%p1%r-llconst%p2%r) + ! update velocites with full multiplier llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%lambda*llconst% & fc @@ -826,45 +734,45 @@ SUBROUTINE rattle ( molecule, simpar, max_sigma, irattle ) fc llconst => llconst%next END DO - + ELSE - + llconst => molecule%ll_dist_const DO iconst = 1, molecule%ndistconst_mol - + ! computing sigma r12 = llconst%p1%r - llconst%p2%r v12 = llconst%p1%v - llconst%p2%v - llconst%sigma = 2._dbl*dot_product(r12,v12) - + llconst%sigma = 2.*dot_product(r12,v12) + ! computing f(dt) - llconst%fc = -2._dbl*(llconst%p1%r-llconst%p2%r) - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass + llconst%fc = -2.*(llconst%p1%r-llconst%p2%r) + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass fdotf = dot_product(llconst%fc,llconst%fc) fdotf_sum = fdotf*imass1 + fdotf*imass2 - del_lam = 2._dbl*llconst%sigma/(simpar%dt*fdotf_sum) + del_lam = 2.*llconst%sigma/(simpar%dt*fdotf_sum) llconst%lambda = llconst%lambda + del_lam - + !update velocites with del_lam llconst%p1%v = llconst%p1%v + imass1*dtby2*del_lam*llconst%fc llconst%p2%v = llconst%p2%v - imass2*dtby2*del_lam*llconst%fc llconst => llconst%next END DO END IF - + ! computing the constraint and value of the tolerance llconst => molecule%ll_dist_const DO iconst = 1, molecule%ndistconst_mol - + ! computing the updated constraint r12 = llconst%p1%r - llconst%p2%r v12 = llconst%p1%v - llconst%p2%v - llconst%sigma = 2._dbl*dot_product(r12,v12) + llconst%sigma = 2.*dot_product(r12,v12) max_sigma = max(abs(llconst%sigma),max_sigma) llconst => llconst%next END DO - + END SUBROUTINE rattle !****************************************************************************** @@ -872,34 +780,34 @@ END SUBROUTINE rattle SUBROUTINE rattle_roll(molecule,simpar,veps,max_sigma,irattle) ! updates the multiplier one molecule type at a time - + IMPLICIT NONE - + ! Arguments TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar REAL ( dbl ), INTENT ( INOUT ) :: max_sigma INTEGER, INTENT ( IN ) :: irattle REAL ( dbl ), INTENT ( IN ), DIMENSION ( :, : ) :: veps - + ! Locals REAL ( dbl ) :: dtby2, imass1, imass2, fdotf, fdotf_sum, del_lam REAL ( dbl ), DIMENSION (3) :: r12, v12, f_roll REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: v1, v2 TYPE (linklist_dist_constraints), POINTER :: llconst INTEGER :: imol, iconst, isos - + !------------------------------------------------------------------------------ - + ! define local variables - dtby2 = simpar%dt*.5_dbl + dtby2 = simpar%dt*.5 IF (irattle==1) THEN llconst => molecule%ll_dist_const DO iconst = 1, molecule%ndistconst_mol - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass - llconst%fc = -2._dbl*(llconst%p1%r-llconst%p2%r) - + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass + llconst%fc = -2.*(llconst%p1%r-llconst%p2%r) + ! update velocites with full multiplier llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%lambda*llconst% & fc @@ -907,50 +815,50 @@ SUBROUTINE rattle_roll(molecule,simpar,veps,max_sigma,irattle) fc llconst => llconst%next END DO - max_sigma = -1.E+10_dbl - + max_sigma = -1.E+10 + ELSE llconst => molecule%ll_dist_const - + ! allocating local vs ALLOCATE (v1(3,molecule%ndistconst_mol),STAT=isos) IF ( isos /= 0 ) CALL stop_prg( 'rattle_roll','failed to allocate v1') ALLOCATE (v2(3,molecule%ndistconst_mol),STAT=isos) IF ( isos /= 0 ) CALL stop_prg( 'rattle_roll','failed to allocate v2') - + DO iconst = 1, molecule%ndistconst_mol - + ! assign local variable v1(:,iconst) = llconst%p1%v v2(:,iconst) = llconst%p2%v r12 = llconst%p1%r - llconst%p2%r - + ! Roll the local vs and fc v1(:,iconst) = matvec_3x3(r_rattle ( :, : ),v1(:,iconst)) v2(:,iconst) = matvec_3x3(r_rattle ( :, : ),v2(:,iconst)) v1(:,iconst) = v1(:,iconst)*llconst%scale v2(:,iconst) = v2(:,iconst)*llconst%scale - llconst%fc = -2._dbl*r12 + llconst%fc = -2.*r12 f_roll = matvec_3x3(r_rattle,llconst%fc) f_roll = f_roll*llconst%scale - + ! computing sigma v12 ( : ) = v1(:,iconst) + matvec_3x3(veps,llconst%p1%r) & - v2(:,iconst) - matvec_3x3(veps,llconst%p2%r) - llconst%sigma = 2._dbl*dot_product(r12,v12) - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass + llconst%sigma = 2.*dot_product(r12,v12) + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass fdotf = dot_product(f_roll,llconst%fc) fdotf_sum = fdotf*imass1 + fdotf*imass2 - llconst%del_lam = 2._dbl*llconst%sigma/(simpar%dt*fdotf_sum) + llconst%del_lam = 2.*llconst%sigma/(simpar%dt*fdotf_sum) llconst%lambda = llconst%lambda + llconst%del_lam - + !update local velocities with del_lam v1(:,iconst) = v1(:,iconst) & + imass1*dtby2*llconst%del_lam*f_roll ( : ) v2(:,iconst) = v2(:,iconst) & - imass2*dtby2*llconst%del_lam*f_roll ( : ) - + !update true velocites with del_lam llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%del_lam*llconst & %fc @@ -958,44 +866,44 @@ SUBROUTINE rattle_roll(molecule,simpar,veps,max_sigma,irattle) %fc llconst => llconst%next END DO - + ! computing the constraint and value of the tolerance with local vs llconst => molecule%ll_dist_const DO iconst = 1, molecule%ndistconst_mol - + ! computing the updated constraint r12 = llconst%p1%r - llconst%p2%r - v12 ( : ) = v1(:,iconst)-v2(:,iconst) - llconst%sigma = 2._dbl*DOTPROD_3D(r12,v12+MATVEC_3X3(veps,r12)) + v12 ( : ) = v1(:,iconst)-v2(:,iconst) + llconst%sigma = 2.*DOTPROD_3D(r12,v12+MATVEC_3X3(veps,r12)) max_sigma = max(abs(llconst%sigma),max_sigma) llconst => llconst%next END DO - + DEALLOCATE (v1,STAT=isos) IF ( isos /= 0 ) CALL stop_prg( 'rattle_roll','failed to deallocate v1') DEALLOCATE (v2,STAT=isos) IF ( isos /= 0 ) CALL stop_prg( 'rattle_roll','failed to deallocate v2') - + END IF - + END SUBROUTINE rattle_roll !****************************************************************************** SUBROUTINE getold(molecule) - + IMPLICIT NONE ! Arguments TYPE (molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: molecule - + ! Locals INTEGER :: imol, iconst TYPE (linklist_dist_constraints), POINTER :: ll_dist TYPE (linklist_g3x3_constraints), POINTER :: ll_g3x3 - + !------------------------------------------------------------------------------ - + ! saves all of the old variables DO imol = 1, size(molecule) ll_dist => molecule(imol) %ll_dist_const @@ -1008,7 +916,7 @@ SUBROUTINE getold(molecule) ll_dist%rold2(3) = ll_dist%p2%r(3) ll_dist => ll_dist%next END DO - + ll_g3x3 => molecule(imol) %ll_g3x3_const DO iconst = 1, molecule(imol) %ng3x3const_mol ll_g3x3%rold1(1) = ll_g3x3%p1%r(1) @@ -1022,49 +930,49 @@ SUBROUTINE getold(molecule) ll_g3x3%rold3(3) = ll_g3x3%p3%r(3) ll_g3x3 => ll_g3x3%next END DO - + END DO - + END SUBROUTINE getold !****************************************************************************** SUBROUTINE pv_constraint ( molecule, thermo, char, group ) - + IMPLICIT NONE - + ! Arguments TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo CHARACTER ( LEN = * ), INTENT ( IN ) :: char INTEGER, INTENT ( IN ) :: group - + ! Locals REAL ( dbl ) :: lambda, pv ( 3, 3 ), lambda_3x3 ( 3 ) REAL ( dbl ) :: fc1 ( 3 ), fc2 ( 3 ), fc3 ( 3 ) TYPE ( linklist_dist_constraints ), POINTER :: llconst TYPE ( linklist_g3x3_constraints ), POINTER :: ll3x3 INTEGER :: imol, iconst - + !------------------------------------------------------------------------------ - - pv = 0.0_dbl + + pv = 0.0 DO imol = 1, size(molecule) - + ! dist llconst => molecule(imol) %ll_dist_const DO iconst = 1, molecule(imol) %ndistconst_mol - + SELECT CASE (char) CASE ( 'FULL') ! pv gets updated with FULL multiplier lambda = llconst%lambda - + CASE ( 'DEL') ! pv gets updated with del_lam lambda = llconst%del_lam END SELECT - + !pv(1,1) pv(1,1) = pv(1,1) + lambda*llconst%fc(1)*llconst%p1%r(1) pv(1,1) = pv(1,1) - lambda*llconst%fc(1)*llconst%p2%r(1) @@ -1074,7 +982,7 @@ SUBROUTINE pv_constraint ( molecule, thermo, char, group ) !pv(1,3) pv(1,3) = pv(1,3) + lambda*llconst%fc(1)*llconst%p1%r(3) pv(1,3) = pv(1,3) - lambda*llconst%fc(1)*llconst%p2%r(3) -!pv(2,1) +!pv(2,1) pv(2,1) = pv(2,1) + lambda*llconst%fc(2)*llconst%p1%r(1) pv(2,1) = pv(2,1) - lambda*llconst%fc(2)*llconst%p2%r(1) !pv(2,2) @@ -1094,28 +1002,28 @@ SUBROUTINE pv_constraint ( molecule, thermo, char, group ) pv(3,3) = pv(3,3) - lambda*llconst%fc(3)*llconst%p2%r(3) llconst => llconst%next END DO - + ! 3x3 ll3x3 => molecule(imol)%ll_g3x3_const DO iconst = 1, molecule(imol)%ng3x3const_mol - + SELECT CASE (char) CASE ( 'FULL') ! pv gets updated with FULL multiplier lambda_3x3 = ll3x3%lambda - + CASE ( 'DEL') ! pv gets updated with del_lam lambda_3x3 = ll3x3%del_lam END SELECT - + fc1=lambda_3x3(1)*ll3x3%fc1+ & lambda_3x3(2)*ll3x3%fc2 fc2=-lambda_3x3(1)*ll3x3%fc1+ & lambda_3x3(3)*ll3x3%fc3 fc3=-lambda_3x3(2)*ll3x3%fc2- & lambda_3x3(3)*ll3x3%fc3 - + !pv(1,1) pv(1,1) = pv(1,1) + fc1(1)*ll3x3%p1%r(1) pv(1,1) = pv(1,1) + fc2(1)*ll3x3%p2%r(1) @@ -1128,7 +1036,7 @@ SUBROUTINE pv_constraint ( molecule, thermo, char, group ) pv(1,3) = pv(1,3) + fc1(1)*ll3x3%p1%r(3) pv(1,3) = pv(1,3) + fc2(1)*ll3x3%p2%r(3) pv(1,3) = pv(1,3) + fc3(1)*ll3x3%p3%r(3) -!pv(2,1) +!pv(2,1) pv(2,1) = pv(2,1) + fc1(2)*ll3x3%p1%r(1) pv(2,1) = pv(2,1) + fc2(2)*ll3x3%p2%r(1) pv(2,1) = pv(2,1) + fc3(2)*ll3x3%p3%r(1) @@ -1152,59 +1060,59 @@ SUBROUTINE pv_constraint ( molecule, thermo, char, group ) pv(3,3) = pv(3,3) + fc1(3)*ll3x3%p1%r(3) pv(3,3) = pv(3,3) + fc2(3)*ll3x3%p2%r(3) pv(3,3) = pv(3,3) + fc3(3)*ll3x3%p3%r(3) - + ll3x3 => ll3x3%next END DO - + END DO - + #if defined(__parallel) CALL mp_sum ( pv, group ) #endif - + thermo % pv_const = pv - + END SUBROUTINE pv_constraint !****************************************************************************** SUBROUTINE shake_roll(molecule,simpar,r_shake,max_sigma,ishake) - + ! updates the multiplier one molecule type at a time IMPLICIT NONE - + ! Arguments TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar REAL ( dbl ), INTENT ( INOUT ) :: max_sigma REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ) :: r_shake INTEGER, INTENT ( IN ) :: ishake - + ! Locals REAL ( dbl ) :: dtsqby2, dtby2, imass1, imass2, fdotf, fdotf_sum REAL ( dbl ), DIMENSION (3) :: fc_t, r12, f_roll TYPE (linklist_dist_constraints), POINTER :: llconst INTEGER :: imol, iconst - + !------------------------------------------------------------------------------ - + ! define local variables - dtsqby2 = simpar%dt*simpar%dt*.5_dbl - dtby2 = simpar%dt*.5_dbl + dtsqby2 = simpar%dt*simpar%dt*.5 + dtby2 = simpar%dt*.5 IF (ishake==1) THEN llconst => molecule%ll_dist_const DO iconst = 1, molecule%ndistconst_mol - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass - llconst%fc = -2._dbl*(llconst%rold1-llconst%rold2) - -! rotate fconst: + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass + llconst%fc = -2.*(llconst%rold1-llconst%rold2) + +! rotate fconst: f_roll = matvec_3x3(r_shake,llconst%fc) - + ! update positions with full multiplier llconst%p1%r = llconst%p1%r + imass1*dtsqby2*llconst%lambda*f_roll llconst%p2%r = llconst%p2%r - imass2*dtsqby2*llconst%lambda*f_roll - + ! update velocites with full multiplier llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%lambda*llconst% & fc @@ -1212,48 +1120,48 @@ SUBROUTINE shake_roll(molecule,simpar,r_shake,max_sigma,ishake) fc llconst => llconst%next END DO - + ELSE - + llconst => molecule%ll_dist_const DO iconst = 1, molecule%ndistconst_mol - + ! computing the constraint r12 = llconst%p1%r - llconst%p2%r llconst%sigma = dot_product(r12,r12) - llconst%distance*llconst% & distance - + ! computing fc(dt) - fc_t = -2._dbl*(llconst%p1%r-llconst%p2%r) - imass1 = 1._dbl/llconst%p1%prop%mass - imass2 = 1._dbl/llconst%p2%prop%mass - -! rotate fc: + fc_t = -2.*(llconst%p1%r-llconst%p2%r) + imass1 = 1./llconst%p1%prop%mass + imass2 = 1./llconst%p2%prop%mass + +! rotate fc: f_roll = matvec_3x3(r_shake,llconst%fc) fdotf = dot_product(f_roll,fc_t) fdotf_sum = fdotf*imass1 + fdotf*imass2 - llconst%del_lam = 2._dbl*llconst%sigma/(simpar%dt*simpar%dt* & + llconst%del_lam = 2.*llconst%sigma/(simpar%dt*simpar%dt* & fdotf_sum) llconst%lambda = llconst%lambda + llconst%del_lam - + ! update positions by delta_lam llconst%p1%r = llconst%p1%r + imass1*dtsqby2*llconst%del_lam* & f_roll llconst%p2%r = llconst%p2%r - imass2*dtsqby2*llconst%del_lam* & f_roll - + ! update velocites by delta_lam llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%del_lam*llconst & %fc llconst%p2%v = llconst%p2%v - imass2*dtby2*llconst%del_lam*llconst & %fc - + llconst => llconst%next END DO - + END IF - -! computing the constraint and value of tolerance + +! computing the constraint and value of tolerance llconst => molecule%ll_dist_const DO iconst = 1, molecule%ndistconst_mol r12 = llconst%p1%r - llconst%p2%r @@ -1267,9 +1175,9 @@ END SUBROUTINE shake_roll !****************************************************************************** SUBROUTINE roll(molecule,veps,veta,wb,dt,nnhc,nfree,eval,u) - + IMPLICIT NONE - + ! Arguments TYPE (molecule_structure_type ), INTENT ( INOUT ), DIMENSION ( : ) :: molecule REAL ( dbl ), INTENT ( INOUT ), DIMENSION ( :, : ) :: veta, veps, wb @@ -1277,35 +1185,35 @@ SUBROUTINE roll(molecule,veps,veta,wb,dt,nnhc,nfree,eval,u) INTEGER, INTENT ( IN ) :: nfree, nnhc REAL ( dbl ), INTENT ( IN ), OPTIONAL, DIMENSION ( :, : ) :: u REAL ( dbl ), INTENT ( IN ), OPTIONAL, DIMENSION ( : ) :: eval - + ! Locals REAL ( dbl ) :: aa, bb, infree, trvg REAL ( dbl ), DIMENSION (3,3) :: roll_local, diag TYPE (linklist_dist_constraints), POINTER :: llconst TYPE (linklist_g3x3_constraints), POINTER :: ll3x3 INTEGER :: imol, iconst - + !------------------------------------------------------------------------------ - - infree = 1.0_dbl / REAL ( nfree, dbl ) - + + infree = 1.0 / REAL ( nfree, dbl ) + ! updating the scale factor for barostat velocity - aa = exp(-.125_dbl*dt*veta(1,nnhc)) - bb = exp(-3._dbl*.125_dbl*dt*veta(1,nnhc)) - scale = scale*aa*aa*aa*aa + (aa+bb)*.25_dbl*dt/wb(1,1) - + aa = exp(-.125*dt*veta(1,nnhc)) + bb = exp(-3.*.125*dt*veta(1,nnhc)) + scale = scale*aa*aa*aa*aa + (aa+bb)*.25*dt/wb(1,1) + ! updating the roll matrix for the velocities IF ( PRESENT ( u)) THEN - diag = 0._dbl + diag = 0. diag(1,1) = eval(1) diag(2,2) = eval(2) diag(3,3) = eval(3) trvg = infree*(veps(1,1)+veps(2,2)+veps(3,3)) roll_local = matmul_3x3(matmul_3x3(u,diag),transpose_3d(u)) r_rattle = matmul_3x3(roll_local,r_rattle) - + DO imol = 1, size(molecule) - + ! dist llconst => molecule(imol) %ll_dist_const DO iconst = 1, molecule(imol) %ndistconst_mol @@ -1313,7 +1221,7 @@ SUBROUTINE roll(molecule,veps,veta,wb,dt,nnhc,nfree,eval,u) molecule(imol)%nvt_num)+trvg)) llconst => llconst%next END DO - + ! 3x3 ll3x3 => molecule(imol) %ll_g3x3_const DO iconst = 1, molecule(imol) %ng3x3const_mol @@ -1322,37 +1230,37 @@ SUBROUTINE roll(molecule,veps,veta,wb,dt,nnhc,nfree,eval,u) ll3x3 => ll3x3%next END DO END DO - + ELSE - + DO imol = 1, size(molecule) ! dist llconst => molecule(imol) %ll_dist_const DO iconst = 1, molecule(imol) %ndistconst_mol llconst%scale = llconst%scale*exp(-dt*(veta(1, & - molecule(imol)%nvt_num)+(1._dbl+3._dbl*infree)*veps(1,1))) + molecule(imol)%nvt_num)+(1.+3.*infree)*veps(1,1))) llconst => llconst%next END DO - + ! 3x3 ll3x3 => molecule(imol) %ll_g3x3_const DO iconst = 1, molecule(imol) %ng3x3const_mol ll3x3%scale = ll3x3%scale*exp(-dt*(veta(1, & - molecule(imol)%nvt_num)+(1._dbl+3._dbl*infree)*veps(1,1))) + molecule(imol)%nvt_num)+(1.+3.*infree)*veps(1,1))) ll3x3 => ll3x3%next END DO END DO - + END IF - + END SUBROUTINE roll !****************************************************************************** SUBROUTINE check_tol(roll_tol,iroll,char,vector,molecule) - + IMPLICIT NONE - + ! Arguments REAL ( dbl ), INTENT ( OUT ) :: roll_tol INTEGER, INTENT ( INOUT ) :: iroll @@ -1360,7 +1268,7 @@ SUBROUTINE check_tol(roll_tol,iroll,char,vector,molecule) TYPE ( molecule_structure_type ), INTENT ( IN ), DIMENSION ( : ), & OPTIONAL :: molecule CHARACTER ( LEN = * ), INTENT ( IN ) :: char - + ! Locals REAL ( dbl ), SAVE :: scale_old REAL ( dbl ), DIMENSION (3), SAVE :: vector_old @@ -1371,36 +1279,36 @@ SUBROUTINE check_tol(roll_tol,iroll,char,vector,molecule) TYPE (linklist_dist_constraints), POINTER :: llconst TYPE (linklist_g3x3_constraints), POINTER :: ll3x3 INTEGER :: imol, iconst - + !------------------------------------------------------------------------------ - + SELECT CASE (char) CASE ( 'SHAKE') IF (iroll==1) THEN vector_old = vector - roll_tol = -1.E10_dbl + roll_tol = -1.E10 ELSE - roll_tol = 0._dbl + roll_tol = 0. diff_shake = abs(vector_old-vector) local_tol = maxval(diff_shake) roll_tol = max(roll_tol,local_tol) vector_old = vector END IF iroll = iroll + 1 - + CASE ( 'RATTLE') IF (iroll==1) THEN scale_old = scale r_rattle_old = r_rattle DO imol = 1, size(molecule) - + ! dist llconst => molecule(imol) %ll_dist_const DO iconst = 1, molecule(imol) %ndistconst_mol llconst%scale_old = llconst%scale llconst => llconst%next END DO - + ! 3x3 ll3x3 => molecule(imol) %ll_g3x3_const DO iconst = 1, molecule(imol) %ng3x3const_mol @@ -1408,15 +1316,15 @@ SUBROUTINE check_tol(roll_tol,iroll,char,vector,molecule) ll3x3 => ll3x3%next END DO END DO - roll_tol = -1.E+10_dbl - + roll_tol = -1.E+10 + ELSE - - roll_tol = 0._dbl - -! compute tolerance on + + roll_tol = 0. + +! compute tolerance on DO imol = 1, size(molecule) - + ! dist llconst => molecule(imol) %ll_dist_const DO iconst = 1, molecule(imol) %ndistconst_mol @@ -1425,7 +1333,7 @@ SUBROUTINE check_tol(roll_tol,iroll,char,vector,molecule) llconst%scale_old = llconst%scale llconst => llconst%next END DO - + ! 3x3 ll3x3 => molecule(imol) %ll_g3x3_const DO iconst = 1, molecule(imol) %ng3x3const_mol @@ -1434,86 +1342,86 @@ SUBROUTINE check_tol(roll_tol,iroll,char,vector,molecule) ll3x3%scale_old = ll3x3%scale ll3x3 => ll3x3%next END DO - + END DO - + diff_rattle = abs(r_rattle-r_rattle_old) local_tol = maxval(diff_rattle) roll_tol = max(roll_tol,local_tol) local_tol = abs(scale-scale_old) roll_tol = max(roll_tol,local_tol) END IF - + iroll = iroll + 1 END SELECT - + END SUBROUTINE check_tol !****************************************************************************** SUBROUTINE initialize_roll(molecule) - + IMPLICIT NONE - + ! Arguments TYPE (molecule_structure_type ), INTENT ( INOUT ), DIMENSION ( : ) :: molecule - + ! Locals INTEGER :: imol, iconst REAL ( dbl ), DIMENSION (3,3) :: unit TYPE (linklist_dist_constraints), POINTER :: llconst TYPE (linklist_g3x3_constraints), POINTER :: ll3x3 - + !------------------------------------------------------------------------------ - + ! initialize unit matrix - unit = 0._dbl - unit(1,1) = 1._dbl - unit(2,2) = 1._dbl - unit(3,3) = 1._dbl - + unit = 0. + unit(1,1) = 1. + unit(2,2) = 1. + unit(3,3) = 1. + ! initialize scale variable for veps - scale = 0._dbl + scale = 0. r_rattle = unit - + ! initialize r_rattle DO imol = 1, SIZE ( molecule ) - + ! dist llconst => molecule(imol) %ll_dist_const DO iconst = 1, molecule(imol) %ndistconst_mol - llconst%scale = 1._dbl + llconst%scale = 1. llconst => llconst%next END DO - + ! 3x3 ll3x3 => molecule(imol) %ll_g3x3_const DO iconst = 1, molecule(imol) %ng3x3const_mol - ll3x3%scale = 1._dbl + ll3x3%scale = 1. ll3x3 => ll3x3%next END DO END DO - + END SUBROUTINE initialize_roll !****************************************************************************** SUBROUTINE update_veps ( molecule, veps, thermo, ensemble, group ) - + IMPLICIT NONE - + ! Arguments REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: veps TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule CHARACTER ( LEN = * ), INTENT ( IN ) :: ensemble INTEGER, INTENT ( IN ) :: group - + ! Locals REAL ( dbl ) :: feps - + !------------------------------------------------------------------------------ - + ! increment pressure pv_const CALL pv_constraint ( molecule, thermo, 'DEL', group ) IF ( ensemble == 'NPT_I' ) THEN @@ -1526,29 +1434,29 @@ SUBROUTINE update_veps ( molecule, veps, thermo, ensemble, group ) ELSE IF ( ensemble == 'NPT_F' ) THEN veps ( :, : ) = veps ( :, : ) + scale * thermo % pv_const ( :, : ) END IF - + END SUBROUTINE update_veps !****************************************************************************** SUBROUTINE get_r_shake(r_shake,vector,u) - + IMPLICIT NONE - + ! Arguments REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: r_shake REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: vector REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ), OPTIONAL :: u - + ! Locals INTEGER :: i REAL ( dbl ), DIMENSION (3,3) :: diag - + !------------------------------------------------------------------------------ - - r_shake = 0.0_dbl - diag = 0.0_dbl - + + r_shake = 0.0 + diag = 0.0 + IF ( PRESENT ( u ) ) THEN diag(1,1) = vector(1) diag(2,2) = vector(2) @@ -1559,7 +1467,7 @@ SUBROUTINE get_r_shake(r_shake,vector,u) r_shake(i,i) = vector(i) END DO END IF - + END SUBROUTINE get_r_shake !****************************************************************************** diff --git a/src/convert_units.F b/src/convert_units.c similarity index 96% rename from src/convert_units.F rename to src/convert_units.c index 7e323ce..cdd9c3d 100644 --- a/src/convert_units.F +++ b/src/convert_units.c @@ -1,6 +1,6 @@ !-----------------------------------------------------------------------------! ! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! +! Copyright (C) 2024 CP2K developers group ! !-----------------------------------------------------------------------------! MODULE convert_units @@ -14,22 +14,22 @@ MODULE convert_units USE physcon, ONLY : joule, evolt, boltzmann USE simulation_cell, ONLY : cell_type USE unit, ONLY : unit_convert_type - + IMPLICIT NONE - + PRIVATE PUBLIC :: convert - + CONTAINS - + !-----------------------------------------------------------------------------! ! ! routine to convert input variables from external units to internal units SUBROUTINE convert ( units, simpar, part, pstat, box, potparm, & intra_param, ewald_param ) - + IMPLICIT NONE - + ! Arguments TYPE (unit_convert_type ), INTENT ( IN ) :: units TYPE (simulation_parameters_type ), INTENT ( INOUT ), OPTIONAL :: simpar @@ -39,27 +39,27 @@ SUBROUTINE convert ( units, simpar, part, pstat, box, potparm, & TYPE (ewald_parameters_type ), INTENT ( INOUT ), OPTIONAL :: ewald_param TYPE (potentialparm_type ), INTENT ( INOUT ), OPTIONAL :: potparm ( :, : ) TYPE (particle_prop_type ), INTENT ( INOUT ), OPTIONAL :: pstat ( : ) - + ! Locals - REAL ( dbl ), PARAMETER :: permittivity = 8.854187817E-12_dbl + REAL ( dbl ), PARAMETER :: permittivity = 8.854187817E-12 REAL ( dbl ) :: conv2k INTEGER :: i - + !------------------------------------------------------------------------------ - + ! convert hmat IF ( PRESENT ( box)) box%hmat = box%hmat*units%lconv - + IF ( PRESENT ( simpar)) THEN ! convert time simpar%dt = simpar%dt*units%tconv ! convert temperature simpar%temp_ext = simpar%temp_ext*units%econv -! convert pressure +! convert pressure simpar%p_ext = simpar%p_ext/units%pconv ! convert verlet skin simpar%verlet_skin = simpar%verlet_skin*units%lconv - + ! converting extended system time constants SELECT CASE (simpar%ensemble) CASE ( 'NVT') @@ -72,14 +72,14 @@ SUBROUTINE convert ( units, simpar, part, pstat, box, potparm, & simpar%tau_nhc = simpar%tau_nhc*units%tconv END SELECT END IF - + IF ( PRESENT ( pstat)) THEN ! convert mass DO i = 1, size(pstat) pstat(i) %mass = pstat(i) %mass*units%mconv END DO END IF - + IF ( PRESENT ( part)) THEN ! convert position DO i = 1, size(part) @@ -88,7 +88,7 @@ SUBROUTINE convert ( units, simpar, part, pstat, box, potparm, & part(i) %r(3) = part(i) %r(3)*units%lconv END DO END IF - + IF ( PRESENT ( potparm)) THEN ! convert LJ parameters potparm ( :, : ) %lj%epsilon = potparm ( :, : ) %lj%epsilon*units%econv @@ -124,9 +124,9 @@ SUBROUTINE convert ( units, simpar, part, pstat, box, potparm, & ! tbhop(i,j) %gsp(:) %rt = tbhop(i,j) %gsp(:) %rt*units%lconv ! END DO ! END DO -! -! note: e_cutoff_coul and energy_cutoff do not need to be converted -! because ewald_correction and the initialization of the energy_cutoff +! +! note: e_cutoff_coul and energy_cutoff do not need to be converted +! because ewald_correction and the initialization of the energy_cutoff ! are called later and the cut-off will be computed in the appropriate units ! ! convert electrostatic parameters @@ -134,17 +134,17 @@ SUBROUTINE convert ( units, simpar, part, pstat, box, potparm, & ewald_param % eps0 = permittivity*units%eps0 ewald_param % alpha = ewald_param % alpha/units % lconv END IF - + IF ( PRESENT ( intra_param)) THEN ! converting bond, bends and torsion and constraint parameters intra_param % bond_param ( :, : ) % r0 = intra_param % bond_param ( :, : ) % r0 & *units%lconv intra_param % bond_param ( :, : ) % k = intra_param % bond_param ( :, : ) % k & * units%econv/units%lconv/units%lconv - + intra_param % bend_param(:,:,:) % k & = intra_param % bend_param(:,:,:) % k * units%econv - + DO i = 1, 6 intra_param % torsion_param(:,:,:,:) % parm(i) = & intra_param % torsion_param(:,:,:,:) % parm(i)*units%econv @@ -152,7 +152,7 @@ SUBROUTINE convert ( units, simpar, part, pstat, box, potparm, & intra_param % constraint_distance ( :, : ) & = intra_param % constraint_distance ( :, : ) * units%lconv END IF - + END SUBROUTINE convert !****************************************************************************** diff --git a/src/cp2k.F b/src/cp2k.F deleted file mode 100644 index 3da5b09..0000000 --- a/src/cp2k.F +++ /dev/null @@ -1,69 +0,0 @@ -!-----------------------------------------------------------------------------! -! ! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -! ! -! This program is free software; you can redistribute it and/or modify ! -! it under the terms of the GNU General Public License as published by ! -! the Free Software Foundation; either version 2 of the License, or ! -! (at your option) any later version. ! -! ! -! This program is distributed in the hope that it will be useful, ! -! but WITHOUT ANY WARRANTY; without even the implied warranty of ! -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! -! GNU General Public License for more details. ! -! ! -! You should have received a copy of the GNU General Public License ! -! along with this program; if not, write to the Free Software ! -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ! -! ! -!-----------------------------------------------------------------------------! -! -!! Main Program -!! - performs only basic initialisations -!! - calls major modules - -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 global_types, ONLY : global_environment_type - 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 - - TYPE ( global_environment_type ) :: globenv - -!------------------------------------------------------------------------------ - - CALL start_parallel ( globenv ) - - CALL initialisation ( globenv ) - - CALL read_cp2k_section ( globenv ) - - IF ( globenv % ionode .AND. globenv % print_level > 9 ) & - CALL print_kind_info ( globenv % scr ) - 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() - - ELSE IF ( globenv % program_name == 'TBMD' ) THEN - CALL set_tbmd_global ( globenv ) - CALL tbmd_main() - END IF - - CALL trailer ( globenv ) - - CALL end_parallel() - -END PROGRAM cp2k diff --git a/src/cp2k.cpp b/src/cp2k.cpp new file mode 100644 index 0000000..5d0ae20 --- /dev/null +++ b/src/cp2k.cpp @@ -0,0 +1,65 @@ +/*---------------------------------------------------------------------------*/ +/* */ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/* */ +/* This program is free software; you can redistribute it and/or modify */ +/* it under the terms of the GNU General Public License as published by */ +/* the Free Software Foundation; either version 2 of the License, or */ +/* (at your option) any later version. */ +/* */ +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ +/* */ +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ +/* */ +/*---------------------------------------------------------------------------*/ + +#include "global_types.h" + +// Main Program +// - performs only basic initialisations +// - calls major modules + +using namespace CP2K_NS; + +class cp2k_input; +class environment; +class fist; +class fist_global; +class parallel; +class physcon; +class tbmd; +class tbmd_global; + + + +int cp2k(int argc, char **argv) { + + global_environment_type globenv; + + start_parallel(globenv); + + initialisation(globenv); + + read_cp2k_section(globenv); + + if (globenv.ionode && globenv.print_level > 9) print_kind_info(globenv.scr); + if (globenv.ionode && globenv.print_level > 4) print_physcon(globenv.scr); + + if (globenv.program_name == "FIST") { + set_fist_global(globenv); + fist_main(); + } else if (globenv.program_name == "TBMD") { + set_tbmd_global(globenv); + tbmd_main(); + } + + trailer(globenv); + + end_parallel(); +} \ No newline at end of file diff --git a/src/cp2k.h b/src/cp2k.h new file mode 100644 index 0000000..6824c3a --- /dev/null +++ b/src/cp2k.h @@ -0,0 +1,14 @@ +#ifndef _LAMMPS_H +#define _LAMMPS_H + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + +int cp2k(int, char **); + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/cp2k_input.F b/src/cp2k_input.F deleted file mode 100644 index ddb3f63..0000000 --- a/src/cp2k_input.F +++ /dev/null @@ -1,114 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE cp2k_input - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE mp, ONLY : mp_bcast - USE parser, ONLY : parser_init, parser_end, read_line, test_next, & - cfield, p_error, get_real, get_int - USE stop_program, ONLY : stop_prg - USE string_utilities, ONLY : uppercase - - PRIVATE - PUBLIC :: read_cp2k_section - -CONTAINS - -!!>---------------------------------------------------------------------------! -!! ! -!! SECTION: &cp2k ... &end ! -!! ! -!! program prg_name ! -!! project name ! -!! iolevel n ! -!! ! -!!<---------------------------------------------------------------------------! - -SUBROUTINE read_cp2k_section ( globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv - -! Locals - INTEGER :: ierror, ilen, iw, source, allgrp - CHARACTER ( LEN = 6 ) :: string - CHARACTER ( LEN = 5 ) :: label - -! ..defaults - globenv%program_name = 'NONE' - globenv%project_name = 'project' - globenv%print_level = 0 - - iw = globenv % scr -! ..parse the input section - label = '&CP2K' - ierror = 0 - CALL parser_init(globenv%input_file_name,label,ierror,globenv) - IF (ierror /= 0) THEN - - IF (globenv % ionode) & - WRITE ( iw, '( a )' ) ' No input section &CP2K found ' - - ELSE - - CALL read_line() - DO WHILE ( test_next() /= 'X' ) - ilen = 6 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - - SELECT CASE (string) - CASE DEFAULT - CALL p_error() - CALL stop_prg( 'input_cntl','unknown option') - - CASE ( 'PROGRA' ) - ilen = 0 - CALL cfield ( globenv % program_name, ilen ) - CALL uppercase ( globenv % program_name ) - - CASE ( 'PROJEC' ) - ilen = 0 - CALL cfield ( globenv % project_name, ilen ) - - CASE ( 'IOLEVE') - globenv%print_level = get_int() - END SELECT - - CALL read_line() - END DO - - END IF - CALL parser_end -! ..end of parsing the input section - - IF ( globenv % program_name == 'QUICKSTEP' ) globenv % program_name = 'QS' - - IF ( globenv % ionode ) THEN -! ..write some information to output - WRITE ( iw, '( A, T41, A )' ) ' CP2K| Program name ', & - ADJUSTR ( globenv % program_name ( 1:40 ) ) - WRITE ( iw, '( A, T41, A )' ) ' CP2K| Input file name ', & - ADJUSTR ( globenv % input_file_name ( 1:40 ) ) - WRITE ( iw, '( A, T41, A )' ) ' CP2K| Project name ', & - ADJUSTR ( globenv % project_name ( 1:40 ) ) - WRITE ( iw, '( A, T77, I4 )' ) ' CP2K| Global print level ', & - globenv % print_level - WRITE ( iw, '( A, T75, I6 )' ) ' CP2K| Total number of processors ', & - globenv % num_pe - WRITE ( iw, '( A, T75, I6 )' ) ' CP2K| This output from processor ', & - globenv % mepos - WRITE (iw,*) - END IF - -END SUBROUTINE read_cp2k_section - -!****************************************************************************** - -END MODULE cp2k_input diff --git a/src/cp2k_input.cpp b/src/cp2k_input.cpp new file mode 100644 index 0000000..26ba387 --- /dev/null +++ b/src/cp2k_input.cpp @@ -0,0 +1,89 @@ +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ + +#include +#include +#include + +#include "global_types.h" + +using namespace CP2K_NS; + +void read_cp2k_section(global_environment_type *globenv) { + + // Locals + int ierror, ilen, iw, source, allgrp; + std::string string; + std::string label; + + // defaults + globenv->program_name = "None"; + globenv->project_name = "project"; + globenv->print_level = 0; + + iw = globenv->scr; + // parse the input section + label = "&CP2K"; + ierror = 0; + parser_init(globenv->input_file_name, label, &ierror, globenv); + if (ierror != 0 ) { + if (globenv->ionode) std::cout << " No input section &CP2K found " << std::endl; + } else { + read_line() + while (test_next() != "X") { + ilen = 6; + cfield(string, ilen); + string.upper() + + switch (string) { + case "PROGRA": + ilen = 0 + cfield(globenv->program_name, ilen); + globenv->program_name.upper(); + break; + case "PROJEC": + ilen = 0 + cfield(globenv->project_name, ilen); + break; + case "IOLEVE": + globenv->print_level = get_int(); + break; + default: + p_error(); + stop_prg("input_cntl", "unknown option"); + } + + read_line(); + } + } + + parser_end(); + // end of parsing the input section + + if (globenv->program_name == "QUICKSTEP") globenv->program_name = "QS"; + + if (globenv->ionode) { + // write some information to output + std::cout << std::left << std::setw(40) << " CP2K| Program name "; + std::cout << std::right << std::setw(40) << globenv->program_name << std::endl; + + std::cout << std::left << std::setw(40) << " CP2K| Input file name "; + std::cout << std::right << std::setw(40) << globenv->input_file_name << std::endl; + + std::cout << std::left << std::setw(40) << " CP2K| Project name "; + std::cout << std::right << std::setw(40) << globenv->project_name << std::endl; + + std::cout << std::left << std::setw(76) << " CP2K| Global print level "; + std::cout << globenv->print_level << std::endl; + + std::cout << std::left << std::setw(74) << " CP2K| Total number of processors "; + std::cout << globenv->num_pe << std::endl; + + std::cout << std::left << std::setw(74) << " CP2K| This output from processor "; + std::cout << globenv->mepos << "\n" << std::endl; + + } + +} \ No newline at end of file diff --git a/src/dg.h b/src/dg.h new file mode 100644 index 0000000..24d7113 --- /dev/null +++ b/src/dg.h @@ -0,0 +1,30 @@ +#ifndef _DG_H +#define _DG_H + +#include "coefficients.h" +#include "particle.h" + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + + typedef struct dg_rho0_type { + char type[13]; + int grid; + double *gcc; + double *zet; + coeff_type density; + } dg_rho0_type; + + typedef struct dg_type { + int grid_index; + int nparts; + dg_rho0_type dg_rho0; + particle_list_type *plist; + } dg_type; + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/dg_rho0s.F b/src/dg_rho0s.c similarity index 100% rename from src/dg_rho0s.F rename to src/dg_rho0s.c diff --git a/src/dg_types.F b/src/dg_types.c similarity index 100% rename from src/dg_types.F rename to src/dg_types.c diff --git a/src/dgs.F b/src/dgs.c similarity index 100% rename from src/dgs.F rename to src/dgs.c diff --git a/src/dump.F b/src/dump.c similarity index 100% rename from src/dump.F rename to src/dump.c diff --git a/src/eigenvalueproblems.F b/src/eigenvalueproblems.c similarity index 100% rename from src/eigenvalueproblems.F rename to src/eigenvalueproblems.c diff --git a/src/environment.F b/src/environment.F deleted file mode 100644 index 2019d94..0000000 --- a/src/environment.F +++ /dev/null @@ -1,176 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE environment - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE machine, ONLY : m_hostnm, m_getcwd, m_getlog, & - m_getuid, m_getpid, m_getarg - USE mathconstants, ONLY : zero - USE physcon, ONLY : init_physcon - USE stop_program, ONLY : set_stop, stop_prg - USE timesl, ONLY : walltime, cputime, datum - USE timings, ONLY : timeprint, timeset, timestop - USE util, ONLY : ran2 - - IMPLICIT NONE - - PRIVATE - PUBLIC :: initialisation, trailer - - CHARACTER ( LEN = 32 ) :: hname = ' ' !! name of the computer - CHARACTER ( LEN = 60 ) :: curdir = ' ' !! current directory name - CHARACTER ( LEN = 10 ) :: user = ' ' !! user name - INTEGER :: my_pid = 0 !! process ID - INTEGER :: my_uid = 0 !! user ID - INTEGER :: handle - -CONTAINS - -!****************************************************************************** - -SUBROUTINE initialisation ( globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv ! check intent - -! Locals - CHARACTER ( LEN = 26 ) :: datx - INTEGER :: iw, l, initial_random - -!------------------------------------------------------------------------------ - - globenv % scr = 6 - - CALL set_stop ( globenv % scr ) - - IF ( globenv % ionode ) THEN - iw = globenv % scr - - CALL set_environment ( globenv ) - - CALL datum ( datx ) - - WRITE ( iw, & - '( A, T55, A26, /, A, T49, A32, /, A, T71, A10, /, A, T71, I10 )' ) & - ' **** **** ****** ** PROGRAM STARTED AT ', ADJUSTR ( datx ), & - ' ***** ** *** *** ** PROGRAM STARTED ON ', ADJUSTR ( hname ), & - ' ** **** ****** PROGRAM STARTED BY ', ADJUSTR ( user ), & - ' ***** ** ** ** ** PROGRAM PROCESS ID ', my_pid - - l = LEN_TRIM ( curdir ) - IF ( l <= 38 ) THEN - WRITE ( iw, '( A, T43, A38 )' ) & - ' **** ** ******* ** PROGRAM STARTED IN ', & - ADJUSTR ( curdir ( 1 : l ) ) - ELSE - WRITE ( iw, '( A )' ) & - ' **** ** ******* ** PROGRAM STARTED IN ' - WRITE ( iw, '( T21, A60 )' ) ADJUSTR ( curdir ) - END IF - - WRITE ( iw, '( )' ) - END IF - -! initialize timing - CALL timeset ( 'CP2K', 'I', ' ', handle ) - -! initialize random number generator - globenv % idum = -1 - initial_random = ran2 ( globenv % idum ) - -! initialize physical constants - CALL init_physcon() - -END SUBROUTINE initialisation - -!****************************************************************************** - -SUBROUTINE trailer ( globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv ! check intent - -! Locals - CHARACTER ( LEN = 26 ) :: datx - INTEGER :: iw, l - -!------------------------------------------------------------------------------ - - CALL timestop ( zero, handle ) - - IF ( globenv % ionode ) THEN - iw = globenv % scr - - CALL timeprint ( iw, globenv % print_level ) - - WRITE ( iw, '( )' ) - - CALL datum ( datx ) - WRITE ( iw, & - '( A, T55, A26, /, A, T49, A32, /, A, T71, A10, /, A, T71, I10 )' ) & - ' **** **** ****** ** PROGRAM ENDED AT ', ADJUSTR ( datx ), & - ' ***** ** *** *** ** PROGRAM RAN ON ', ADJUSTR ( hname ), & - ' ** **** ****** PROGRAM RAN BY ', ADJUSTR ( user ), & - ' ***** ** ** ** ** PROGRAM PROCESS ID ', my_pid - - l = LEN_TRIM ( curdir ) - IF ( l <= 38 ) THEN - WRITE ( iw, '( A, T43, A38 )' ) & - ' **** ** ******* ** PROGRAM RAN IN ', & - ADJUSTR ( curdir ( 1 : l ) ) - ELSE - WRITE ( iw, '( A )' ) & - ' **** ** ******* ** PROGRAM RAN IN ' - WRITE ( iw, '( T21, A60 )' ) ADJUSTR ( curdir ) - END IF - END IF - -END SUBROUTINE trailer - -!****************************************************************************** - -SUBROUTINE set_environment ( globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv - -! Locals - INTEGER :: narg - - INTEGER :: iargc - -!------------------------------------------------------------------------------ - - CALL m_hostnm ( hname ) - CALL m_getcwd ( curdir ) - CALL m_getlog ( user ) - CALL m_getuid ( my_uid ) - CALL m_getpid ( my_pid ) - - narg = iargc() - - SELECT CASE ( narg ) - CASE ( 0 ) - globenv % input_file_name = 'input' - CASE ( 1 ) - CALL m_getarg ( 1, globenv % input_file_name ) - CASE DEFAULT - CALL stop_prg ( 'set_environment', & - 'illegal number of command line arguments passed' ) - END SELECT - -END SUBROUTINE set_environment - -!****************************************************************************** - -END MODULE environment diff --git a/src/environment.cpp b/src/environment.cpp new file mode 100644 index 0000000..dce720e --- /dev/null +++ b/src/environment.cpp @@ -0,0 +1,120 @@ +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ + +#include "global_types.h" + +#ifdef __cplusplus +#include +#include +using namespace CP2K_NS; +#endif + +void initialisation(global_environment_type *globenv) { + + std::string datx; + int iw, l, initial_random; + + //----------------------------------------------------------------------------- + + globenv->scr = 6; + + set_stop(globenv.scr); + + if (globenv->ionode) { + iw = globenv.scr; + + set_environment(globenv); + + datum(datx); + + std::cout << std::left << std::setw(54) << " **** **** ****** ** PROGRAM STARTED AT "; + std::cout << std::right << std::setw(26) << datx << std::endl; + + std::cout << std::left << std::setw(48) << " ***** ** *** *** ** PROGRAM STARTED ON "; + std::cout << std::right << std::setw(32) << hname << std::endl; + + std::cout << std::left << std::setw(70) << " ** **** ****** PROGRAM STARTED BY "; + std::cout << std::right << std::setw(10) << user << std::endl; + + std::cout << std::left << std::setw(70) << " ***** ** ** ** ** PROGRAM PROCESS ID "; + std::cout << std::right << std::setw(10) << my_pid << std::endl; + + std::cout << std::left << std::setw(42) << " **** ** ******* ** PROGRAM STARTED IN "; + std::cout << std::right << std::setw(38) << curdir << "\n" << std::endl; + + } + + // initialize timing + timeset("CP2K", "I", " ", handle); + + // initialize random number generator + globenv.idum = -1; + initial_random = ran2(globenv.idum); + + init_physcon(); +} + +void trailer(global_environment_type *globenv) { + + std::string datx; + int iw, l; + + timestop(zero, handle); + + if (globenv.ionode) { + iw = globenv.scr; + + timeprint(iw, globenv.print_level); + + std::cout << "\n" << std::endl; + + datum(datx); + + std::cout << std::left << std::setw(54) << " **** **** ****** ** PROGRAM ENDED AT "; + std::cout << std::right << std::setw(26) << datx << std::endl; + + std::cout << std::left << std::setw(48) << " ***** ** *** *** ** PROGRAM RAN ON "; + std::cout << std::right << std::setw(32) << hname << std::endl; + + std::cout << std::left << std::setw(70) << " ** **** ****** PROGRAM RAN BY "; + std::cout << std::right << std::setw(10) << user << std::endl; + + std::cout << std::left << std::setw(70) << " ***** ** ** ** ** PROGRAM PROCESS ID "; + std::cout << std::right << std::setw(10) << my_pid << std::endl; + + std::cout << std::left << std::setw(70) << " **** ** ******* ** PROGRAM RAN IN "; + std::cout << std::right << std::setw(10) << curdir << std::endl; + } + +} + +/*****************************************************************************/ + +void set_environment(global_environment_type *globenv) { + + // Locals + int narg, iargc; + + //----------------------------------------------------------------------------- + + m_hostnm(hname); + m_getcwd(curdir); + m_getlog(user); + m_getuid(my_uid); + m_getpid(my_pid); + + narg = iargc(); + + switch (narg) { + case 0: + globenv.input_file_name = "input"; + break; + case 1: + m_getarg(1, globenv.input_file_name); + break; + default: + stop_prg("set_environment", "illegal number of command line arguments passed") + } +} \ No newline at end of file diff --git a/src/erf.F b/src/erf.c similarity index 100% rename from src/erf.F rename to src/erf.c diff --git a/src/erf_fn.F b/src/erf_fn.c similarity index 100% rename from src/erf_fn.F rename to src/erf_fn.c diff --git a/src/ewald.h b/src/ewald.h new file mode 100644 index 0000000..323510e --- /dev/null +++ b/src/ewald.h @@ -0,0 +1,23 @@ +#ifndef _EWALD_H +#define _EWALD_H + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + + typedef struct ewald_parameters_type { + char ewald_type[13]; + double alpha; + double eps0; + double epsilon; + int gmax; + int ns_max; + int gtot; + int ewald_grp; + } ewald_parameters_type; + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/ewald_parameters_types.F b/src/ewald_parameters_types.c similarity index 100% rename from src/ewald_parameters_types.F rename to src/ewald_parameters_types.c diff --git a/src/ewalds.F b/src/ewalds.F deleted file mode 100644 index 9d3d30a..0000000 --- a/src/ewalds.F +++ /dev/null @@ -1,428 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE ewalds - - USE coefficient_types, ONLY : coeff_type - USE dgs, ONLY : dg_grid_setup - USE dg_types, ONLY : dg_type - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE kinds, ONLY : dbl - USE mathconstants, ONLY : pi, zero - USE md, ONLY : thermodynamic_type - USE molecule_types, ONLY : particle_node_type - USE mp, ONLY : mp_sum - USE particle_types, ONLY : particle_type - USE pme, ONLY : pme_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_prg, stop_memory - USE structure_factor_types, ONLY : structure_factor_type - USE structure_factors, ONLY : structure_factor_evaluate, & - structure_factor_allocate, & - structure_factor_deallocate - USE timings, ONLY : timeset, timestop - USE util, ONLY : matvec_3x3 - - IMPLICIT NONE - - PRIVATE - PUBLIC :: ewald_gaussian, ewald_correction, ewald_self - PUBLIC :: ewald_print, ewald_initialize - - INTEGER :: ewald_grp - -CONTAINS - -!****************************************************************************** - -#if defined ( __PGI ) -#define mp mpp -#endif - -!****************************************************************************** - -SUBROUTINE ewald_gaussian (dg, ewald_param, fg_coulomb, vg_coulomb, & - pv_g, pnode, box ) - -! computes the potential and the force from the g-space part of -! the 1/r potential -! Ref.: J.-P. Hansen, Enrico Fermi School, 1985 -! Note: Only the positive G-vectors are used in the sum. - - IMPLICIT NONE - -! Arguments - TYPE ( dg_type ), INTENT ( IN ), TARGET :: dg - TYPE ( cell_type ), INTENT ( IN ) :: box - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - TYPE ( particle_node_type ), INTENT ( IN ), DIMENSION ( : ) :: pnode - REAL ( dbl ), INTENT ( OUT ) :: vg_coulomb - REAL ( dbl ), INTENT ( OUT ), DIMENSION ( :, : ) :: fg_coulomb - REAL ( dbl ), INTENT ( OUT ), DIMENSION ( :, : ) :: pv_g - -! Locals - INTEGER :: node, gpt, nnodes, handle, isos, gptl, gptm, gptn - INTEGER :: lp, mp, np - INTEGER, DIMENSION ( :, : ), POINTER :: bds - REAL ( dbl ) :: gdotr, gsq, four_alpha_sq, common, pref - REAL ( dbl ) :: denom, charge, e_igdotr, flops - REAL ( dbl ) :: gauss - REAL ( dbl ), DIMENSION ( 3 ) :: vec - REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho0 - COMPLEX ( dbl ), DIMENSION ( : ), ALLOCATABLE :: summe - TYPE ( coeff_type ), POINTER :: dg_rho0 - TYPE ( pw_grid_type ), POINTER :: pw_grid - TYPE ( structure_factor_type ) :: exp_igr - -!------------------------------------------------------------------------------ - - CALL timeset ( 'EWALD', 'E', 'Mflops', handle ) - flops = 0.0_dbl - -! pointing - dg_rho0 => dg % dg_rho0 % density - rho0 => dg % dg_rho0 % density % pw % cr3d - pw_grid => dg % dg_rho0 % density % pw % pw_grid - bds => dg % dg_rho0 % density % pw % pw_grid % bounds - -! allocating - nnodes = SIZE ( pnode ) - - CALL structure_factor_allocate ( pw_grid % bounds, nnodes, exp_igr) - - ALLOCATE ( summe ( 1:pw_grid % ngpts_cut ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'ewald', 'summe', 0 ) - -! Initializing vg_coulomb and fg_coulomb - vg_coulomb = 0.0_dbl - fg_coulomb = 0.0_dbl - pv_g = 0.0_dbl -! defining four_alpha_sq - four_alpha_sq = 4.0_dbl * ewald_param % alpha ** 2 - - DO node = 1, nnodes - - vec = matvec_3x3 ( box % h_inv, pnode ( node ) % p % r ) - - CALL structure_factor_evaluate ( vec, pw_grid % npts, exp_igr % lb, & - exp_igr % ex(:,node), exp_igr % ey(:,node), exp_igr % ez(:,node) ) - - END DO - - summe ( : ) = CMPLX ( 0.0_dbl, 0.0_dbl ) -! looping over the positive g-vectors - DO gpt = 1, pw_grid % ngpts_cut - - lp = pw_grid % mapl % pos ( pw_grid % g_hat ( 1, gpt ) ) - mp = pw_grid % mapm % pos ( pw_grid % g_hat ( 2, gpt ) ) - np = pw_grid % mapn % pos ( pw_grid % g_hat ( 3, gpt ) ) - - lp = lp + bds ( 1, 1 ) - mp = mp + bds ( 1, 2 ) - np = np + bds ( 1, 3 ) - -! initializing sum to be used in the energy and force - DO node = 1, nnodes - charge = pnode ( node ) % p % prop % charge - summe ( gpt ) = summe ( gpt ) + charge * & - ( exp_igr % ex ( lp, node ) & - * exp_igr % ey ( mp, node ) & - * exp_igr % ez ( np, node ) ) - END DO - END DO - flops = flops & - + pw_grid % ngpts_cut * 10.0_dbl & - + pw_grid % ngpts_cut * nnodes * 20.0_dbl - -#if defined(__parallel) - CALL mp_sum ( summe, ewald_grp ) -#endif - -! looping over the positive g-vectors - DO gpt = 1, pw_grid % ngpts_cut -! computing the potential energy - lp = pw_grid % mapl % pos ( pw_grid % g_hat ( 1, gpt ) ) - mp = pw_grid % mapm % pos ( pw_grid % g_hat ( 2, gpt ) ) - np = pw_grid % mapn % pos ( pw_grid % g_hat ( 3, gpt ) ) - - lp = lp + bds ( 1, 1 ) - mp = mp + bds ( 1, 2 ) - np = np + bds ( 1, 3 ) - - IF ( pw_grid % gsq ( gpt ) <= 1.0E-10_dbl ) CYCLE - - gauss = ( rho0 ( lp, mp, np ) * pw_grid % vol ) ** 2 & - / pw_grid % gsq ( gpt ) - common = gauss * REAL ( summe ( gpt ) * CONJG ( summe ( gpt ) ) ) - vg_coulomb = vg_coulomb + common - -! computing the force - DO node = 1, nnodes - e_igdotr = AIMAG ( summe(gpt) * CONJG & - ( exp_igr % ex ( lp, node ) & - * exp_igr % ey ( mp, node ) & - * exp_igr % ez ( np, node ) ) ) - charge = pnode ( node ) % p % prop % charge * gauss * e_igdotr - fg_coulomb ( :, node ) = fg_coulomb ( :, node ) & - + charge * pw_grid % g ( :, gpt ) - END DO - -! compute the virial P*V - - denom = 1.0_dbl / four_alpha_sq + 1.0_dbl / pw_grid % gsq ( gpt ) - pv_g(1,1) = pv_g(1,1) + common * ( 1.0_dbl & - - 2.0_dbl * pw_grid % g ( 1, gpt ) * pw_grid % g ( 1, gpt ) * denom ) - pv_g(1,2) = pv_g(1,2) - common * & - ( 2.0_dbl * pw_grid % g ( 1, gpt ) * pw_grid % g ( 2, gpt ) * denom ) - pv_g(1,3) = pv_g(1,3) - common * & - ( 2.0_dbl * pw_grid % g ( 1, gpt ) * pw_grid % g ( 3, gpt ) * denom ) - pv_g(2,1) = pv_g(2,1) - common * & - ( 2.0_dbl * pw_grid % g ( 2, gpt ) * pw_grid % g ( 1, gpt ) * denom ) - pv_g(2,2) = pv_g(2,2) + common * ( 1.0_dbl & - - 2.0_dbl * pw_grid % g ( 2, gpt ) * pw_grid % g ( 2, gpt ) * denom ) - pv_g(2,3) = pv_g(2,3) - common * & - ( 2.0_dbl * pw_grid % g ( 2, gpt ) * pw_grid % g ( 3, gpt ) * denom ) - pv_g(3,1) = pv_g(3,1) - common * & - ( 2.0_dbl * pw_grid % g ( 3, gpt ) * pw_grid % g ( 1, gpt ) * denom) - pv_g(3,2) = pv_g(3,2) - common * & - ( 2.0_dbl * pw_grid % g ( 3, gpt ) * pw_grid % g ( 2, gpt ) * denom ) - pv_g(3,3) = pv_g(3,3) + common * ( 1.0_dbl & - - 2.0_dbl * pw_grid % g ( 3, gpt ) * pw_grid % g ( 3, gpt ) * denom ) - END DO - - flops = flops + pw_grid % ngpts_cut * 55.0_dbl & - + pw_grid % ngpts_cut * nnodes * 23.0_dbl - - pref = 1.0_dbl / ( ewald_param % eps0 * box % deth ) - vg_coulomb = vg_coulomb * pref - pv_g = pv_g * pref - - pref = 2.0_dbl * pref - fg_coulomb = fg_coulomb * pref - - CALL structure_factor_deallocate ( exp_igr ) - - DEALLOCATE ( summe, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'ewald', 'summe' ) - - flops = flops * 1.0E-6_dbl - CALL timestop ( flops, handle ) - -END SUBROUTINE ewald_gaussian - -!****************************************************************************** - -!! computes the self interaction from g-space and the neutralizing background -SUBROUTINE ewald_self ( ewald_param, thermo, pnode ) - -! Arguments - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - -! Locals - INTEGER :: nnodes, i - REAL ( dbl ) :: q_self, q_sum, q - -!------------------------------------------------------------------------------ - - q_self = 0.0_dbl - q_sum = 0.0_dbl - nnodes = SIZE ( pnode ) - DO i = 1, nnodes - q = pnode ( i ) % p % prop % charge - q_self = q_self + q*q - q_sum = q_sum + q - END DO - -#if defined(__parallel) - CALL mp_sum(q_self,ewald_grp) - CALL mp_sum(q_sum,ewald_grp) -#endif - - IF ( ewald_param % ewald_type == 'EWALD_GAUSS' .OR. & - ewald_param % ewald_type == 'PME_GAUSS' ) THEN - - thermo % e_self = -q_self * ewald_param % alpha & - / ( 4.0_dbl * ewald_param % eps0 * pi * SQRT ( pi ) ) - - thermo % e_neut = -q_sum ** 2 / ( 8.0_dbl * ewald_param % eps0 & - * ewald_param % alpha ** 2 ) - END IF - -END SUBROUTINE ewald_self - -!****************************************************************************** - -!!> computing the shift in the potential energy -!!< for the real space coulomb potential - -FUNCTION ewald_correction ( ewald_param, qi, qj, rcutsq ) & - RESULT ( e_cutoff_coul ) - - IMPLICIT NONE - -! Arguments - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - REAL ( dbl ), INTENT ( IN ) :: qi, qj, rcutsq - REAL ( dbl ) ::e_cutoff_coul - -! Locals - REAL ( dbl ) :: inv_fourpieps0 - REAL ( dbl ), PARAMETER :: ac1 = 0.254829592_dbl, & - ac2 = -0.284496736_dbl, ac3 = 1.421413741_dbl, & - ac4 = -1.453152027_dbl, ac5 = 1.061405429_dbl, pc = 0.3275911_dbl - REAL ( dbl ) :: tc, arg, e_arg_arg, erfcf, erfc_over_rij - -!------------------------------------------------------------------------------ - -! compute the value of the real-space coulomb at the cut-off - inv_fourpieps0 = 1.0_dbl / ( 4.0_dbl * pi * ewald_param % eps0 ) - arg = ewald_param % alpha * SQRT ( rcutsq ) - e_arg_arg = EXP ( - arg ** 2 ) - tc = 1.0_dbl / ( 1.0_dbl + pc * arg ) - erfcf = ((((ac5*tc+ac4)*tc+ac3)*tc+ac2)*tc+ac1)*tc * e_arg_arg - erfc_over_rij = erfcf / SQRT ( rcutsq ) - e_cutoff_coul = inv_fourpieps0 * qi * qj * erfc_over_rij - -END FUNCTION ewald_correction - -!****************************************************************************** - -SUBROUTINE ewald_print ( iw, thermo, box, e_label ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: iw - TYPE ( thermodynamic_type ), INTENT ( IN ) :: thermo - TYPE ( cell_type ), INTENT ( IN ) :: box - CHARACTER ( LEN = * ), INTENT ( IN ) :: e_label - -!------------------------------------------------------------------------------ - - WRITE ( iw, '( A, A )' ) ' *********************************', & - '**********************************************' - WRITE ( iw, '( A, A, T35, A, T66, E15.7 )' ) ' INITIAL GSPACE ENERGY', & - e_label, '= ', thermo%gspace - WRITE ( iw, '( A, A, T35, A, T66, E15.7 )' ) ' SELF ENERGY CORRECTION', & - e_label, '= ', thermo%e_self - WRITE ( iw, '( A, A, T35, A, T66, E15.7 )' ) ' NEUT. BACKGROUND', e_label, & - '= ', thermo%e_neut/box%deth - WRITE ( iw, '( A, A, T35, A, T66, E15.7 )' ) ' BONDED CORRECTION', e_label, & - '= ', thermo%e_bonded - WRITE ( iw, '( A, A )' ) ' *********************************', & - '**********************************************' - -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 ) - - IMPLICIT NONE - -! Arguments - TYPE ( dg_type ), INTENT ( OUT ) :: dg - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - INTEGER, 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 - -! Locals - INTEGER :: natoms, iat, jat, gmax, npts_s ( 3 ), iw - REAL ( dbl ) :: qi, qj, i, cutoff - -!------------------------------------------------------------------------------ - -! 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 - -! writing output to unit iounit - iw = iounit - - natoms = SIZE ( part ) - - 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 - - ELSE - - WRITE ( iw, '( A )' ) ' No Ewald summation is performed' - - END IF - -! fire up the reciprocal space and compute self interaction and -! term from the neutralizing background. - - IF ( ewald_param % ewald_type /= 'NONE' ) THEN - - CALL ewald_self ( ewald_param, thermo, pnode ) - -! set up EWALD_GAUSS - 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" ) - END IF - 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) - - CALL pme_setup (pnode, ewald_grid, ewald_param, dg ) - END IF - -! set up PME_GAUSS - - 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 ) - END IF - - END IF - -END SUBROUTINE ewald_initialize - -!****************************************************************************** - -END MODULE ewalds diff --git a/src/ewalds.c b/src/ewalds.c new file mode 100644 index 0000000..d2be584 --- /dev/null +++ b/src/ewalds.c @@ -0,0 +1,330 @@ +#include +#include +#include +#include + +#include "coefficients.h" +// #include "complex.h" +#include "dg.h" +#include "ewald.h" +#include "md.h" +#include "molecule.h" +#include "pw.h" +#include "simulation.h" +#include "structure.h" +#include "timings.h" +#include "util.h" + +#if defined ( __PGI ) +#define mp mpp +#endif + +int ewald_grp; + +void ewald_gaussian(dg_type dg, ewald_parameters_type ewald_param, double **fg_coulomb, + double vg_coulomb, double **pv_g, particle_node_type pnode[], cell_type box) { + + // + int node, gpt, nnodes, handle, isos, gptl, gptm, gptn, lp, mp, np; + int *bds; + // + double gdotr, gsq, four_alpha_sq, common, pref, denom, charge, e_igdotr; + double flops, gauss; + + size_t i, j; + double vec[3]; + double ***rho0; + double complex *summe; + coeff_type *dg_rho0; + pw_grid_type *pw_grid; + structure_factor_type exp_igr; + + timeset("EWALD", 'E', "Mflops", handle); + flops = 0.0; + + // pointing + dg_rho0 = dg.dg_rho0->density; + rho0 = dg.dg_rho0->density->pw->cr3d; + pw_grid = dg.dg_rho0->density->pw->pw_grid; + bds = dg.dg_rho0.density.pw.pw_grid.bounds; + + // allocating + nnodes = sizeof(pnode); + + structure_factor_allocate(&pw_grid->bounds, nnodes, exp_igr); + summe = malloc(pw_grid->ngpts_cut*sizeof(double complex)); + + vg_coulomb = 0.0; + for (i = 0; i < node; i++) { + fg_coulomg[0][i] = 0.0; + fg_coulomg[1][i] = 0.0; + fg_coulomg[2][i] = 0.0; + } + + for (i = 0; i < 3; i++) { + for (j = 0; j < 3; j++) { + pv_g[i][j] = 0.0; + } + } + + // define four alpha_sq + four_alpha_sq = 4.0 * ewald_param.alpha * ewald_param.alpha; + + for (node = 0; node < nnodes; node++) { + vec = matvec_3x3(box.h_inv, pnode[node].p->r); + + structure_factor_evaluate(vec, pw_grid->npts, exp_igr.lb, + exp_igr.ex, exp_igr.ey, exp_igr.ez); + } + + // looping over the positive g-vectors + for (gpt = 0; gpt < pw_grid->ngpts_cut; gpt++) { + lp = pw_grid->mapl->pos[pw_grid->g_hat[0][gpt]]; + mp = pw_grid->mapm->pos[pw_grid->g_hat[1][gpt]]; + np = pw_grid->mapn->pos[pw_grid->g_hat[2][gpt]]; + + lp += bds[0][0]; + mp += bds[0][1]; + np += bds[0][2]; + + for (node = 0; node < nnodes; node++) { + charge = pnode[node]->p->prop->charge; + summe[gpt] += charge * + ( exp_igr.ex[lp][node] + * exp_igr.ey[mp][node] + * exp_igr.ez[np][node] ); + } + } + + flops += pw_grid->ngpts_cut * 10.0 + pw_grid->ngpts_cut * nnodes * 20.0; + #if defined (__parallel) + mp_sum(summe, ewald_grp); + #endif + + // looping over the positive g-vectors + for (gpt = 0; gpt < pw_grid -> ngpts_cut; gpt++) { + // compute the potential energy + lp = pw_grid->mapl->pos[pw_grid->g_hat[0][gpt]]; + mp = pw_grid->mapm->pos[pw_grid->g_hat[1][gpt]]; + np = pw_grid->mapn->pos[pw_grid->g_hat[2][gpt]]; + + lp += bds[0][0]; + mp += bds[0][1]; + np += bds[0][2]; + + if (pw_grid->gsq[gpt] < 1.0E-10) break; + + double tmp = rho0[lp][mp][np] * pw_grid->vol; + + gauss = tmp * tmp / pw_grid->gsq[gpt]; + common = gauss * (double)(summe[gpt] * conj(summe[gpt])); + vg_coulomb += common; + + // computing the forces + for (node = 0; node < nnodes; node++) { + e_igdotr = cimag(summe[gpt] * conj + ( exp_igr.ex[lp][node] + * exp_igr.ey[mp][node] + * exp_igr.ez[np][node])); + charge = pnode[node].p->prop->charge * gauss * e_igdotr; + fg_coulomb[0][node] += charge * pw_grid->g[0][gpt]; + fg_coulomb[1][node] += charge * pw_grid->g[1][gpt]; + fg_coulomb[2][node] += charge * pw_grid->g[2][gpt]; + } + + // computing the virial P*V + + denom = 1.0 / four_alpha_sq + 1.0 / pw_grid->gsq[gpt]; + pv_g[0][0] += common * (1.0 - 2.0 * pw_grid->g[0][gpt] * pw_grid->g[0][gpt] * denom); + + pv_g[0][1] -= common * (2.0 * pw_grid->g[0][gpt] * pw_grid->g[1][gpt] * denom); + + pv_g[0][2] -= common * (2.0 * pw_grid->g[0][gpt] * pw_grid->g[2][gpt] * denom); + + pv_g[1][0] -= common * (2.0 * pw_grid->g[1][gpt] * pw_grid->g[0][gpt] * denom); + + pv_g[1][1] += common * (1.0 - 2.0 * pw_grid->g[1][gpt] * pw_grid->g[1][gpt] * denom); + + pv_g[1][2] -= common * (2.0 * pw_grid->g[1][gpt] * pw_grid->g[2][gpt] * denom); + + pv_g[2][0] -= common * (2.0 * pw_grid->g[2][gpt] * pw_grid->g[0][gpt] * denom); + + pv_g[2][1] -= common * (2.0 * pw_grid->g[2][gpt] * pw_grid->g[1][gpt] * denom); + + pv_g[2][2] += common * (1.0 - 2.0 * pw_grid->g[2][gpt] * pw_grid->g[2][gpt] * denom); + } + + flops += pw_grid->ngpts_cut * 55.0 + pw_grid->ngpts_cut * nnodes * 23.0; + + pref = 1.0 / (ewald_param.eps0 * box.deth); + vg_coulomb *= pref; + + for (i = 0; i < 3; i++) { + for (j = 0; j < 3; j++) { + pv_g[i][j] *= pref; + } + } + + pref *= 2.0; + + for (j = 0; j < 3; j++) { + for (i = 0; i < nnodes; i++) { + fg_coulomb[j][i] *= pref; + } + } + + for (size_t i = 0; i < nnodes; i++) { + fg_coulomb[0][i] *= pref; + fg_coulomb[1][i] *= pref; + fg_coulomb[2][i] *= pref; + } + + structure_factor_deallocate(exp_igr); + + free(summe); + + flops *= 1.0E-6; + timestop(flops, handle); + +} + +void ewald_self(ewald_parameters_type ewald_param, thermodynamic_type *thermo, partilce_node_type pnode[], int nnodes) { + + size_t i; + double q_self, q_sum, q; + + q_self = 0.0; + q_sum = 0.0; + + for (i = 0; i < nnodes; i++) { + q = pnode[i].p->prop->charge; + q_self += q * q; + q_sum += q; + } + + #if defined (__parallel) + mp_sum(q_self, ewald_grp); + mp_sum(q_sum, ewald_grp); + #endif + + if (strncmp(ewald_param.ewald_type, "EWALD_GAUSS", 20) || + strncmp(ewald_param.ewald_type, "PME_GAUSS", 20)) { + + thermo->e_self = -q_self * ewald_param.alpha + / (4.0 * ewald_param.eps0 * sqrt(M_PI) * M_PI); + + thermo->e_neut = -q_sum * q_sum / (8.0 * ewald_param.eps0 + * ewald_param.alpha * ewald_param.alpha); + } + +} + +double ewald_correction(ewald_parameters_type ewald_param, double qi, double qj, double rcutsq) { + + double e_cutoff_coul, inv_fourpiesp0; + double tc, arg, e_arg_arg, erfcf, erfc_over_rij; + + double ac1 = 0.254829592; + double ac2 = -0.284496736; + double ac3 = 1.421413741; + double ac4 = -1.453152027; + double ac5 = 1.061405429; + double pc = 0.3275911; + + // compute the value of the real-space coulomb at the cut-off + inv_fourpiesp0 = 1.0 / (4.0 * M_PI * ewald_param.eps0); + arg = ewald_param.alpha * sqrt(rcutsq); + e_arg_arg = exp(-arg * arg); + tc = 1.0 / (1.0 + pc * arg); + erfcf = ((((ac5 * tc + ac4) * tc + ac3) * tc + ac2) * tc + ac1) * tc * e_arg_arg; + erfc_over_rij = erfcf / sqrt(rcutsq); + e_cutoff_coul = inv_fourpiesp0 * qi * qj * erfc_over_rij; + + return e_cutoff_coul; +} + +void ewald_print(FILE *iw, thermodynamic_type thermo, cell_type box, char *e_label) { + fprintf(iw, "( %s, %s )", " *********************************", + "**********************************************"); + fprintf(iw, "( %s, %s, %35s, %s, %66s, %15.7E )", " INITIAL GSPACE ENERGY", + e_label, "= ", thermo.gspace); + fprintf(iw, "( %s, %s, %35s, %s, %66s, %15.7E )", " SELF ENERGY CORRECTION", + e_label, "= ", thermo.e_self); + fprintf(iw, "( %s, %s, %35s, %s, %66s, %15.7E )", " NEUT. BACKGROUND", e_label, + "= ", thermo.e_neut / box.deth); + fprintf(iw, "( %s, %s, %35s, %s, %66s, %15.7E )", " BONDED CORRECTION", e_label, + "= ", thermo.e_bonded); + fprintf(iw, "( %s, %s )", " *********************************", + "**********************************************"); +} + +void ewald_initialize(dg_type *dg, particle_type *part, particle_node_type *pnode, + int pnode_grp, ewald_parameters_type *ewald_param, cell_type *box, + thermodynamic_type *thermo, int iounit, pw_grid_type *ewald_grid, + pw_grid_type *pme_small_grid, pw_grid_type *pme_big_grid) { + + int natoms, iat, jat, gmax, npts_s[3], iw; + double qi, qj, i, cutoff; + + // 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; + + // writing output to unit iounit + iw = iounit; + + natoms = sizeof(part) / sizeof(part[0]); + + if (strcmp(ewald_param.ewald_type, "NONE") != 0) { + printf("Ewald summation is done by: %s\n", ewald_param.ewald_type); + printf("Ewald alpha parameter [A]: %f\n", ewald_param.alpha); + + if (strncmp(ewald_param.ewald_type, "EWALD", 5) == 0) { + printf("Ewald G-space max. Miller index: %d\n", ewald_param.gmax); + } else if (strncmp(ewald_param.ewald_type, "PME", 3) == 0) { + printf("PME max small-grid points: %d\n", ewald_param.ns_max); + } + } else { + printf("No Ewald summation is performed\n"); + } + + // fire up the reciprocal space and compute self interaction and + // term from the neutralizing background. + if (strcmp(ewald_param.ewald_type, "NONE") != 0) { + ewald_self(ewald_param, thermo, pnode); + // set up EWALD_GAUSS + if (ewald_grid != NULL) { + gmax = ewald_param.gmax; + if (gmax % 2 == 0) { + stop_prg("initialize_ewalds", "gmax has to be odd"); + } + ewald_grid->bounds[0][:] = -gmax / 2; + ewald_grid->bounds[1][:] = +gmax / 2; + npts_s[0] = gmax; + npts_s[1] = gmax; + npts_s[2] = gmax; + ewald_grid->grid_span = HALFSPACE; + + pw_find_cutoff(npts_s, box, cutoff); + + pw_grid_setup(box, ewald_grid, cutoff); + + pme_setup(pnode, ewald_grid, ewald_param, dg); + } + + // set up PME_GAUSS + if (pme_small_grid != NULL and pme_big_grid != NULL) { + npts_s[:] = ewald_param.ns_max; + pme_small_grid->bounds[0][:] = -npts_s[:]/2; + pme_small_grid->bounds[1][:] = (+npts_s[:] - 1) / 2; + pme_small_grid->grid_span = HALFSPACE; + pme_big_grid->grid_span = HALFSPACE; + + dg_grid_setup(box, npts_s, ewald_param.epsilon, ewald_param.alpha, + pme_small_grid, pme_big_grid, ewald_param.ewald_type); + + pme_setup(pnode, pme_small_grid, ewald_param, dg); + + } + +} diff --git a/src/fft_tools.F b/src/fft_tools.c similarity index 100% rename from src/fft_tools.F rename to src/fft_tools.c diff --git a/src/fist.F b/src/fist.F deleted file mode 100644 index 1a0a126..0000000 --- a/src/fist.F +++ /dev/null @@ -1,328 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE fist - - USE atoms_input, ONLY : read_coord_vel, system_type - USE convert_units, ONLY : convert - 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 - USE kinds, ONLY : dbl - USE fist_debug, ONLY : debug_control - USE fist_input, ONLY : read_fist_section - USE fist_global, ONLY : fistpar - 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 - USE molecule_types, ONLY : molecule_type, intra_parameters_type - USE nose, ONLY : extended_parameters_type - USE pair_potential, ONLY : potentialparm_type, & - potential_f, 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 - USE timings, ONLY : timeset, timestop - USE unit, ONLY : unit_convert_type, set_units - USE util, ONLY : close_unit, get_share - - IMPLICIT NONE - - PRIVATE - PUBLIC :: fist_main - - TYPE ( mdio_parameters_type ) :: mdio - -CONTAINS - -!-----------------------------------------------------------------------------! -! FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST ! -!-----------------------------------------------------------------------------! - -SUBROUTINE fist_main - - IMPLICIT NONE - -! Locals - REAL ( dbl ) :: cons, ecut, qi, qj - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rcut - INTEGER :: handle, itimes, isos, para_comm_cart - INTEGER :: iat, jat - CHARACTER ( LEN = ATOMNAMESLENGTH ), DIMENSION ( : ), POINTER :: atom_names - CHARACTER ( LEN = 20 ) :: set_fn - - TYPE ( potentialparm_type ), DIMENSION ( :, : ), POINTER :: potparm - 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 ( 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 - -!------------------------------------------------------------------------------ - - CALL timeset ( 'FIST', 'I', ' ', handle ) - - IF ( fistpar % ionode ) CALL fist_header ( fistpar % scr ) - -!..read fist section - - CALL read_fist_section ( setup, ewald_param, fistpar ) - -! read from the setup and molecule section of *.set - - set_fn = setup % set_file_name - - CALL read_setup_section ( mol_setup, set_fn, fistpar ) - - CALL read_molecule_section ( mol_setup, set_fn, fistpar ) - -! read force_field information for classical MD - - CALL read_force_field_section ( setup, mol_setup, set_fn, & - intra_param, potparm, atom_names, pstat, fistpar ) - -!..read the input of the molecular dynamics section - - CALL read_md_section ( simpar, fistpar, mdio ) - simpar % program = 'FIST' - -!..read atomic coordinates, velocities (optional) and the simulation box - ainp % rtype = simpar % read_type - CALL read_coord_vel ( ainp, setup % input_file_name, fistpar ) - -!..initialize box, perd - struc % box % hmat = ainp % box - struc % box % perd = setup % perd - - CALL get_hinv ( struc % box ) - -!..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 ) - -!..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 = potparm, intra_param = intra_param, & - ewald_param = ewald_param ) - -!..initialize molecule_type - CALL initialize_molecule_type ( mol_setup, intra_param, struc % pnode, & - struc % part, struc % molecule, fistpar ) - -!..initialize extended_parameters_type and get number of degrees of freedom - CALL initialize_extended_type ( struc % box, simpar, & - struc % molecule, mol_setup, nhcp, fistpar ) - -! initialize velocities if needed - IF ( simpar % read_type == 'POS' ) THEN - CALL initialize_velocities ( simpar, struc % part, fistpar ) - END IF - -!...initialize splines - - potparm ( :, : ) % energy_cutoff = 0.0_dbl - potparm ( :, : ) % e_cutoff_coul = 0.0_dbl - CALL spline_nonbond_control ( 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 ( 'fist', 'rcut', 0 ) - - rcut ( :, : ) = potparm ( :, : ) % rcutsq - - CALL set_ll_parm ( fistpar, simpar % verlet_skin, & - setup % natom_type, rcut, simpar % n_cell ) - - CALL set_ll_parm ( fistpar, printlevel = fistpar % print_level, & - ltype = 'NONBOND' ) - - DEALLOCATE ( rcut, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'fist', 'rcut' ) - -!..deallocate arrays needed for atom input - IF ( ASSOCIATED ( ainp % c ) ) THEN - DEALLOCATE ( ainp % c, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'fist', 'ainp%c' ) - END IF - - IF ( ASSOCIATED ( ainp % v ) ) THEN - DEALLOCATE ( ainp % v, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'fist', 'ainp%v' ) - END IF - -!..initialize integrator - CALL set_integrator (fistpar % ionode, fistpar % group, fistpar % scr, mdio ) - - IF ( setup % run_type == 'DEBUG' ) THEN -!..debug the forces - - CALL debug_control( fistpar, ewald_param, struc%part, struc%pnode, & - struc%molecule, struc%box, thermo, potparm, simpar % ensemble ) - - ELSE - -!..MD - itimes = 0 - - CALL force ( struc, potparm, thermo, simpar, ewald_param ) - IF ( fistpar % ionode .AND. ewald_param % ewald_type /= 'NONE' ) & - CALL ewald_print ( fistpar % 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, potparm, thermo, & - struc, ewald_param, nhcp ) - - IF ( MOD ( itimes, mdio % idump ) == 0 ) & - CALL dump_variables ( struc, mdio % dump_file_name, fistpar ) - END DO - - CALL dump_variables ( struc, mdio % dump_file_name, fistpar ) - - IF ( fistpar % ionode ) CALL close_unit ( 10, 99 ) - END IF - -!..deallocate memory for atoms and molecules - CALL deallocmem ( struc ) - - CALL timestop ( zero, handle ) - -END SUBROUTINE fist_main - -!-----------------------------------------------------------------------------! -! FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST ! -!-----------------------------------------------------------------------------! - -SUBROUTINE allocmem ( ainp, mol_setup, struc ) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_type ), DIMENSION ( : ), INTENT ( IN ) :: mol_setup - TYPE ( structure_type ), INTENT ( INOUT ) :: struc - TYPE ( system_type ), INTENT ( IN ) :: ainp - -! Locals - INTEGER :: iw, natoms, nnodes, nmol, nmoltype, ios, iat, i - -!------------------------------------------------------------------------------ - - struc % name = 'FIST MOLECULAR SYSTEM' - IF ( fistpar % num_pe == 1 ) THEN - natoms = SIZE ( ainp % c ( 1, : ) ) - ALLOCATE ( struc % part ( 1:natoms ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'fist', 'part', natoms ) - ALLOCATE ( struc % pnode ( 1:natoms ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'fist', 'pnode', natoms ) - nmol = SUM ( mol_setup ( : ) % num_mol ) - - ALLOCATE ( struc % molecule ( 1:nmol ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'fist', 'molecule', nmol ) - - IF ( fistpar % ionode .AND. fistpar % print_level > 3 ) THEN - iw = fistpar % scr - - WRITE ( iw, '( A )' ) - WRITE ( iw, '( A, T71, I10 )' ) & - ' FIST| Number of allocated particles ', natoms - WRITE ( iw,'( A, T71, I10 )' ) & - ' FIST| Number of allocated particle nodes ', natoms - WRITE ( iw, '( A, T71, I10 )' ) & - ' FIST| 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 ( 'fist', 'part', natoms ) - nmoltype = SIZE ( mol_setup ) - nmol = 0 - nnodes = 0 - DO i = 1, nmoltype - nmol = nmol + get_share ( mol_setup ( i ) % num_mol, & - fistpar % num_pe, fistpar % mepos ) - nnodes = nnodes + nmol * mol_setup ( i ) % molpar % natom - END DO - - ALLOCATE ( struc % molecule ( 1:nmol ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'fist', 'molecule' , nmol ) - ALLOCATE ( struc % pnode ( 1:nnodes ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'fist', 'pnode', nnodes ) - - IF ( fistpar % ionode .AND. fistpar % print_level > 3 ) THEN - iw = fistpar % scr - WRITE ( iw, '( A )' ) - WRITE ( iw, '( A, T71, I10 )' ) & - ' FIST| Number of allocated particles ', natoms - WRITE ( iw, '( A, T71, I10 )' ) & - ' FIST| Number of allocated particle nodes ', nnodes - WRITE ( iw, '( A, I5, T71, I10 )' ) & - ' FIST| Number of allocated molecules on processor ', & - fistpar % 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 ( 'fist', 'part' ) - - DEALLOCATE ( struc % pnode, STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'fist', 'pnode' ) - - DEALLOCATE ( struc % molecule, STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'fist', 'molecule' ) - -END SUBROUTINE deallocmem - -!****************************************************************************** - -END MODULE fist diff --git a/src/fist.cpp b/src/fist.cpp new file mode 100644 index 0000000..8b53ccd --- /dev/null +++ b/src/fist.cpp @@ -0,0 +1,241 @@ +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ + +#include + +#include "atoms_input.h" +#include "convert_units.h" +#include "dump.h" +#include "ewalds.h" +#include "ewald_parameters_types.h" +#include "header.h" +#include "kinds.h" +#include "fist_debug.h" +#include "fist_input.h" +#include "fist_global.h" +#include "force_fields.h" +#include "initialize_extended_types.h" +#include "initialize_molecule_types.h" +#include "initialize_particle_types.h" +#include "integrator.h" +#include "input_types.h" +#include "linklist_control.h" +#include "mathconstants.h" +#include "md.h" +#include "molecule_input.h" +#include "molecule_types.h" +#include "nose.h" +#include "pair_potential.h" +#include "particle_types.h" +#include "simulation_cell.h" +#include "stop_program.h" +#include "structure_types.h" +#include "timings.h" +#include "unit.h" +#include "util.h" + +using namespace CP2K_NS; + +class fist { + +public: + void fist_main(); + +private: + void allocmem(system_type ainp, std::vector mol_setup, structure_type *struc); + void deallocmem(structure_type struc); + +}; + +/*----------------------------------------------------------------------------*/ +/* FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST */ +/*----------------------------------------------------------------------------*/ + +void fist::fist_main() { + + double cons, ecut, qi, qj; + std::vector> rcut; + int handle, itimes, isos, para_comm_cart; + int iat, jat; + std::vector atom_names; + std::string set_fn; + + potentialparm_type potparm; + particle_prop_type pstat; + molecule_type mol_setup; + unit_convert_type units; + simulation_parameters_type simpar; + structure_type struc; + extended_parameters_type nhcp; + thermodynamic_type thermo; + system_type ainp; + ewald_parameters_type ewald_param; + setup_parameters_type setup; + intra_parameters_type intra_param; + + timeset("FIST", "I", " ", handle); + + if (fistpar.ionone) fist_header(fistpar.scr); + + // read fist section + + read_fist_section(setup, ewald_param, fistpar); + + // read from the setup and molecule section of *.set + + set_fn = setup.set_file_name; + + read_setup_section(mol_setup, set_fn, fistpar); + + read_molecule_section(mol_setup, set_fn, fistpar); + + // read force_field information for classical MD + + read_force_field_section(setup, mol_setup, set_fn, + intra_param, potparm, atom_names, pstat, fistpar); + + // read the input of the molecular dynamics section + + read_md_section(simpar, fistpar, mdio); + simpar.program = "FIST"; + + // read atomic coordinates, velocities (optional) and the simulation box + ainp.rtype = simpar.read_type; + atoms_input.read_coord_vel(ainp, setup.input_file_name, fistpar); + + // initialize box, perd + struc.box.hmat = ainp.box; + struc.box.perd = setup.perd; + + get_hinv(struc.box); + + // initialize working units + set_units ( setup.unit_type, units ); + + 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 + allocmem ( ainp, mol_setup, struc ); + + // initialize particle_type + initialize_particle_type ( atom_names, simpar, mol_setup, + ainp, pstat, struc.part ); + + // convert the units + convert ( units = units, simpar = simpar, + part = struc.part, pstat = pstat, box = struc.box, + potparm = potparm, intra_param = intra_param, + ewald_param = ewald_param ); + + // initialize molecule_type + initialize_molecule_type ( mol_setup, intra_param, struc.pnode, + struc.part, struc.molecule, fistpar ); + + // initialize extended_parameters_type and get number of degrees of freedom + initialize_extended_type ( struc.box, simpar, + struc.molecule, mol_setup, nhcp, fistpar ); + + // initialize velocities if needed + if ( simpar.read_type == "POS" ) { + initialize_velocities ( simpar, struc.part, fistpar ); + } + + // initialize splines + + potparm ( :, : ).energy_cutoff = 0.0; + potparm ( :, : ).e_cutoff_coul = 0.0; + spline_nonbond_control ( potparm, pstat, 5000, ewald_param ); + + // set linklist control parameters + allocate ( rcut ( setup.natom_type, setup.natom_type ), STAT = isos ); + if ( isos !=0 ) stop_memory ( "fist", "rcut", 0 ); + + rcut ( :, : ) = potparm ( :, : ).rcutsq; + + set_ll_parm ( fistpar, simpar.verlet_skin, + setup.natom_type, rcut, simpar.n_cell ); + + set_ll_parm ( fistpar, printlevel = fistpar.print_level, + ltype = "NONBOND" ); + + deallocate ( rcut, STAT = isos ); + if ( isos != 0 ) stop_memory ( "fist", "rcut" ); + + // deallocate arrays needed for atom input + if (associated(ainp.c)) { + deallocate(ainp.c, STAT=isos); + if (isos != 0) stop_memory("fist", "ainp.c"); + } + + if (associated(ainp.v)) { + deallocate(ainp.v, STAT=isos); + if (isos != 0) stop_memory("fist", "ainp.v"); + } + + // initialize integrator + set_integrator(fistpar.ionode, fistpar.group, fistpar.scr, mdio); + + if (setup.run_type == "DEBUG") { + // debug the forces + debug_control( fistpar, ewald_param, struc.part, struc.pnode, + struc.molecule, struc.box, thermo, potparm, simpar.ensemble ); + } else { + // MD + itimes = 0; + force(struc, potparm, thermo, simpar, ewald_param); + if (fistpar.ionode && ewald_param.ewald_type != "None") { + ewald_print(fistpar.scr, thermo, struc.box, units.e_label); + } + energy(itimes, cons, simpar, struc, thermo, nhcp); + + for (itimes = 0; itimes < simpar.nsteps; itimes++) { + velocity_verlet(itimes, cons, simpar, potparm, thermo, + struc, ewald_param, nhcp); + if (itimes % mdio.idump == 0) dump_variables(struc, mdio.dump_file_name, fistpar); + } + + dump_variables(struc, mdio.dump_file_name, fistpar); + + if (fistpar.ionode) close_unit(10,99); + } + + // deallocate memory for atoms and molecules + deallocmem(struc); + + timestop(zero, handle); +} + +fist::~fist() { + deallocmem(struc); +} + +/*----------------------------------------------------------------------------*/ +/* FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST */ +/*----------------------------------------------------------------------------*/ + +void fist::allocmem(system_type ainp, std::vector mol_setup, structure_type *struc) { + + // Locals + int iw, natoms, nnodes, nmol, nmoltype, ios, iat, i; + + //----------------------------------------------------------------------------- + + struc.name = "FIST MOLECULAR SYSTEM" + if (fistpar.num_pe == 1) { + natoms = ainp.c.length(); + allocate(struc.part, STAT = ios); + + } +} + +void fist::deallocmem(structure_type *struc) { + + free(struc->part); + free(struc->pnode); + free(struc->molecule); + +} diff --git a/src/fist_debug.F b/src/fist_debug.c similarity index 100% rename from src/fist_debug.F rename to src/fist_debug.c diff --git a/src/fist_force.F b/src/fist_force.c similarity index 100% rename from src/fist_force.F rename to src/fist_force.c diff --git a/src/fist_force_numer.F b/src/fist_force_numer.c similarity index 100% rename from src/fist_force_numer.F rename to src/fist_force_numer.c diff --git a/src/fist_global.F b/src/fist_global.c similarity index 100% rename from src/fist_global.F rename to src/fist_global.c diff --git a/src/fist_input.F b/src/fist_input.c similarity index 100% rename from src/fist_input.F rename to src/fist_input.c diff --git a/src/fist_intra_force.F b/src/fist_intra_force.c similarity index 100% rename from src/fist_intra_force.F rename to src/fist_intra_force.c diff --git a/src/fist_nonbond_force.F b/src/fist_nonbond_force.c similarity index 100% rename from src/fist_nonbond_force.F rename to src/fist_nonbond_force.c diff --git a/src/force_control.F b/src/force_control.c similarity index 100% rename from src/force_control.F rename to src/force_control.c diff --git a/src/force_fields.F b/src/force_fields.c similarity index 100% rename from src/force_fields.F rename to src/force_fields.c diff --git a/src/force_fit.F b/src/force_fit.c similarity index 100% rename from src/force_fit.F rename to src/force_fit.c diff --git a/src/global_types.F b/src/global_types.F deleted file mode 100644 index dd73ccd..0000000 --- a/src/global_types.F +++ /dev/null @@ -1,29 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE global_types - - USE kinds, ONLY : dbl - - IMPLICIT NONE - - PRIVATE - PUBLIC :: global_environment_type - - TYPE global_environment_type - CHARACTER ( LEN = 200 ) :: input_file_name - CHARACTER ( LEN = 200 ) :: program_name - CHARACTER ( LEN = 200 ) :: project_name - LOGICAL :: ionode !! this processor performs global output - INTEGER :: group !! group handle for all processors - INTEGER :: source !! processor id for global output node - INTEGER :: num_pe !! total number of processors - INTEGER :: mepos !! position number for local processor - INTEGER :: print_level !! how much information is written - INTEGER :: idum !! random number seed - INTEGER :: scr !! output unit - END TYPE global_environment_type - -END MODULE global_types diff --git a/src/global_types.h b/src/global_types.h new file mode 100644 index 0000000..c49932b --- /dev/null +++ b/src/global_types.h @@ -0,0 +1,32 @@ +#ifndef _GLOBAL_TYPES_H +#define _GLOBAL_TYPES_H + +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ + +#ifdef __cplusplus +namespace CP2K_NS { +#include +#endif + +typedef struct global_environment_type { + char *input_file_name; + char *program_name; + char *project_name; + bool ionode; // this processor performs global output + int group; // group handle for all processors + int source; // processor id for global output node + int num_pe; // total number of processors + int mepos; // position number for local processor + int print_level; // how much information is written + int idum; // random number seed + int scr; // output unit +} global_environment_type; + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/header.c b/src/header.c index 719853f..2d2907f 100644 --- a/src/header.c +++ b/src/header.c @@ -1,6 +1,6 @@ /*---------------------------------------------------------------------------*/ /* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2000 CP2K developers group */ +/* Copyright (C) 2024 CP2K developers group */ /*---------------------------------------------------------------------------*/ #include "header.h" @@ -20,7 +20,7 @@ void fist_header(FILE *iw) { fprintf(iw, " FRONTIERS IN | \\__| |__|__| SIMULATION TECHNOLOGY\n"); fprintf(iw, " | \\__/ \\ \n"); fprintf(iw, " C.J. Mundy \\ \\____/ | \n"); - fprintf(iw, " S. Balasubramanian / | 1998-1999\n"); + fprintf(iw, " S. Balasubramanian / | 1998-2024\n"); fprintf(iw, " Ken Bagchi \\ / Version 0.0\n"); fprintf(iw, " \n"); } @@ -64,7 +64,7 @@ void qs_header(FILE *iw) { fprintf(iw, " *** \n"); fprintf(iw, " \n"); fprintf(iw, " MPI Festkoerperforschung Stuttgart \n"); - fprintf(iw, " 1999 \n"); + fprintf(iw, " 2024 \n"); fprintf(iw, " \n"); fprintf(iw, " Version 0.0 \n"); fprintf(iw, " \n"); @@ -87,7 +87,7 @@ void wave_header(FILE *iw) { fprintf(iw, " **** **** **** **** ****** ******** \n"); fprintf(iw, " \n"); fprintf(iw, " MPI Festkoerperforschung Stuttgart \n"); - fprintf(iw, " 1999 \n"); + fprintf(iw, " 2024 \n"); fprintf(iw, " \n"); fprintf(iw, " Version 0.0 \n"); fprintf(iw, " \n"); @@ -110,7 +110,7 @@ void faust_header(FILE *iw) { fprintf(iw, " **** **** **** **** ****** ******** \n"); fprintf(iw, " \n"); fprintf(iw, " MPI Festkoerperforschung Stuttgart \n"); - fprintf(iw, " 1999 \n"); + fprintf(iw, " 2024 \n"); fprintf(iw, " \n"); fprintf(iw, " Version 0.0 \n"); fprintf(iw, " \n"); diff --git a/src/initialize_ewalds.F b/src/initialize_ewalds.c similarity index 100% rename from src/initialize_ewalds.F rename to src/initialize_ewalds.c diff --git a/src/initialize_extended_types.F b/src/initialize_extended_types.c similarity index 100% rename from src/initialize_extended_types.F rename to src/initialize_extended_types.c diff --git a/src/initialize_molecule_types.F b/src/initialize_molecule_types.c similarity index 100% rename from src/initialize_molecule_types.F rename to src/initialize_molecule_types.c diff --git a/src/initialize_particle_types.F b/src/initialize_particle_types.c similarity index 100% rename from src/initialize_particle_types.F rename to src/initialize_particle_types.c diff --git a/src/input_types.F b/src/input_types.c similarity index 100% rename from src/input_types.F rename to src/input_types.c diff --git a/src/integrator.F b/src/integrator.c similarity index 100% rename from src/integrator.F rename to src/integrator.c diff --git a/src/io_parameters.F b/src/io_parameters.c similarity index 100% rename from src/io_parameters.F rename to src/io_parameters.c diff --git a/src/kinds.cpp b/src/kinds.cpp index 5106c4c..6a033ab 100644 --- a/src/kinds.cpp +++ b/src/kinds.cpp @@ -1,7 +1,7 @@ /* !-----------------------------------------------------------------------------! ! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! +! Copyright (C) 2024 CP2K developers group ! !-----------------------------------------------------------------------------! Data type definitions; tested on: - IBM AIX xlf90 diff --git a/src/lapack.F b/src/lapack.c similarity index 100% rename from src/lapack.F rename to src/lapack.c diff --git a/src/linklist.h b/src/linklist.h new file mode 100644 index 0000000..82a8790 --- /dev/null +++ b/src/linklist.h @@ -0,0 +1,32 @@ +#ifndef _LINKLIST_H +#define _LINKLIST_H + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + + typedef struct cell_atoms_linklist_type { + int atom; + bool used; + cell_atoms_linklist_type *next; + } cell_atoms_linklist_type; + + typedef struct cell_atoms_type { + cell_atoms_linklist_type *ll; + } cell_atoms_type; + + typedef struct neighbor_cells_type { + int **index; + } neighbor_cells_type; + + typedef struct cell_neighborlist_type { + int *natoms; + neighbor_cells_type **neighbor; + cell_atoms_type *ptype; + } cell_neighborlist_type; + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/linklist_cell_list.F b/src/linklist_cell_list.c similarity index 100% rename from src/linklist_cell_list.F rename to src/linklist_cell_list.c diff --git a/src/linklist_cell_types.F b/src/linklist_cell_types.c similarity index 100% rename from src/linklist_cell_types.F rename to src/linklist_cell_types.c diff --git a/src/linklist_control.F b/src/linklist_control.c similarity index 100% rename from src/linklist_control.F rename to src/linklist_control.c diff --git a/src/linklist_utilities.F b/src/linklist_utilities.c similarity index 100% rename from src/linklist_utilities.F rename to src/linklist_utilities.c diff --git a/src/linklist_verlet_list.F b/src/linklist_verlet_list.c similarity index 100% rename from src/linklist_verlet_list.F rename to src/linklist_verlet_list.c diff --git a/src/linklists.F b/src/linklists.c similarity index 100% rename from src/linklists.F rename to src/linklists.c diff --git a/src/machine.F b/src/machine.c similarity index 100% rename from src/machine.F rename to src/machine.c diff --git a/src/machine_absoft.F b/src/machine_absoft.c similarity index 100% rename from src/machine_absoft.F rename to src/machine_absoft.c diff --git a/src/machine_aix.F b/src/machine_aix.c similarity index 100% rename from src/machine_aix.F rename to src/machine_aix.c diff --git a/src/machine_dec.F b/src/machine_dec.c similarity index 100% rename from src/machine_dec.F rename to src/machine_dec.c diff --git a/src/machine_irix.F b/src/machine_irix.c similarity index 100% rename from src/machine_irix.F rename to src/machine_irix.c diff --git a/src/machine_pgi.F b/src/machine_pgi.c similarity index 100% rename from src/machine_pgi.F rename to src/machine_pgi.c diff --git a/src/machine_t3e.F b/src/machine_t3e.c similarity index 100% rename from src/machine_t3e.F rename to src/machine_t3e.c diff --git a/src/mathconstants.F b/src/mathconstants.c similarity index 100% rename from src/mathconstants.F rename to src/mathconstants.c diff --git a/src/md.F b/src/md.F deleted file mode 100644 index aa45204..0000000 --- a/src/md.F +++ /dev/null @@ -1,499 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE md - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE mp, ONLY : mp_bcast - USE parser, ONLY : parser_init, parser_end, read_line, test_next, & - cfield, p_error, get_real, get_int, stop_parser - USE particle_types, ONLY : particle_type - USE string_utilities, ONLY : uppercase, xstring - USE util, ONLY : gasdev - - IMPLICIT NONE - - PRIVATE - PUBLIC :: read_md_section, simulation_parameters_type, & - initialize_velocities, thermodynamic_type, mdio_parameters_type - - TYPE simulation_parameters_type - INTEGER :: nsteps - REAL ( dbl ) :: dt - REAL ( dbl ) :: temp_ext - REAL ( dbl ) :: p_ext - CHARACTER ( LEN = 20 ) :: ensemble - CHARACTER ( LEN = 20 ) :: read_type - CHARACTER ( LEN = 20 ) :: program - LOGICAL :: constraint - INTEGER :: nfree - INTEGER :: nc - INTEGER :: nyosh - INTEGER :: nhclen - INTEGER, DIMENSION ( 3 ) :: n_cell - REAL ( dbl ) :: tau_nhc - REAL ( dbl ) :: tau_cell - REAL ( dbl ), POINTER, DIMENSION ( : ) :: dt_yosh - REAL ( dbl ) :: shake_tol - REAL ( dbl ) :: verlet_skin - END TYPE simulation_parameters_type - - TYPE thermodynamic_type - REAL ( dbl ), DIMENSION ( 3, 3 ) :: ptens, pv_kin, pv, pv_const - REAL ( dbl ) :: kin, pot, gspace, e_self, e_neut, e_bonded - END TYPE thermodynamic_type - - TYPE mdio_parameters_type - INTEGER :: icrd, ivel, iptens, iener, itemp, idump, iscreen - CHARACTER ( LEN = 50 ) :: crd_file_name - CHARACTER ( LEN = 50 ) :: vel_file_name - CHARACTER ( LEN = 50 ) :: ptens_file_name - CHARACTER ( LEN = 50 ) :: ener_file_name - CHARACTER ( LEN = 50 ) :: temp_file_name - CHARACTER ( LEN = 50 ) :: dump_file_name - END TYPE mdio_parameters_type - -CONTAINS - -!!>---------------------------------------------------------------------------! -!! SECTION: &md ... &end ! -!! ! -!! ensemble: [nve,nvt] ensemble type ! -!! steps: n total number of steps ! -!! timestep: dt time step [fs] ! -!! temperature: T temperature [K] ! -!! restart: [pos,posvel] start type ! -!! constraints: [on,off] constraints ! -!! shake: eps convergence for Shake algorithm ! -!! verlet_skin vs buffer size for Verlet lists ! -!! cells x y z Number of cells in each direction ! -!! Nose_parameter & parameter of Nose-Hoover-chains ! -!! length: nhclen & length of thermostat ! -!! Yoshida: nyosh & order of Yoshida integrator ! -!! mts: nc & number of multiple time steps ! -!! timecon: tau_nhc NHC time constant ! -!! Barostat_parameter parameter of barostat ! -!! pressure: P & pressure [bar] ! -!! timecon: tau_cell & barostat time constant ! -!! FILES & ! -!! filebody "filename" & ! -!! coordinates "filename.crd" & ! -!! velocities "filename.vel" & ! -!! pressure "filename.ptens" & ! -!! energies "filename.ener" & ! -!! temperature "filename.temp" & ! -!! dump "filename.dum" ! -!! PRINT & ! -!! screen iscreen & ! -!! files ifiles & ! -!! coordinates icrd & ! -!! velocities ivel & ! -!! pressure iptens & ! -!! energies iener & ! -!! temperature itemp & ! -!! dump idump ! -!! ! -!! ! -!!<---------------------------------------------------------------------------! - -SUBROUTINE read_md_section ( simpar, mdpar, mdio ) - - IMPLICIT NONE - -! Arguments - TYPE ( simulation_parameters_type ), INTENT ( OUT ) :: simpar - TYPE ( global_environment_type ), INTENT ( IN ) :: mdpar - TYPE ( mdio_parameters_type ), INTENT ( OUT ) :: mdio - -! Locals - INTEGER :: ierror, ilen, msglen, ia, ie, iw, allgrp, source - CHARACTER ( LEN = 20 ) :: string - CHARACTER ( LEN = 5 ) :: label - -!------------------------------------------------------------------------------ - -!..defaults - simpar % ensemble = 'NVE' - simpar % nsteps = 0 - simpar % dt = 0.0_dbl - simpar % temp_ext = 0.0_dbl - simpar % p_ext = 0.0_dbl - simpar % read_type = 'POS' - simpar % constraint = .FALSE. - simpar % shake_tol = 1.0E-6_dbl - simpar % nhclen = 1 - simpar % nc = 1 - simpar % n_cell = 1 - simpar % nyosh = 1 - simpar % tau_nhc = 1000.0_dbl - simpar % tau_cell = 1000.0_dbl - simpar % verlet_skin = 1.0_dbl - - iw = mdpar % scr - -!..filenames - CALL xstring ( mdpar % project_name, ia, ie ) - mdio % crd_file_name = mdpar % project_name(ia:ie) // '.crd' - mdio % vel_file_name = mdpar % project_name(ia:ie) // '.vel' - mdio % ptens_file_name = mdpar % project_name(ia:ie) // '.ptens' - mdio % ener_file_name = mdpar % project_name(ia:ie) // '.ener' - mdio % temp_file_name = mdpar % project_name(ia:ie) // '.temp' - mdio % dump_file_name = mdpar % project_name(ia:ie) // '.dump' - -!..print frequency - mdio % icrd = 1 - mdio % ivel = 1 - mdio % iptens = 1 - mdio % iener = 1 - mdio % itemp = 1 - mdio % idump = 1 - mdio % iscreen = 1 - -!..parse the input section - label = '&MD' - CALL parser_init(mdpar % input_file_name,label,ierror,mdpar) - IF (ierror /= 0 ) THEN - IF( mdpar % ionode ) & - WRITE ( iw, '( a )' ) ' No input section &MD found ' - ELSE - CALL read_line - DO WHILE ( test_next() /= 'X' ) - ilen = 6 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - - SELECT CASE ( string ) - CASE DEFAULT - CALL p_error() - CALL stop_parser ( 'read_md_section', 'unknown option' ) - - CASE ( 'ENSEMB' ) - ilen = 0 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - simpar % ensemble = string ( 1:ilen ) - - CASE ( 'STEPS' ) - simpar % nsteps = get_int() - - CASE ( 'VERLET' ) - simpar % verlet_skin = get_real() - - CASE ( 'CELL' ) - simpar % n_cell(1) = get_int() - simpar % n_cell(2) = get_int() - simpar % n_cell(3) = get_int() - - CASE ( 'TIMEST' ) - simpar % dt = get_real() - - CASE ( 'TEMPER' ) - simpar % temp_ext = get_real() - - CASE ( 'RESTAR' ) - ilen = 0 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - simpar % read_type = string ( 1:ilen ) - - CASE ( 'CONSTR' ) - ilen = 0 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - IF ( string(1:2)=='ON' ) simpar % constraint = .TRUE. - IF ( string(1:3)=='OFF' ) simpar % constraint = .FALSE. - - CASE ( 'SHAKE' ) - simpar % shake_tol = get_real() - - CASE ( 'NOSE_P' ) - DO WHILE ( test_next() == 'C' ) - - ilen = 6 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - - SELECT CASE ( string ) - CASE DEFAULT - CALL p_error() - CALL stop_parser ( 'read_md_section%nose', & - 'unknown suboption' ) - CASE ( 'LENGTH' ) - simpar % nhclen = get_int() - CASE ( 'YOSHID' ) - simpar % nyosh = get_int() - CASE ( 'TIMECO' ) - simpar % tau_nhc = get_real() - CASE ( 'MTS' ) - simpar % nc = get_int() - END SELECT - END DO - - CASE ( 'BAROST' ) - DO WHILE ( test_next() == 'C' ) - - ilen = 6 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - - SELECT CASE ( string ) - CASE DEFAULT - CALL p_error() - CALL stop_parser ( 'read_md_section%barost', & - 'unknown suboption' ) - CASE ( 'TIMECO' ) - simpar % tau_cell = get_real() - CASE ( 'PRESSU' ) - simpar % p_ext = get_real() - END SELECT - END DO - - CASE ( 'FILES' ) - DO WHILE ( test_next() == 'C' ) - - ilen = 6 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - - SELECT CASE ( string ) - CASE DEFAULT - CALL p_error() - CALL stop_parser ( 'read_md_section%files', & - 'unknown suboption' ) - CASE ( 'FILEBO' ) - ilen = 0 - CALL cfield ( string, ilen ) - mdio % crd_file_name = string(1:ilen) // '.crd' - mdio % vel_file_name = string(1:ilen) // '.vel' - mdio % ptens_file_name = string(1:ilen) // '.ptens' - mdio % ener_file_name = string(1:ilen) // '.ener' - mdio % temp_file_name = string(1:ilen) // '.temp' - mdio % dump_file_name = string(1:ilen) // '.dump' - CASE ( 'COORDI' ) - ilen = 0 - CALL cfield ( mdio % crd_file_name, ilen ) - CASE ( 'ENERGI' ) - ilen = 0 - CALL cfield ( mdio % ener_file_name, ilen ) - CASE ( 'PRESSU' ) - ilen = 0 - CALL cfield ( mdio % ptens_file_name, ilen ) - CASE ( 'VELOCI' ) - ilen = 0 - CALL cfield ( mdio % vel_file_name, ilen ) - CASE ( 'TEMPER' ) - ilen = 0 - CALL cfield ( mdio % temp_file_name, ilen ) - CASE ( 'DUMP' ) - ilen = 0 - CALL cfield ( mdio % dump_file_name, ilen ) - END SELECT - END DO - - CASE ( 'PRINT' ) - DO WHILE ( test_next() == 'C' ) - - ilen = 6 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - - SELECT CASE ( string ) - CASE DEFAULT - CALL p_error() - CALL stop_parser ( 'read_md_section%print', & - 'unknown suboption' ) - - CASE ( 'SCREEN' ) - mdio % iscreen = get_int() - - CASE ( 'FILES' ) - ia = get_int() - mdio % icrd = ia - mdio % ivel = ia - mdio % iener = ia - mdio % iptens = ia - mdio % itemp = ia - mdio % idump = ia - CASE ( 'COORDI' ) - mdio % icrd = get_int() - CASE ( 'ENERGI' ) - mdio % iener = get_int() - CASE ( 'PRESSU' ) - mdio % iptens = get_int() - CASE ( 'VELOCI' ) - mdio % ivel = get_int() - CASE ( 'TEMPER' ) - mdio % itemp = get_int() - CASE ( 'DUMP' ) - mdio % idump = get_int() - END SELECT - END DO - END SELECT - CALL read_line - END DO - - END IF - CALL parser_end -!..end of parsing the input section - -!..write some information to output - IF (mdpar % ionode .AND. mdpar % print_level>=0) THEN - WRITE ( iw, '( A )' ) ' MD| Molecular Dynamics Protocol ' - WRITE ( iw, '( A,T61,A )' ) ' MD| Ensemble Type ', & - ADJUSTR ( simpar % ensemble ) - WRITE ( iw, '( A,T61,A )' ) ' MD| Restart Type ', & - ADJUSTR ( simpar % read_type ) - WRITE ( iw, '( A,T71,I10 )' ) ' MD| Number of Time Steps ', & - simpar % nsteps - WRITE ( iw, '( A,T71,F10.2 )' ) ' MD| Time Step [fs] ', simpar % dt - WRITE ( iw, '( A,T71,F10.2 )' ) ' MD| Temperature [K] ', & - simpar % temp_ext - WRITE ( iw, '( A,T71,F10.2 )' ) & - ' MD| Verlet buffer skin [Angstrom] ', simpar % verlet_skin - IF ( ( simpar % ensemble ( 1:3 ) == 'NVT' ) & - .OR. (simpar % ensemble ( 1:3 ) == 'NPT' ) ) THEN - WRITE ( iw, '( A )' ) ' MD| Nose-Hoover-Chain parameters ' - WRITE ( iw, '( A,T77,I4 )' ) ' MD| Nose-Hoover-Chain length ', & - simpar % nhclen - WRITE ( iw, '( A,T71,F10.4 )' ) & - ' MD| Nose-Hoover-Chain time constant [fs] ', simpar % tau_nhc - WRITE ( iw, '( A,T77,I4 )' ) ' MD| Order of Yoshida integrator ', & - simpar % nyosh - WRITE ( iw, '( A,T77,I4 )' ) ' MD| Number of multiple time steps', & - simpar % nc - END IF - IF ( simpar % ensemble ( 1:3 ) == 'NPT' ) THEN - WRITE ( iw, '( A, T71, F10.2 )' ) & - ' MD| Pressure [bar] ', simpar % p_ext - WRITE ( iw, '( A, T71, F10.4 )' ) & - ' MD| Barostat time constant [fs] ', simpar % tau_cell - END IF - IF ( simpar % constraint ) THEN - WRITE ( iw, '( A )' ) ' MD| Constraints activated ' - WRITE ( iw, '( A,T71,G10.4 )' ) ' MD| Tolerance for shake ', & - simpar % shake_tol - END IF - WRITE ( iw, '( A,T63,i10,A )' ) ' MD| Print MD information every', & - mdio % iscreen, ' step(s)' - WRITE ( iw, '( A,T20,A,T71,A )' ) ' MD| File type', & - 'Print frequency[steps]', 'File names' - WRITE ( iw, '( A,T25,i5,T31,A )' ) ' MD| Coordinates', mdio % icrd, & - ADJUSTR ( mdio % crd_file_name ( 1:50 ) ) - WRITE ( iw, '( A,T25,i5,T31,A )' ) ' MD| Velocities', mdio % ivel, & - ADJUSTR ( mdio % vel_file_name ( 1:50 ) ) - WRITE ( iw, '( A,T25,i5,T31,A )' ) ' MD| Energies', mdio % iener, & - ADJUSTR ( mdio % ener_file_name ( 1:50 ) ) - WRITE ( iw, '( A,T25,i5,T31,A )' ) ' MD| Temperature', mdio % itemp, & - ADJUSTR ( mdio % temp_file_name ( 1:50 ) ) - WRITE ( iw, '( A,T25,i5,T31,A )' ) ' MD| Pressure Tensor', mdio % iptens, & - ADJUSTR ( mdio % ptens_file_name ( 1:50 ) ) - WRITE ( iw, '( A,T25,i5,T31,A )' ) ' MD| Dump', mdio % idump, & - ADJUSTR ( mdio % dump_file_name ( 1:50 ) ) - WRITE (iw,*) - END IF - -END SUBROUTINE read_md_section - -!****************************************************************************** - -! Initializes the velocities to the Maxwellian distribution - -SUBROUTINE initialize_velocities ( simpar, part, mdpar ) - - IMPLICIT NONE - -! Arguments - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE ( particle_type ), INTENT ( INOUT ), DIMENSION ( : ) :: part - TYPE ( global_environment_type ), INTENT ( INOUT ) :: mdpar - -! Locals - INTEGER :: i, id, natoms, iw - REAL ( dbl ), DIMENSION ( 3 ) :: vcom - REAL ( dbl ), DIMENSION ( 3 ) :: sum - REAL ( dbl ) :: denom, sc, mass - REAL ( dbl ) :: akin, temp - LOGICAL :: domdec - -!------------------------------------------------------------------------------ - - iw = mdpar % scr - IF (mdpar % ionode .AND. mdpar % print_level>1) THEN - WRITE ( iw, '( A, A, A )' ) ' **********************', & - ' begin of velocity initialization ', '***********************' - END IF - -! Initializing parameters - sum = 0.0_dbl - vcom = 0.0_dbl - denom = 0.0_dbl - natoms = SIZE ( part ) - -! initializing velocities - IF (mdpar % ionode) THEN - DO i = 1, natoms - part(i) % v(1) = gasdev(mdpar % idum) - part(i) % v(2) = gasdev(mdpar % idum) - part(i) % v(3) = gasdev(mdpar % idum) - END DO - akin = 0.0_dbl - DO i = 1, natoms - mass = part(i) % prop % mass - akin = akin + 0.5_dbl*(mass*part(i) % v(1)*part(i) % v(1)) - akin = akin + 0.5_dbl*(mass*part(i) % v(2)*part(i) % v(2)) - akin = akin + 0.5_dbl*(mass*part(i) % v(3)*part(i) % v(3)) - END DO - - temp = 2.0_dbl * akin / REAL ( simpar % nfree, dbl ) - -! scale velocities to get the correct initial temperature - sc = SQRT ( simpar % temp_ext / temp ) - DO i = 1, natoms - part(i) % v(1) = sc*part(i) % v(1) - part(i) % v(2) = sc*part(i) % v(2) - part(i) % v(3) = sc*part(i) % v(3) - END DO - -! Computing the COM velocities - DO i = 1, natoms - mass = part(i) % prop % mass - vcom(1) = vcom(1) + mass*part(i) % v(1) - vcom(2) = vcom(2) + mass*part(i) % v(2) - vcom(3) = vcom(3) + mass*part(i) % v(3) - denom = denom + mass - END DO - -! Moving the velocities so that the COM velocity is zero - vcom = vcom / denom - DO i = 1, natoms - mass = part(i) % prop % mass - part(i) % v ( : ) = part(i) % v ( : ) - vcom ( : ) - sum ( : ) = sum ( : ) + mass*part(i) % v ( : ) - END DO - END IF - -#if defined(__parallel) - DO i = 1, natoms - CALL mp_bcast(part(i) % v,mdpar % source,mdpar % group) - END DO -#endif - - IF ( mdpar % ionode .AND. mdpar % print_level > 1 ) THEN - WRITE ( iw, '( A, T69, E12.6 )' ) & - ' Centre of mass velocity in direction x:', sum ( 1 ) - WRITE ( iw, '( A, T69, E12.6 )' ) & - ' Centre of mass velocity in direction y:', sum ( 2 ) - WRITE ( iw, '( A, T69, E12.6 )' ) & - ' Centre of mass velocity in direction z:', sum ( 3 ) - WRITE ( iw, '( A, A, A, / )' ) ' ***********************', & - ' end of velocity initialization ', '************************' - END IF - -END SUBROUTINE initialize_velocities - -!****************************************************************************** - -END MODULE md diff --git a/src/md.h b/src/md.h new file mode 100644 index 0000000..5b2eaef --- /dev/null +++ b/src/md.h @@ -0,0 +1,6 @@ +#ifndef _MD_H +#define _MD_H + + + +#endif \ No newline at end of file diff --git a/src/mol_force.F b/src/mol_force.c similarity index 100% rename from src/mol_force.F rename to src/mol_force.c diff --git a/src/molecule.h b/src/molecule.h new file mode 100644 index 0000000..14db731 --- /dev/null +++ b/src/molecule.h @@ -0,0 +1,165 @@ +#ifndef _MOLECULE_H +#define _MOLECULE_H + +#include "particle.h" +#include "linklist.h" + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + + typedef struct linklist_images { + double vec[3]; + linklist_images *next; + } linklist_images; + + typedef struct linklist_exclusion { + particle_type *p; + linklist_exclusion *next; + } linklist_exclusion; + + typedef struct localization_list { + bool all; + int nloc; + int *atomlist; + } localization_list; + + typedef struct linklist_neighbor { + particle_type *p; + linklist_images *image; + int index, nimages; + linklist_neighbor *next; + } linklist_neighbor; + + typedef struct particle_node_type { + particle_type *p; + int in_mol, iat_in_mol; + int nneighbor, nexcl, nsneighbor; + linklist_neighbor *nl; + linklist_neighbor *sl; + linklist_exclusion *ex; + localization_list *llist; + } particle_node_type; + + typedef struct linklist_atoms { + particle_node_type *part; + linklist_atoms *next; + } linklist_atoms; + + typedef struct bond_parameters_type { + char type[21]; + double r0, k; + } bond_parameters_type; + + typedef struct linklist_bonds { + particle_type *p1, *p2; + bond_parameters_type *bond_param; + linklist_bonds *next; + int index[2]; + } linklist_bonds; + + typedef struct bend_parameters_type { + char type[21]; + double theta0, k; + } bend_parameters_type; + + typedef struct linklist_bends { + particle_type *p1, *p2, *p3; + bend_parameters_type *bend_param; + linklist_bends *next; + int index[3]; + } linklist_bends; + + typedef struct torsion_parameters_type { + char type[21]; + double parm[7]; + } torsion_parameters_type; + + typedef struct linklist_torsions { + particle_type *p1, *p2, *p3, *p4; + torsion_parameters_type *torsion_param; + linklist_torsions *next; + int index[4]; + } linklist_torsions; + + typedef struct linklist_dist_constraints { + particle_type *p1, *p2; + double *distance; + double del_lam, lambda, sigma; + double rold1[3], rold2[3], fc[3]; + double scale, scale_old; + linklist_dist_constraints *next; + } linklist_dist_constraints; + + typedef struct linklist_g3x3_constraints { + particle_type *p1, *p2, *p3; + double *d12, *d13, *d23; + double fc1[3], fc2[3], fc3[3]; + double lambda[3], del_lam[3]; + double rold1[3], rold2[3], rold3[3]; + double vold1[3], vold2[3], vold3[3]; + double v1[3], v2[3], v3[3]; + double scale, scale_old; + linklist_g3x3_constraints *next; + } linklist_g3x3_constraints; + + typedef struct intra_parameters_type { + bond_parameters_type **bond_param; + bend_parameters_type ***bend_param; + torsion_parameters_type ***torsion_param; + double **constraint_distance; + } intra_parameters_type; + + typedef struct molecule_parameter_type { + char name[21]; + int natom; + int natom_type; + char *aname[21]; + char *alabel[21]; + double *aweight; + double *acharge; + int nbonds; + int **bonds; + int nbends; + int **bends; + int ntorsions ; + int **torsions; + int ndcon ; + int **ndc; + int n3x3con; + int **n3x3c; + } molecule_parameter_type; + + typedef struct molecule_type { + char file_name[21]; + int num_mol; + char nhcopt[21]; + molecule_parameter_type molpar; + } molecule_type; + + typedef struct molecule_structure_type { + char mol_name[31]; // name of molecule + int moltype; // pointer to molecular type + int imol; // position counter + int atombase; // position counter of first atom in molecule + int natoms_mol; // # of atoms in molecule + int nvt_num; // thermostat number that it is connected. + // Used for constraints + linklist_atoms *ll_atoms; + int nbonds_mol; // # of bonds in molecule + linklist_bonds *ll_bonds; + int nbends_mol; // # of bends in molecule + linklist_bends *ll_bends; + int ntorsions_mol; // # of torsions in molecule + linklist_torsions *ll_torsions; + int ndistconst_mol; // # of distance constraints in molecule + linklist_dist_constraints *ll_dist_const; + int ng3x3const_mol; // # of 3x3 group constraints in molecule + linklist_g3x3_constraints *ll_g3x3_const; + } molecule_structure_type; + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/molecule_input.F b/src/molecule_input.c similarity index 100% rename from src/molecule_input.F rename to src/molecule_input.c diff --git a/src/molecule_types.F b/src/molecule_types.c similarity index 100% rename from src/molecule_types.F rename to src/molecule_types.c diff --git a/src/mp.F b/src/mp.cpp similarity index 66% rename from src/mp.F rename to src/mp.cpp index 305c5a2..d1e4b83 100644 --- a/src/mp.F +++ b/src/mp.cpp @@ -1,218 +1,127 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ -MODULE mp - - USE kinds, ONLY : dbl - USE parallel_include - - PRIVATE - PUBLIC :: mp_start, mp_end, mp_environ, mp_group, mp_cart_create, & - mp_bcast, mp_stop, mp_sum, mp_max, mp_min, mp_sync - - INTERFACE mp_bcast - MODULE PROCEDURE mp_bcast_i1, mp_bcast_r1, mp_bcast_c1, mp_bcast_z, & - mp_bcast_iv, mp_bcast_rv, mp_bcast_cv, mp_bcast_l, mp_bcast_rm, & - mp_bcast_cm, mp_bcast_im - END INTERFACE - - INTERFACE mp_sum - MODULE PROCEDURE mp_sum_i1, mp_sum_r1, mp_sum_c1, mp_sum_iv, & - mp_sum_rv, mp_sum_cv, mp_sum_rm, mp_sum_cm - END INTERFACE - - INTERFACE mp_max - MODULE PROCEDURE mp_max_i, mp_max_r, mp_max_rv - END INTERFACE - - INTERFACE mp_min - MODULE PROCEDURE mp_min_i, mp_min_r, mp_min_rv - END INTERFACE - -CONTAINS +#include -!****************************************************************************** - -!..mp_start -SUBROUTINE mp_start() - - IMPLICIT NONE - -! Locals - INTEGER :: ierr - - ierr = 0 -#if defined(__parallel) - CALL mpi_init ( ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8000 ) -#endif - -END SUBROUTINE mp_start +void mp_start() { -!****************************************************************************** + int ierr = 0; + #if defined(__parallel) + mpi_init(ierr); + if (ierr != 0) mp_stop(8000); + #endif -!..mp_end -SUBROUTINE mp_end() - - IMPLICIT NONE - -! Locals - INTEGER :: ierr - - ierr = 0 -#if defined(__parallel) - CALL mpi_finalize ( ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8999 ) -#endif - -END SUBROUTINE mp_end +} -!****************************************************************************** +void mp_end() { -!..mp_stop -SUBROUTINE mp_stop ( code ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: code - -! Locals - INTEGER :: numtask, taskid, groupid - -#if defined(__parallel) - CALL mpi_abort ( mpi_comm_world, code ) -#endif - - CALL mp_environ ( numtask, taskid, groupid ) - - WRITE(*,'(/,A,T71,I10,/)') ' CP2K| Stopped by processor number',taskid + int ierr = 0; + #if defined(__parallel) + mpi_finalize(ierr); + if (ierr != 0) mp_stop(8999); + #endif - STOP "mp_stop" +} - -END SUBROUTINE mp_stop +void mp_stop(int code) { -!****************************************************************************** + int numtask, taskid, groupid; -!..mp_sync -SUBROUTINE mp_sync ( group ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: group - -! Locals - INTEGER :: ierr - -#if defined(__parallel) - CALL mpi_barrier ( group, ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8400 ) -#endif - -END SUBROUTINE mp_sync + #if defined(__parallel) + mpi_abort(mpi_comm_world, code); + #endif -!****************************************************************************** + mp_environ(numtask, taskid, groupid); -!..mp_environ -SUBROUTINE mp_environ ( numtask, taskid, groupid ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( OUT ) :: numtask, taskid, groupid - -! Locals - INTEGER :: ierr - - ierr = 0 - numtask = 1 - taskid = 0 - groupid = 0 -#if defined(__parallel) - CALL mpi_comm_rank ( mpi_comm_world, taskid, ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8001 ) - - CALL mpi_comm_size ( mpi_comm_world, numtask, ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8002 ) - groupid = mpi_comm_world -#endif - -END SUBROUTINE mp_environ + std::cout << " CP2K| Stopped by processor number " << taskid; -!****************************************************************************** + std::cout << "mp_stop" << std::endl; + exit(1); +} -!..mp_group -SUBROUTINE mp_group(group_list,group_size,base_group,groupid) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: group_list ( : ), group_size, base_group - INTEGER, INTENT ( OUT ) :: groupid - -! Locals - INTEGER :: base, newgroup, ierr - - ierr = 0 - groupid = base_group -#if defined(__parallel) - CALL mpi_comm_group ( base_group, base, ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8010 ) - - CALL mpi_group_incl ( base, group_size, group_list, newgroup, ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8011 ) - - CALL mpi_comm_create ( base_group, newgroup, groupid, ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8012 ) -#endif - -END SUBROUTINE mp_group +void mp_sync(int group) { -!****************************************************************************** + int ierr = 0; + #if defined(__parallel) + mpi_barrier(group, ierr); + if (ierr != 0) mp_stop(8400); + #endif +} -!..mp_cart_create -SUBROUTINE mp_cart_create ( comm_old, ndims, dims, pos, comm_cart ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: comm_old, ndims - INTEGER, INTENT ( OUT ) :: dims ( : ), pos ( : ), comm_cart - -! Locals - INTEGER :: ierr, nodes - LOGICAL :: period(1:ndims), reorder - - ierr = 0 - dims ( 1:ndims ) = 1 - pos ( 1:ndims ) = 1 - comm_cart = comm_old -#if defined(__parallel) - dims ( 1:ndims ) = 0 - - CALL mpi_comm_size ( comm_old, nodes, ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8020 ) - - CALL mpi_dims_create ( nodes, ndims, dims, ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8021 ) - - reorder = .TRUE. - period = .TRUE. - CALL mpi_cart_create ( comm_old, ndims, dims, period, reorder, comm_cart, & - ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8022 ) - - CALL mpi_cart_get ( comm_cart, ndims, dims, period, pos, ierr ) - IF ( ierr /= 0 ) CALL mp_stop ( 8023 ) -#endif - -END SUBROUTINE mp_cart_create +void mp_environ(int numtask, int taskid, int groupid) { -!****************************************************************************** + int ierr = 0; + + numtask = 1; + taskid = 0; + groupid = 0; + + #if defined(__parallel) + mpi_comm_rank(mpi_comm_world, taskid, ierr); + if (ierr != 0) mp_stop(8001); + + mpi_comm_size(mpi_comm_world, numtask, ierr); + if (ierr != 0) mp_stop(8002); + groupid = mpi_comm_world; + #endif + +} + +void mp_group(int *group_list, int group_size, int base_group, int *groupid) { + + int base, newgroup, ierr; + + ierr = 0; + *groupid = base_group; + #if defined(__parallel) + mpi_comm_group(base_group, base, ierr); + if (ierr != 0) mp_stop(8010); + + mpi_group_incl(base, group_size, group_list, newgroup, ierr); + if (ierr != 0) mp_stop(8011); + + mpi_comm_create(base_group, newgroup, groupid, ierr); + if (ierr != 0) mp_stop(8012); + #endif + +} + +void mp_cart_create (int comm_old, int ndims, int *dims, int *pos, int *comm_cart ) { + + size_t i; + int ierr, nodes; + bool period[ndims], reorder; + + ierr = 0; + for (i = 0; i < ndims; i++) { + dims[i] = 1; + pos[i] = 1; + } + + comm_cart = comm_old; + #if defined(__parallel) + for (i = 0; i < ndims; i++) { + dims[i] = 0; + } + + mpi_comm_siz ( comm_old, nodes, ierr ); + if ( ierr != 0 ) mp_stop ( 8020 ); + + mpi_dims_create ( nodes, ndims, dims, ierr ); + if ( ierr != 0 ) mp_stop ( 8021 ); + + reorder = true; + period = true; + mpi_cart_create ( comm_old, ndims, dims, period, reorder, comm_cart, ierr ); + if ( ierr != 0 ) mp_stop ( 8022 ); + + mpi_cart_get ( comm_cart, ndims, dims, period, pos, ierr ); + IF ( ierr != 0 ) mp_stop ( 8023 ); + #endif + +} !..mp_bcast SUBROUTINE mp_bcast_i1(msg,source,gid) @@ -220,7 +129,7 @@ SUBROUTINE mp_bcast_i1(msg,source,gid) INTEGER :: msg INTEGER :: source, gid INTEGER :: msglen, ierr - + ierr = 0 msglen = 1 #if defined(__parallel) @@ -233,7 +142,7 @@ SUBROUTINE mp_bcast_iv(msg,source,gid) INTEGER :: msg ( : ) INTEGER :: source, gid INTEGER :: msglen, ierr - + ierr = 0 msglen = size(msg) #if defined(__parallel) @@ -246,7 +155,7 @@ SUBROUTINE mp_bcast_im(msg,source,gid) INTEGER :: msg ( :, : ) INTEGER :: source, gid INTEGER :: msglen, ierr - + ierr = 0 msglen = size(msg) #if defined(__parallel) @@ -259,7 +168,7 @@ SUBROUTINE mp_bcast_r1(msg,source,gid) REAL ( dbl ) :: msg INTEGER :: msglen, source, gid INTEGER :: ierr - + ierr = 0 msglen = 1 #if defined(__parallel) @@ -272,7 +181,7 @@ SUBROUTINE mp_bcast_rv(msg,source,gid) REAL ( dbl ) :: msg ( : ) INTEGER :: source, gid INTEGER :: msglen, ierr - + ierr = 0 msglen = size(msg) #if defined(__parallel) @@ -285,7 +194,7 @@ SUBROUTINE mp_bcast_rm(msg,source,gid) REAL ( dbl ) :: msg ( :, : ) INTEGER :: source, gid INTEGER :: msglen, ierr - + ierr = 0 msglen = size(msg) #if defined(__parallel) @@ -298,7 +207,7 @@ SUBROUTINE mp_bcast_c1(msg,source,gid) COMPLEX ( dbl ) :: msg INTEGER :: source, gid INTEGER :: msglen, ierr - + ierr = 0 msglen = 1 #if defined(__parallel) @@ -311,7 +220,7 @@ SUBROUTINE mp_bcast_cv(msg,source,gid) COMPLEX ( dbl ) :: msg ( : ) INTEGER :: source, gid INTEGER :: msglen, ierr - + ierr = 0 msglen = size(msg) #if defined(__parallel) @@ -324,7 +233,7 @@ SUBROUTINE mp_bcast_cm(msg,source,gid) COMPLEX ( dbl ) :: msg ( :, : ) INTEGER :: source, gid INTEGER :: msglen, ierr - + ierr = 0 msglen = size(msg) #if defined(__parallel) @@ -337,7 +246,7 @@ SUBROUTINE mp_bcast_l(msg,source,gid) LOGICAL :: msg INTEGER :: source, gid INTEGER :: msglen, ierr - + ierr = 0 msglen = 1 #if defined(__parallel) @@ -351,7 +260,7 @@ SUBROUTINE mp_bcast_z(msg,source,gid) INTEGER :: source, gid INTEGER :: msglen, ierr, i INTEGER, ALLOCATABLE :: imsg ( : ) - + ierr = 0 msglen = len(msg) #if defined(__parallel) @@ -381,7 +290,7 @@ SUBROUTINE mp_sum_i1(msg,gid) INTEGER, INTENT ( INOUT ) :: msg INTEGER, INTENT ( IN ) :: gid INTEGER :: msglen, res, ierr - + msglen = 1 #if defined(__parallel) CALL mpi_allreduce(msg,res,msglen,mpi_integer,mpi_sum,gid,ierr) @@ -411,7 +320,7 @@ SUBROUTINE mp_sum_r1(msg,gid) INTEGER, INTENT ( IN ) :: gid INTEGER :: msglen, ierr REAL ( dbl ) :: res - + msglen = 1 #if defined(__parallel) CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_sum,gid, & @@ -462,7 +371,7 @@ SUBROUTINE mp_sum_c1(msg,gid) INTEGER, INTENT ( IN ) :: gid INTEGER :: msglen, ierr COMPLEX ( dbl ) :: res - + msglen = 2 #if defined(__parallel) CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_sum,gid, & @@ -600,8 +509,4 @@ SUBROUTINE mp_min_rv(msg,gid) DEALLOCATE (res) IF ( ierr /= 0 ) CALL mp_stop(8313) #endif -END SUBROUTINE mp_min_rv - -!****************************************************************************** - -END MODULE mp +END SUBROUTINE mp_min_rv \ No newline at end of file diff --git a/src/nhc.F b/src/nhc.c similarity index 100% rename from src/nhc.F rename to src/nhc.c diff --git a/src/nose.F b/src/nose.c similarity index 100% rename from src/nose.F rename to src/nose.c diff --git a/src/nrutil.cpp b/src/nrutil.cpp index b6a0404..42d5b68 100644 --- a/src/nrutil.cpp +++ b/src/nrutil.cpp @@ -1,10 +1,14 @@ #include +#include #include +#include -namespace nrutil { +namespace CP2K_NS { const double twopi = 6.283185307179586476925286766559005768394; - const int npar_arth = 16, npar2_arth = 8; - const int npar_geop = 4, npar2_geop = 2; + const int npar_arth = 16; + const int npar2_arth = 8; + const int npar_geop = 4; + const int npar2_geop = 2; const int npar_cumsum = 16; const int npar_cumprod = 8; const int npar_poly = 8; @@ -232,7 +236,7 @@ namespace nrutil { iminloc = imin(1) END FUNCTION iminloc - SUBROUTINE assert1(n1,string) +void assert1(bool n1, std::string string) { CHARACTER (len=*), INTENT (IN) :: string LOGICAL, INTENT (IN) :: n1 @@ -240,9 +244,9 @@ namespace nrutil { WRITE (*,*) 'nrerror: an assertion failed with this tag:', string STOP 'program terminated by assert1' END IF - END SUBROUTINE assert1 +} - SUBROUTINE assert2(n1,n2,string) +void assert2(bool n1, bool n2, std::string string) { CHARACTER (len=*), INTENT (IN) :: string LOGICAL, INTENT (IN) :: n1, n2 @@ -250,9 +254,9 @@ namespace nrutil { WRITE (*,*) 'nrerror: an assertion failed with this tag:', string STOP 'program terminated by assert2' END IF - END SUBROUTINE assert2 +} - SUBROUTINE assert3(n1,n2,n3,string) +void assert3(bool n1, bool n2, bool n3, std::string string) { CHARACTER (len=*), INTENT (IN) :: string LOGICAL, INTENT (IN) :: n1, n2, n3 @@ -260,9 +264,9 @@ namespace nrutil { WRITE (*,*) 'nrerror: an assertion failed with this tag:', string STOP 'program terminated by assert3' END IF - END SUBROUTINE assert3 +} - SUBROUTINE assert4(n1,n2,n3,n4,string) +void assert4(bool n1, bool n2, bool n3, bool n4, std::string string) { CHARACTER (len=*), INTENT (IN) :: string LOGICAL, INTENT (IN) :: n1, n2, n3, n4 @@ -270,9 +274,9 @@ namespace nrutil { WRITE (*,*) 'nrerror: an assertion failed with this tag:', string STOP 'program terminated by assert4' END IF - END SUBROUTINE assert4 +} - SUBROUTINE assert_v(n,string) +void assert_v(bool n[], std::string string) { CHARACTER (len=*), INTENT (IN) :: string LOGICAL, DIMENSION (:), INTENT (IN) :: n @@ -280,7 +284,7 @@ namespace nrutil { WRITE (*,*) 'nrerror: an assertion failed with this tag:', string STOP 'program terminated by assert_v' END IF - END SUBROUTINE assert_v +} int assert_eq2(int n1, int n2, std::string string) { @@ -292,7 +296,7 @@ namespace nrutil { } } - FUNCTION assert_eq3(n1,n2,n3,string) +int assert_eq3(int n1, int n2, int n3, std::string) { CHARACTER (len=*), INTENT (IN) :: string INTEGER, INTENT (IN) :: n1, n2, n3 INTEGER :: assert_eq3 @@ -303,9 +307,9 @@ namespace nrutil { WRITE (*,*) 'nrerror: an assert_eq failed with this tag:', string STOP 'program terminated by assert_eq3' END IF - END FUNCTION assert_eq3 +} - FUNCTION assert_eq4(n1,n2,n3,n4,string) +int assert_eq4(int n1, int n2, int n3, int n4, std::string) { CHARACTER (len=*), INTENT (IN) :: string INTEGER, INTENT (IN) :: n1, n2, n3, n4 INTEGER :: assert_eq4 @@ -316,9 +320,9 @@ namespace nrutil { WRITE (*,*) 'nrerror: an assert_eq failed with this tag:', string STOP 'program terminated by assert_eq4' END IF - END FUNCTION assert_eq4 +} - FUNCTION assert_eqn(nn,string) +int assert_eqn(int nn[], std::string string) { CHARACTER (len=*), INTENT (IN) :: string INTEGER, DIMENSION (:), INTENT (IN) :: nn INTEGER :: assert_eqn @@ -329,23 +333,22 @@ namespace nrutil { WRITE (*,*) 'nrerror: an assert_eq failed with this tag:', string STOP 'program terminated by assert_eqn' END IF - END FUNCTION assert_eqn +} - SUBROUTINE nrerror(string) - CHARACTER (len=*), INTENT (IN) :: string +void nrerror(std::string string) { + printf("nrerror: %s", string); + printf("program terminated by nerror"); + exit(1); +} - WRITE (*,*) 'nrerror: ', string - STOP 'program terminated by nrerror' - END SUBROUTINE nrerror - FUNCTION arth_r(first,increment,n) - REAL (sp), INTENT (IN) :: first, increment - INTEGER (i4b), INTENT (IN) :: n - REAL (sp), DIMENSION (n) :: arth_r - INTEGER (i4b) :: k, k2 - REAL (sp) :: temp +double *arth_r(double first, double increment, int n) { + + int k, k2; + double temp; + double *arth_r = new double[n]; + if (n > 0) arth_r[0] = first; - IF (n>0) arth_r(1) = first IF (n<=npar_arth) THEN DO k = 2, n arth_r(k) = arth_r(k-1) + increment @@ -364,7 +367,7 @@ namespace nrutil { k = k2 END DO END IF - END FUNCTION arth_r +} FUNCTION arth_i(first,increment,n) INTEGER (i4b), INTENT (IN) :: first, increment, n diff --git a/src/output_utilities.F b/src/output_utilities.c similarity index 100% rename from src/output_utilities.F rename to src/output_utilities.c diff --git a/src/pair_potential.F b/src/pair_potential.c similarity index 100% rename from src/pair_potential.F rename to src/pair_potential.c diff --git a/src/parallel.F b/src/parallel.c similarity index 100% rename from src/parallel.F rename to src/parallel.c diff --git a/src/parallel_include.F b/src/parallel_include.c similarity index 100% rename from src/parallel_include.F rename to src/parallel_include.c diff --git a/src/parser.F b/src/parser.cpp similarity index 78% rename from src/parser.F rename to src/parser.cpp index 0f7ff30..f2415dd 100644 --- a/src/parser.F +++ b/src/parser.cpp @@ -1,117 +1,67 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! -!-----------------------------------------------------------------------------! -!!> F R E E - F O R M A T I N P U T R O U T I N E S ! -!! ! -!! Function INSCAN(iunit,label) : looks for an input dection started by ! -!! label un file associated with unit iunit ! -!! Subroutine READ_LINE(iunit) : reads an input line, physical end of lines ! -!! can be masked by a & character, no further ! -!! characters are alowed to the right ! -!! Function TEST_NEXT() : tests contains of next input field, return values! -!! are : E (blank); C (text); N (number); ! -!! K (bracket); S (! comment); X (&END); ! -!! O all other ! -!! Subroutine CFIELD(string,length) : extracts the next field from the ! -!! input line, at most length charcters ! -!! are returned in string, if length is 0 ! -!! the full field is returned, possible ! -!! field seperators are: blank, comma, ! -!! colon, semicolon, bracket, equal sign ! -!! Subroutine P_ERROR : writes out current input line and current position ! -!! within the line, does not stop code ! -!! Function GET_INT() : read an integer from the input line ! -!! Function GET_REAL() : read an real value from the input line ! -!! F R E E - F O R M A T I N P U T R O U T I N E S | +| | +| Function INSCAN(iunit,label) : looks for an input dection started by | +| label un file associated with unit iunit | +| Subroutine READ_LINE(iunit) : reads an input line, physical end of lines | +| can be masked by a & character, no further | +| characters are alowed to the right | +| Function TEST_NEXT() : tests contains of next input field, return values| +| are : E (blank); C (text); N (number); | +| K (bracket); S (! comment); X (&END); | +| O all other | +| Subroutine CFIELD(string,length) : extracts the next field from the | +| input line, at most length charcters | +| are returned in string, if length is 0 | +| the full field is returned, possible | +| field seperators are: blank, comma, | +| colon, semicolon, bracket, equal sign | +| Subroutine P_ERROR : writes out current input line and current position | +| within the line, does not stop code | +| Function GET_INT() : read an integer from the input line | +| Function GET_REAL() : read an real value from the input line | +| 0) THEN - CALL stop_parser ( 'parser_init','read error') - ELSE IF ( ios <0) THEN - ierr = 2 - EXIT - ELSE - CALL uppercase(line) - IF (index(line,label) /= 0 ) EXIT - END IF - END DO - END IF - END IF - IF ( parallel_io ) call mp_bcast(ierr,parenv%source,parenv%group) -END SUBROUTINE parser_init +/******************************************************************************/ + +void parser_init(std::string file_name, std::string label, FILE ierr, + global_environment_type *globenv) { + + std::string line; + FILE ios; + bool exists; + + // setup parameters for parallel parser + if (globenv) { + ionode = globenv->ionode; + parallel_io = true; + parenv = *globenv; + } else { + ionode = true; + parallel_io = false; + } + + if (ionode) { + //..find a not associated unit + iunit = get_unit(); + line = blank; + } + +} !****************************************************************************** diff --git a/src/parser.h b/src/parser.h new file mode 100644 index 0000000..af9848d --- /dev/null +++ b/src/parser.h @@ -0,0 +1,24 @@ +#ifndef _PARSER_H +#define _PARSER_H + +#ifdef __cplusplus +namespace CP2K_NS { +#include +#endif + + +const int max_line = 20; +std::string inp_line[max_line]; +int num_inp_line; +int p_line, p_har; +int iunit; +char newline = '&'; +char blank = ' '; + +bool parallel_io, ionode; + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/particle.h b/src/particle.h new file mode 100644 index 0000000..d807080 --- /dev/null +++ b/src/particle.h @@ -0,0 +1,36 @@ +#ifndef _PARTICLE_H +#define _PARTILCE_H + +#include "linklist.h" + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + + typedef struct particle_prop_type { + double charge; + double mass; + int ptype; + } particle_prop_type; + + typedef struct particle_type { + int iatom; + double r[3]; + double f[3]; + double v[3]; + particle_prop_type *prop; + cell_neighborlist_type *cell; + } particle_type; + + typedef struct particle_list_type { + int particle_index; + double *r; + double *charge; + particle_list_type *next; + } particle_list_type; + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/particle_lists.F b/src/particle_lists.c similarity index 100% rename from src/particle_lists.F rename to src/particle_lists.c diff --git a/src/particle_types.F b/src/particle_types.c similarity index 100% rename from src/particle_types.F rename to src/particle_types.c diff --git a/src/periodic_table.F b/src/periodic_table.c similarity index 100% rename from src/periodic_table.F rename to src/periodic_table.c diff --git a/src/physcon.F b/src/physcon.c similarity index 100% rename from src/physcon.F rename to src/physcon.c diff --git a/src/pme.F b/src/pme.c similarity index 100% rename from src/pme.F rename to src/pme.c diff --git a/src/pw.h b/src/pw.h new file mode 100644 index 0000000..657ab1a --- /dev/null +++ b/src/pw.h @@ -0,0 +1,79 @@ +#ifndef _PW_H +#define _PW_H + +#ifdef __cplusplus +namespace CP2K_NS { +#else +#include +#endif + + const int REALDATA1D = 301; + const int COMPLEXDATA1D = 302; + const int REALDATA3D = 303; + const int COMPLEXDATA3D = 304; + + const int NOSPACE = 371; + const int REALSPACE = 372; + const int RECIPROCALSPACE = 373; + + const int HALFSPACE = 211; + const int FULLSPACE = 212; + + + typedef struct map_pn { + int *pos; + int *neg; + } map_pn; + + typedef struct pw_grid_type { + int ngpts; // # grid points + int ngpts_cut; // # grid points within cutoff + int ndimension; // # of dimensions + int bounds[3][2]; // lower and upper bounds + int npts[3]; // # point in all directions + double dr[3]; // grid spacing + double dvol, vol; // volume element, volume + struct map_pn mapl, mapm, mapn; // mapping 1D => 3D + double **g; // grid point vectors + double *gsq; // squared vector lengths + int **g_hat; // grid point indices (Miller) + // int grid_kind // type of grid: equidistance, + // logarithmic, ... + int grid_span; // type of equidistance grid: + // is f^*(g) = f(-g) + + bool have_g0; // whether I have G = [0,0,0] + int first_gne0; // first g index /= 0 [1/2] + + int nglengths; // # different lengths/shells + double *glsq; // squared vector lengths + int *glidx; // index to the full arrays + } pw_grid_type; + + typedef struct pw_type { + double *cr; + double ***cr3d; + double *cc; + double ***cc3d; + pw_grid_type pw_grid; + int in_use; // Which data is used [r1d/c1d/r3d/c3d] + int in_space; // Real/Reciprocal space + + int group_id; // In which parallel group am I + bool group_head; // Whether I am the head of this group + int group_head_id; // The group id for the head of this group + } pw_type; + + typedef struct pw_grid_types { + int number; + } pw_grid_types; + + void pw_zero(pw_type); + void pw_allocate(pw_type, pw_grid_type, int); + void pw_deallocate(pw_type); + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/pw_grid_types.F b/src/pw_grid_types.c similarity index 100% rename from src/pw_grid_types.F rename to src/pw_grid_types.c diff --git a/src/pw_grids.F b/src/pw_grids.c similarity index 100% rename from src/pw_grids.F rename to src/pw_grids.c diff --git a/src/pw_types.F b/src/pw_types.F deleted file mode 100644 index d878594..0000000 --- a/src/pw_types.F +++ /dev/null @@ -1,175 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE pw_types - - USE kinds, ONLY : dbl - USE pw_grid_types, ONLY : pw_grid_type - USE stop_program, ONLY : stop_prg, stop_memory - - IMPLICIT NONE - - PRIVATE - PUBLIC :: pw_type, pw_allocate, pw_deallocate, pw_zero - PUBLIC :: REALDATA1D, COMPLEXDATA1D, REALDATA3D, COMPLEXDATA3D - PUBLIC :: NOSPACE, REALSPACE, RECIPROCALSPACE - - TYPE pw_type - REAL ( dbl ), DIMENSION ( : ), POINTER :: cr - REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: cr3d - COMPLEX ( dbl ), DIMENSION ( : ), POINTER :: cc - COMPLEX ( dbl ), DIMENSION ( :, :, : ), POINTER :: cc3d - - TYPE ( pw_grid_type ), POINTER :: pw_grid - - INTEGER :: in_use ! Which data is used [r1d/c1d/r3d/c3d] - INTEGER :: in_space ! Real/Reciprocal space - - INTEGER :: group_id ! In which parallel group am I - LOGICAL :: group_head ! Whether I am the head of this group - INTEGER :: group_head_id ! The group id for the head of this group - END TYPE pw_type - - !! Flags for the structure member 'in_use' - INTEGER, PARAMETER :: REALDATA1D = 301, COMPLEXDATA1D = 302 - INTEGER, PARAMETER :: REALDATA3D = 303, COMPLEXDATA3D = 304 - - !! Flags for the structure member 'in_space' - INTEGER, PARAMETER :: NOSPACE = 371, REALSPACE = 372, RECIPROCALSPACE = 373 - -CONTAINS - -!****************************************************************************** - -SUBROUTINE pw_allocate ( pw, pw_grid, use_data ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: use_data - TYPE ( pw_grid_type ), INTENT ( IN ), TARGET :: pw_grid - TYPE ( pw_type ), INTENT ( INOUT ), TARGET :: pw - -! Locals - INTEGER :: allocstat - INTEGER, DIMENSION ( :, : ), POINTER :: bounds - -!------------------------------------------------------------------------------ - - pw % in_use = use_data - pw % pw_grid => pw_grid - pw % in_space = NOSPACE - bounds => pw % pw_grid % bounds - - NULLIFY ( pw % cr, pw % cc, pw % cr3d, pw % cc3d ) - - IF ( use_data == REALDATA1D ) THEN - ALLOCATE ( pw % cr ( pw % pw_grid % ngpts_cut ), STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_memory ( "pw_allocate", "cr", pw % pw_grid % ngpts_cut ) - END IF - - ELSE IF ( use_data == COMPLEXDATA1D ) THEN - ALLOCATE ( pw % cc ( pw % pw_grid % ngpts_cut ), STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_memory ( "pw_allocate", "cc", pw % pw_grid % ngpts_cut ) - END IF - - ELSE IF ( use_data == REALDATA3D ) THEN - ALLOCATE ( pw % cr3d ( & - bounds ( 1, 1 ) : bounds ( 2, 1 ), & - bounds ( 1, 2 ) : bounds ( 2, 2 ), & - bounds ( 1, 3 ) : bounds ( 2, 3 ) ), STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_memory ( "pw_allocate", "cr3d", 0 ) - END IF - - ELSE IF ( use_data == COMPLEXDATA3D ) THEN - ALLOCATE ( pw % cc3d ( & - bounds ( 1, 1 ) : bounds ( 2, 1 ), & - bounds ( 1, 2 ) : bounds ( 2, 2 ), & - bounds ( 1, 3 ) : bounds ( 2, 3 ) ), STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_memory ( "pw_allocate", "cc3d", 0 ) - END IF - - ELSE - CALL stop_prg ( "pw_allocate", "no possible data field" ) - END IF - -END SUBROUTINE pw_allocate - -!****************************************************************************** - -SUBROUTINE pw_deallocate ( pw ) - - IMPLICIT NONE - -! Arguments - TYPE ( pw_type ), INTENT ( INOUT ) :: pw - -! Locals - INTEGER :: allocstat - -!------------------------------------------------------------------------------ - - IF ( pw % in_use == REALDATA1D ) THEN - DEALLOCATE ( pw % cr, STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_memory ( "pw_deallocate", "cr" ) - END IF - ELSE IF ( pw % in_use == COMPLEXDATA1D ) THEN - DEALLOCATE ( pw % cc, STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_memory ( "pw_deallocate", "cc" ) - END IF - ELSE IF ( pw % in_use == REALDATA3D ) THEN - DEALLOCATE ( pw % cr3d, STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_memory ( "pw_deallocate", "cr3d" ) - END IF - ELSE IF ( pw % in_use == COMPLEXDATA3D ) THEN - DEALLOCATE ( pw % cc3d, STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_memory ( "pw_deallocate", "cc3d" ) - END IF - ELSE - CALL stop_prg ( "pw_deallocate", "no possible data field" ) - END IF - -END SUBROUTINE pw_deallocate - -!****************************************************************************** - -SUBROUTINE pw_zero ( pw ) - - IMPLICIT NONE - -! Arguments - TYPE ( pw_type ), INTENT ( INOUT ) :: pw - -!------------------------------------------------------------------------------ - - IF ( pw % in_use == REALDATA1D ) THEN - pw % cr = 0.0_dbl - ELSE IF ( pw % in_use == COMPLEXDATA1D ) THEN - pw % cc = 0.0_dbl - ELSE IF ( pw % in_use == REALDATA3D ) THEN - pw % cr3d = 0.0_dbl - ELSE IF ( pw % in_use == COMPLEXDATA3D ) THEN - pw % cc3d = 0.0_dbl - ELSE - CALL stop_prg ( "pw_zero", "no possible data field" ) - END IF - -END SUBROUTINE pw_zero - -!****************************************************************************** - - - -!****************************************************************************** - -END MODULE pw_types diff --git a/src/pw_types.cpp b/src/pw_types.cpp new file mode 100644 index 0000000..836c6c6 --- /dev/null +++ b/src/pw_types.cpp @@ -0,0 +1,67 @@ +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ + +#include +#include + +#include "pw.h" + +using namespace CP2K_NS; + +void pw_allocate(pw_type &pw, pw_grid_type &pw_grid, int use_data) { + + int *bounds; + + pw.in_use = use_data; + pw.pw_grid = pw_grid; + pw.in_space = NOSPACE; + bounds = pw.pw_grid->bounds[0]; + + pw.cr = nullptr; + pw.cc = nullptr; + pw.cr3d = nullptr; + pw.cc3d = nullptr; + + if (use_data == REALDATA1D) { + pw.cr = new double[pw.pw_grid->ngpts_cut]; + } else if (use_data == COMPLEXDATA1D) { + pw.cc = new std::complex [pw.pw_grid->ngpts_cut]; + } else if (use_data == REALDATA3D) { + pw.cr3d = new double[bounds[1] - bounds[0] + 1][bounds[3] - bounds[2] + 1][bounds[5] - bounds[4] + 1]; + } else if (use_data == COMPLEXDATA3D) { + pw.cc3d = new std::complex [bounds[1] - bounds[0] + 1][bounds[3] - bounds[2] + 1][bounds[5] - bounds[4] + 1]; + } else { + stop_prg("pw_allocate", "no possible data field"); + } +} + +void pw_deallocate(pw_type pw) { + + if (pw.in_use == REALDATA1D) { + delete pw.cr; + } else if (pw.in_use == COMPLEXDATA1D) { + delete pw.cc; + } else if (pw.in_use == REALDATA3D) { + delete pw.cr3d; + } else if (pw.in_use == COMPLEXDATA3D) { + delete pw.cc3d; + } else { + stop_prg("pw_deallocate", "no possible data field"); + } +} + +void pw_zero(pw_type pw) { + if (pw.in_use == REALDATA1D) { + pw.cr[0] = 0.0; + } else if (pw.in_use == COMPLEXDATA1D) { + pw.cc[0] = 0.0; + } else if (pw.in_use == REALDATA3D) { + pw.cr3d[0][0][0].push_back(0.0); + } else if (pw.in_use == COMPLEXDATA3D) { + pw.cc3d[0][0][0].push_back(0.0); + } else { + stop_prg("pw_zero", "no possible data field"); + } +} \ No newline at end of file diff --git a/src/pws.F b/src/pws.c similarity index 100% rename from src/pws.F rename to src/pws.c diff --git a/src/simulation.h b/src/simulation.h new file mode 100644 index 0000000..f802964 --- /dev/null +++ b/src/simulation.h @@ -0,0 +1,19 @@ +#ifndef _SIMULATION_H +#define _SIMULATION_H + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + + typedef struct cell_type { + double hmat[3][3]; + double h_inv[3][3]; + double deth; + int perd[3]; + } cell_type; + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/simulation_cell.F b/src/simulation_cell.c similarity index 100% rename from src/simulation_cell.F rename to src/simulation_cell.c diff --git a/src/slater_koster.F b/src/slater_koster.c similarity index 100% rename from src/slater_koster.F rename to src/slater_koster.c diff --git a/src/slater_koster_matr.c b/src/slater_koster_matr.c index 31dd696..6c14142 100644 --- a/src/slater_koster_matr.c +++ b/src/slater_koster_matr.c @@ -1,6 +1,6 @@ /*----------------------------------------------------------------------------*/ /* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2000 CP2K developers group */ +/* Copyright (C) 2024 CP2K developers group */ /*----------------------------------------------------------------------------*/ //> Calculation of two-center s-f Slater-Koster integrals // A.K. McMahan, Phys. Rev. B, 58, p4293 (1998) diff --git a/src/slater_koster_test.F b/src/slater_koster_test.F deleted file mode 100644 index ae52a73..0000000 --- a/src/slater_koster_test.F +++ /dev/null @@ -1,1689 +0,0 @@ -!------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!------------------------------------------------------------------------------! -! Test for Slater-Koster matrices -! - MODULE slater_koster_test -!------------------------------------------------------------------------------! - USE kinds, ONLY : dbl - USE slater_koster_util, ONLY : dpro - USE slater_koster_matr, ONLY : gmat, dgmat -! - IMPLICIT NONE -! - PRIVATE - PUBLIC :: sk_test, dsk_test -! -!------------------------------------------------------------------------------! -! - CONTAINS -! -!------------------------------------------------------------------------------! - SUBROUTINE sk_test(l1,l2,emax) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (OUT) :: emax - REAL (dbl) :: r1(3), r2(3), rr, chi - REAL (dbl) :: gmu1(0:6,0:6,0:3), gmu2(0:6,0:6,0:3) - REAL (dbl) :: dll1(0:6,0:6,0:6), dll2(0:6,0:6,0:6) - INTEGER :: lm, lu - - CALL random_number(r1) - rr = dot_product(r1,r1) - r1 = r1/sqrt(rr) - CALL random_number(r2) - rr = dot_product(r2,r2) - r2 = r2/sqrt(rr) - chi = dot_product(r1,r2) - - gmu1 = 0._dbl - gmu2 = 0._dbl - dll1 = 0._dbl - dll2 = 0._dbl - CALL gmat(l1,l2,r1,gmu1,dll1) - CALL gmat(l1,l2,r2,gmu2,dll2) - - emax = 0._dbl - lm = max(l1,l2) - lu = min(l1,l2) - SELECT CASE (lu) - CASE (0) - CALL s_test(chi,gmu1,gmu2,l1,l2,emax) - CASE (1) - CALL p_test(chi,gmu1,gmu2,dll1,dll2,l1,l2,emax) - CASE (2) - CALL d_test(chi,gmu1,gmu2,dll1,dll2,l1,l2,emax) - CASE (3) - CALL f_test(chi,gmu1,gmu2,dll1,dll2,l1,l2,emax) - END SELECT - - END SUBROUTINE sk_test -!------------------------------------------------------------------------------! - SUBROUTINE dsk_test(l1,l2,emax) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (OUT) :: emax - REAL (dbl) :: r1(3), r2(3), rr, chi - REAL (dbl) :: dchi1(3), dchi2(3) - REAL (dbl) :: gmu1(0:6,0:6,0:3), gmu2(0:6,0:6,0:3) - REAL (dbl) :: dgmu1(0:6,0:6,0:3,1:3), dgmu2(0:6,0:6,0:3,1:3) - REAL (dbl) :: dll1(0:6,0:6,0:6), dll2(0:6,0:6,0:6) - REAL (dbl) :: ddll1(0:6,0:6,0:6,1:3), ddll2(0:6,0:6,0:6,1:3) - INTEGER :: lm, lu - - CALL random_number(r1) - rr = dot_product(r1,r1) - r1 = r1/sqrt(rr) - CALL random_number(r2) - rr = dot_product(r2,r2) - r2 = r2/sqrt(rr) - chi = dot_product(r1,r2) - dchi1(1) = r2(1) - r1(1)*chi - dchi1(2) = r2(2) - r1(2)*chi - dchi1(3) = r2(3) - r1(3)*chi - dchi2(1) = r1(1) - r2(1)*chi - dchi2(2) = r1(2) - r2(2)*chi - dchi2(3) = r1(3) - r2(3)*chi - - gmu1 = 0._dbl - gmu2 = 0._dbl - dll1 = 0._dbl - dll2 = 0._dbl - dgmu1 = 0._dbl - dgmu2 = 0._dbl - ddll1 = 0._dbl - ddll2 = 0._dbl - CALL gmat(l1,l2,r1,gmu1,dll1) - CALL gmat(l1,l2,r2,gmu2,dll2) - CALL dgmat(l1,l2,r1,dgmu1,ddll1) - CALL dgmat(l1,l2,r2,dgmu2,ddll2) - - emax = 0._dbl - lm = max(l1,l2) - lu = min(l1,l2) - SELECT CASE (lu) - CASE (0) - CALL ds_test(chi,dchi1,dchi2,gmu1,gmu2,dgmu1,dgmu2,l1,l2,emax) - CASE (1) - CALL dp_test(chi,dchi1,dchi2,gmu1,gmu2,dgmu1,dgmu2, & - dll1,dll2,ddll1,ddll2,l1,l2,emax) - CASE (2) - CALL dd_test(chi,dchi1,dchi2,gmu1,gmu2,dgmu1,dgmu2, & - dll1,dll2,ddll1,ddll2,l1,l2,emax) - CASE (3) - CALL df_test(chi,dchi1,dchi2,gmu1,gmu2,dgmu1,dgmu2, & - dll1,dll2,ddll1,ddll2,l1,l2,emax) - END SELECT - - END SUBROUTINE dsk_test -!------------------------------------------------------------------------------! - SUBROUTINE s_test(chi,gmu1,gmu2,l1,l2,emax) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (OUT) :: emax - REAL (dbl), INTENT (IN) :: chi - REAL (dbl), INTENT (IN) :: gmu1(0:6,0:6,0:3), gmu2(0:6,0:6,0:3) - REAL (dbl) :: xt - INTEGER :: lm, lu - - lm = max(l1,l2) - lu = min(l1,l2) - xt = dpro(gmu1(:,:,0),gmu2(:,:,0),l1,l2) - SELECT CASE (lm) - CASE (0) - xt = abs(xt - 1._dbl) - CASE (1) - xt = abs(xt - chi) - CASE (2) - xt = abs(xt - 0.5_dbl*(3._dbl*chi*chi-1._dbl)) - CASE (3) - xt = abs(xt - 0.5_dbl*(5._dbl*chi*chi-3._dbl)*chi) - END SELECT - IF (xt>1.E-12) WRITE (*,*) ' Error in test for gmu ', l1, l2, xt - emax = max(emax,xt) - END SUBROUTINE s_test - - SUBROUTINE p_test(chi,gmu1,gmu2,dll1,dll2,l1,l2,emax) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (OUT) :: emax - REAL (dbl), INTENT (IN) :: chi - REAL (dbl), INTENT (IN) :: gmu1(0:6,0:6,0:3), gmu2(0:6,0:6,0:3) - REAL (dbl), INTENT (IN) :: dll1(0:6,0:6,0:6), dll2(0:6,0:6,0:6) - REAL (dbl) :: xt1, xt2, xt3 - REAL (dbl) :: dt1, dt2, dt3 - INTEGER :: lm, lu - - lm = max(l1,l2) - lu = min(l1,l2) - xt1 = dpro(gmu1(:,:,0),gmu2(:,:,0),l1,l2) - xt2 = dpro(gmu1(:,:,0),gmu2(:,:,1),l1,l2) - xt3 = dpro(gmu1(:,:,1),gmu2(:,:,1),l1,l2) - SELECT CASE (lm) - CASE (1) - xt1 = abs(xt1 - chi*chi) - xt2 = abs(xt2 - (1._dbl-chi*chi)) - xt3 = abs(xt3 - (1._dbl+chi*chi)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 ', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 ', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 ', l1, l2, xt3 - emax = max(emax,xt1,xt2,xt3) - dt1 = dpro(dll1(:,:,0),dll2(:,:,0),l1,l2) - dt2 = dpro(dll1(:,:,0),dll2(:,:,2),l1,l2) - dt3 = dpro(dll1(:,:,2),dll2(:,:,2),l1,l2) - dt1 = abs(dt1-3._dbl) - dt2 = abs(dt2-1._dbl) - dt3 = abs(dt3-chi*chi) - IF (dt1>1.E-12) WRITE (*,*) ' Error in test for dll #1 ', l1, l2, dt1 - IF (dt2>1.E-12) WRITE (*,*) ' Error in test for dll #2 ', l1, l2, dt2 - IF (dt3>1.E-12) WRITE (*,*) ' Error in test for dll #3 ', l1, l2, dt3 - emax = max(emax,dt1,dt2,dt3) - CASE (2) - xt1 = abs(xt1 - 0.5_dbl*chi*(3._dbl*chi*chi-1._dbl)) - xt2 = abs(xt2 + sqrt(3._dbl)*chi*(chi*chi-1._dbl)) - xt3 = abs(xt3 - 2._dbl*chi*chi*chi) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 ', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 ', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 ', l1, l2, xt3 - emax = max(emax,xt1,xt2,xt3) - dt1 = dpro(dll1(:,:,1),dll2(:,:,1),l1,l2) - dt2 = dpro(dll1(:,:,1),dll2(:,:,3),l1,l2) - dt3 = dpro(dll1(:,:,3),dll2(:,:,3),l1,l2) - dt1 = abs(dt1-10._dbl/3._dbl*chi) - dt2 = abs(dt2-2._dbl*chi/sqrt(3._dbl)) - dt3 = abs(dt3-0.5_dbl*chi*(3._dbl*chi*chi-1._dbl)) - IF (dt1>1.E-12) WRITE (*,*) ' Error in test for dll #1 ', l1, l2, dt1 - IF (dt2>1.E-12) WRITE (*,*) ' Error in test for dll #2 ', l1, l2, dt2 - IF (dt3>1.E-12) WRITE (*,*) ' Error in test for dll #3 ', l1, l2, dt3 - emax = max(emax,dt1,dt2,dt3) - CASE (3) - xt1 = abs(xt1 - 0.5_dbl*(5._dbl*chi*chi-3._dbl)*chi*chi) - xt2 = abs(xt2 + sqrt(0.375_dbl)*(5._dbl*chi*chi-1._dbl)*(chi*chi- & - 1._dbl)) - xt3 = abs(xt3 - 0.25_dbl*(15._dbl*chi*chi*chi*chi-6._dbl*chi*chi- & - 1._dbl)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 ', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 ', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 ', l1, l2, xt3 - emax = max(emax,xt1,xt2,xt3) - dt1 = dpro(dll1(:,:,2),dll2(:,:,2),l1,l2) - dt2 = dpro(dll1(:,:,2),dll2(:,:,4),l1,l2) - dt3 = dpro(dll1(:,:,4),dll2(:,:,4),l1,l2) - dt1 = abs(dt1-7._dbl*(3._dbl*chi*chi-1._dbl)) - dt2 = abs(dt2-sqrt(1.5_dbl)*(3._dbl*chi*chi-1._dbl)) - dt3 = abs(dt3-0.5_dbl*chi*chi*(5._dbl*chi*chi-3._dbl)) - IF (dt1>1.E-12) WRITE (*,*) ' Error in test for dll #1 ', l1, l2, dt1 - IF (dt2>1.E-12) WRITE (*,*) ' Error in test for dll #2 ', l1, l2, dt2 - IF (dt3>1.E-12) WRITE (*,*) ' Error in test for dll #3 ', l1, l2, dt3 - emax = max(emax,dt1,dt2,dt3) - END SELECT - END SUBROUTINE p_test - - SUBROUTINE d_test(chi,gmu1,gmu2,dll1,dll2,l1,l2,emax) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (OUT) :: emax - REAL (dbl), INTENT (IN) :: chi - REAL (dbl), INTENT (IN) :: gmu1(0:6,0:6,0:3), gmu2(0:6,0:6,0:3) - REAL (dbl), INTENT (IN) :: dll1(0:6,0:6,0:6), dll2(0:6,0:6,0:6) - REAL (dbl) :: xt1, xt2, xt3, xt4, xt5, xt6 - REAL (dbl) :: dt1, dt2, dt3, dt4, dt5, dt6 - REAL (dbl) :: c2, c4 - INTEGER :: lm, lu - - lm = max(l1,l2) - lu = min(l1,l2) - xt1 = dpro(gmu1(:,:,0),gmu2(:,:,0),l1,l2) - xt2 = dpro(gmu1(:,:,0),gmu2(:,:,1),l1,l2) - xt3 = dpro(gmu1(:,:,0),gmu2(:,:,2),l1,l2) - xt4 = dpro(gmu1(:,:,1),gmu2(:,:,1),l1,l2) - xt5 = dpro(gmu1(:,:,1),gmu2(:,:,2),l1,l2) - xt6 = dpro(gmu1(:,:,2),gmu2(:,:,2),l1,l2) - SELECT CASE (lm) - CASE (2) - c2 = chi*chi - c4 = c2*c2 - xt1 = abs(xt1 - 0.25_dbl*(3._dbl*c2-1._dbl)**2) - xt2 = abs(xt2 + 3._dbl*c2*(c2-1._dbl)) - xt3 = abs(xt3 - 0.75_dbl*(c2-1._dbl)**2) - xt4 = abs(xt4 - (4._dbl*c4-3._dbl*c2+1._dbl)) - xt5 = abs(xt5 - (-c4+1._dbl)) - xt6 = abs(xt6 - 0.25_dbl*(c4+6._dbl*c2+1._dbl)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 ', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 ', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 ', l1, l2, xt3 - IF (xt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 ', l1, l2, xt4 - IF (xt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 ', l1, l2, xt5 - IF (xt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 ', l1, l2, xt6 - emax = max(emax,xt1,xt2,xt3,xt4,xt5,xt6) - dt1 = dpro(dll1(:,:,0),dll2(:,:,0),l1,l2) - dt2 = dpro(dll1(:,:,0),dll2(:,:,2),l1,l2) - dt3 = dpro(dll1(:,:,0),dll2(:,:,4),l1,l2) - dt4 = dpro(dll1(:,:,2),dll2(:,:,2),l1,l2) - dt5 = dpro(dll1(:,:,2),dll2(:,:,4),l1,l2) - dt6 = dpro(dll1(:,:,4),dll2(:,:,4),l1,l2) - dt1 = abs(dt1-5._dbl) - dt2 = abs(dt2+5._dbl/3._dbl) - dt3 = abs(dt3-1._dbl) - dt4 = abs(dt4-1._dbl/9._dbl*(21._dbl*c2-2._dbl)) - dt5 = abs(dt5-1._dbl/3._dbl*(3._dbl*c2-2._dbl)) - dt6 = abs(dt6-1._dbl/4._dbl*(3._dbl*c2-1._dbl)**2) - IF (dt1>1.E-12) WRITE (*,*) ' Error in test for dll #1 ', l1, l2, dt1 - IF (dt2>1.E-12) WRITE (*,*) ' Error in test for dll #2 ', l1, l2, dt2 - IF (dt3>1.E-12) WRITE (*,*) ' Error in test for dll #3 ', l1, l2, dt3 - IF (dt4>1.E-12) WRITE (*,*) ' Error in test for dll #4 ', l1, l2, dt4 - IF (dt5>1.E-12) WRITE (*,*) ' Error in test for dll #5 ', l1, l2, dt5 - IF (dt6>1.E-12) WRITE (*,*) ' Error in test for dll #6 ', l1, l2, dt6 - emax = max(emax,dt1,dt2,dt3,dt4,dt5,dt6) - CASE (3) - c2 = chi*chi - c4 = c2*c2 - xt1 = abs(xt1 - 0.25_dbl*(5._dbl*c2-3._dbl)*(3._dbl*c2-1._dbl)*chi) - xt2 = abs(xt2 + 3._dbl/sqrt(8._dbl)*(5._dbl*c2-1._dbl)*(c2-1._dbl)*chi) - xt3 = abs(xt3 - sqrt(45._dbl)/4._dbl*chi*(c2-1._dbl)**2) - xt4 = abs(xt4 - 0.5_dbl*(15._dbl*c4-16._dbl*c2+5._dbl)*chi) - xt5 = abs(xt5 + sqrt(0.625_dbl)*(3._dbl*c2+1._dbl)*(c2-1._dbl)*chi) - xt6 = abs(xt6 - 0.25_dbl*(3._dbl*c4+10._dbl*c2-5._dbl)*chi) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 ', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 ', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 ', l1, l2, xt3 - IF (xt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 ', l1, l2, xt4 - IF (xt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 ', l1, l2, xt5 - IF (xt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 ', l1, l2, xt6 - emax = max(emax,xt1,xt2,xt3,xt4,xt5,xt6) - dt1 = dpro(dll1(:,:,1),dll2(:,:,1),l1,l2) - dt2 = dpro(dll1(:,:,1),dll2(:,:,3),l1,l2) - dt3 = dpro(dll1(:,:,1),dll2(:,:,5),l1,l2) - dt4 = dpro(dll1(:,:,3),dll2(:,:,3),l1,l2) - dt5 = dpro(dll1(:,:,3),dll2(:,:,5),l1,l2) - dt6 = dpro(dll1(:,:,5),dll2(:,:,5),l1,l2) - dt1 = abs(dt1-17.5_dbl*chi) - dt2 = abs(dt2+3.5_dbl*chi) - dt3 = abs(dt3-3._dbl/sqrt(2._dbl)*chi) - dt4 = abs(dt4-0.5_dbl*(24._dbl*c2-13._dbl)*chi) - dt5 = abs(dt5-1._dbl/sqrt(2._dbl)*chi*(4._dbl*c2-3._dbl)) - dt6 = abs(dt6-0.25_dbl*chi*(5._dbl*c2-3._dbl)*(3._dbl*c2-1._dbl)) - IF (dt1>1.E-12) WRITE (*,*) ' Error in test for dll #1 ', l1, l2, dt1 - IF (dt2>1.E-12) WRITE (*,*) ' Error in test for dll #2 ', l1, l2, dt2 - IF (dt3>1.E-12) WRITE (*,*) ' Error in test for dll #3 ', l1, l2, dt3 - IF (dt4>1.E-12) WRITE (*,*) ' Error in test for dll #4 ', l1, l2, dt4 - IF (dt5>1.E-12) WRITE (*,*) ' Error in test for dll #5 ', l1, l2, dt5 - IF (dt6>1.E-12) WRITE (*,*) ' Error in test for dll #6 ', l1, l2, dt6 - emax = max(emax,dt1,dt2,dt3,dt4,dt5,dt6) - END SELECT - END SUBROUTINE d_test - - SUBROUTINE f_test(chi,gmu1,gmu2,dll1,dll2,l1,l2,emax) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (OUT) :: emax - REAL (dbl), INTENT (IN) :: chi - REAL (dbl), INTENT (IN) :: gmu1(0:6,0:6,0:3), gmu2(0:6,0:6,0:3) - REAL (dbl), INTENT (IN) :: dll1(0:6,0:6,0:6), dll2(0:6,0:6,0:6) - REAL (dbl) :: xt1, xt2, xt3, xt4, xt5, xt6, xt7, xt8, xt9, xt0 - REAL (dbl) :: dt1, dt2, dt3, dt4, dt5, dt6, dt7, dt8, dt9, dt0 - REAL (dbl) :: c2, c4, c6 - INTEGER :: lm, lu - - lm = max(l1,l2) - lu = min(l1,l2) - xt1 = dpro(gmu1(:,:,0),gmu2(:,:,0),l1,l2) - xt2 = dpro(gmu1(:,:,0),gmu2(:,:,1),l1,l2) - xt3 = dpro(gmu1(:,:,0),gmu2(:,:,2),l1,l2) - xt4 = dpro(gmu1(:,:,0),gmu2(:,:,3),l1,l2) - xt5 = dpro(gmu1(:,:,1),gmu2(:,:,1),l1,l2) - xt6 = dpro(gmu1(:,:,1),gmu2(:,:,2),l1,l2) - xt7 = dpro(gmu1(:,:,1),gmu2(:,:,3),l1,l2) - xt8 = dpro(gmu1(:,:,2),gmu2(:,:,2),l1,l2) - xt9 = dpro(gmu1(:,:,2),gmu2(:,:,3),l1,l2) - xt0 = dpro(gmu1(:,:,3),gmu2(:,:,3),l1,l2) - c2 = chi*chi - c4 = c2*c2 - c6 = c4*c2 - xt1 = abs(xt1 - 0.25_dbl*(5._dbl*c2-3._dbl)**2*c2) - xt2 = abs(xt2 + 0.375_dbl*(5._dbl*c2-1._dbl)**2*(c2-1._dbl)) - xt3 = abs(xt3 - 3.75_dbl*c2*(c2-1._dbl)**2) - xt4 = abs(xt4 + 0.625_dbl*(c2-1._dbl)**3) - xt5 = abs(xt5 - 0.0625_dbl*(225._dbl*c6-305._dbl*c4+111._dbl*c2+1._dbl)) - xt6 = abs(xt6 + 0.625_dbl*(9._dbl*c4-2._dbl*c2+1._dbl)*(c2-1._dbl)) - xt7 = abs(xt7 - 0.9375_dbl*(c2+1._dbl)*(c2-1._dbl)**2) - xt8 = abs(xt8 - 0.25_dbl*(9._dbl*c6+10._dbl*c4-15._dbl*c2+4._dbl)) - xt9 = abs(xt9 + 0.375_dbl*(c4+6._dbl*c2+1._dbl)*(c2-1._dbl)) - xt0 = abs(xt0 - 0.0625_dbl*(c4+14._dbl*c2+1._dbl)*(c2+1._dbl)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 ', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 ', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 ', l1, l2, xt3 - IF (xt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 ', l1, l2, xt4 - IF (xt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 ', l1, l2, xt5 - IF (xt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 ', l1, l2, xt6 - IF (xt7>1.E-12) WRITE (*,*) ' Error in test for gmu #7 ', l1, l2, xt7 - IF (xt8>1.E-12) WRITE (*,*) ' Error in test for gmu #8 ', l1, l2, xt8 - IF (xt9>1.E-12) WRITE (*,*) ' Error in test for gmu #9 ', l1, l2, xt9 - IF (xt0>1.E-12) WRITE (*,*) ' Error in test for gmu #0 ', l1, l2, xt0 - emax = max(emax,xt1,xt2,xt3,xt4,xt5,xt6,xt7,xt8,xt9,xt0) - dt1 = dpro(dll1(:,:,0),dll2(:,:,0),l1,l2) - dt2 = dpro(dll1(:,:,0),dll2(:,:,2),l1,l2) - dt3 = dpro(dll1(:,:,0),dll2(:,:,4),l1,l2) - dt4 = dpro(dll1(:,:,0),dll2(:,:,6),l1,l2) - dt5 = dpro(dll1(:,:,2),dll2(:,:,2),l1,l2) - dt6 = dpro(dll1(:,:,2),dll2(:,:,4),l1,l2) - dt7 = dpro(dll1(:,:,2),dll2(:,:,6),l1,l2) - dt8 = dpro(dll1(:,:,4),dll2(:,:,4),l1,l2) - dt9 = dpro(dll1(:,:,4),dll2(:,:,6),l1,l2) - dt0 = dpro(dll1(:,:,6),dll2(:,:,6),l1,l2) - dt1 = abs(dt1-7._dbl) - dt2 = abs(dt2) - dt3 = abs(dt3+1.4_dbl) - dt4 = abs(dt4-1._dbl) - dt5 = abs(dt5-1.68_dbl*(3._dbl*c2-1._dbl)) - dt6 = abs(dt6-0.24_dbl*(3._dbl*c2-1._dbl)) - dt7 = abs(dt7-0.4_dbl*(3._dbl*c2-1._dbl)) - dt8 = abs(dt8-0.04_dbl*(220._dbl*c4-186._dbl*c2+25._dbl)) - dt9 = abs(dt9-0.6_dbl*(5._dbl*c2-4._dbl)*c2) - dt0 = abs(dt0-0.25_dbl*(5._dbl*c2-3._dbl)**2*c2) - IF (dt1>1.E-12) WRITE (*,*) ' Error in test for dll #1 ', l1, l2, dt1 - IF (dt2>1.E-12) WRITE (*,*) ' Error in test for dll #2 ', l1, l2, dt2 - IF (dt3>1.E-12) WRITE (*,*) ' Error in test for dll #3 ', l1, l2, dt3 - IF (dt4>1.E-12) WRITE (*,*) ' Error in test for dll #4 ', l1, l2, dt4 - IF (dt5>1.E-12) WRITE (*,*) ' Error in test for dll #5 ', l1, l2, dt5 - IF (dt6>1.E-12) WRITE (*,*) ' Error in test for dll #6 ', l1, l2, dt6 - IF (dt7>1.E-12) WRITE (*,*) ' Error in test for dll #7 ', l1, l2, dt7 - IF (dt8>1.E-12) WRITE (*,*) ' Error in test for dll #8 ', l1, l2, dt8 - IF (dt9>1.E-12) WRITE (*,*) ' Error in test for dll #9 ', l1, l2, dt9 - IF (dt0>1.E-12) WRITE (*,*) ' Error in test for dll #0 ', l1, l2, dt9 - IF (dt0>1.E-12) WRITE (*,*) ' Error in test for dll #0 ', l1, l2, dt0 - emax = max(emax,dt1,dt2,dt3,dt4,dt5,dt6,dt7,dt8,dt9,dt0) - END SUBROUTINE f_test -!------------------------------------------------------------------------------! - SUBROUTINE ds_test(chi,dchi1,dchi2,gmu1,gmu2,dgmu1,dgmu2,l1,l2,emax) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (OUT) :: emax - REAL (dbl), INTENT (IN) :: chi, dchi1(3), dchi2(3) - REAL (dbl), INTENT (IN) :: gmu1(0:6,0:6,0:3), gmu2(0:6,0:6,0:3) - REAL (dbl), INTENT (IN) :: dgmu1(0:6,0:6,0:3,1:3), dgmu2(0:6,0:6,0:3,1:3) - REAL (dbl) :: xt, yt, zt - INTEGER :: lm, lu - - emax = 0._dbl - lm = max(l1,l2) - lu = min(l1,l2) - xt = dpro(dgmu1(:,:,0,1),gmu2(:,:,0),l1,l2) - yt = dpro(dgmu1(:,:,0,2),gmu2(:,:,0),l1,l2) - zt = dpro(dgmu1(:,:,0,3),gmu2(:,:,0),l1,l2) - SELECT CASE (lm) - CASE (0) -! ds-s - CASE (1) -! ds-p - xt = abs(xt - dchi1(1)) - yt = abs(yt - dchi1(2)) - zt = abs(zt - dchi1(3)) - CASE (2) -! ds-d - xt = abs(xt - 3._dbl*chi*dchi1(1)) - yt = abs(yt - 3._dbl*chi*dchi1(2)) - zt = abs(zt - 3._dbl*chi*dchi1(3)) - CASE (3) -! ds-f - xt = abs(xt - 0.5_dbl*(15._dbl*chi*chi-3._dbl)*dchi1(1)) - yt = abs(yt - 0.5_dbl*(15._dbl*chi*chi-3._dbl)*dchi1(2)) - zt = abs(zt - 0.5_dbl*(15._dbl*chi*chi-3._dbl)*dchi1(3)) - END SELECT - IF (xt>1.E-12) WRITE (*,*) ' Error in test for dgmu x0 ', l1, l2, xt - IF (yt>1.E-12) WRITE (*,*) ' Error in test for dgmu y0 ', l1, l2, yt - IF (zt>1.E-12) WRITE (*,*) ' Error in test for dgmu z0 ', l1, l2, zt - emax = max(xt,yt,zt) - - xt = dpro(gmu1(:,:,0),dgmu2(:,:,0,1),l1,l2) - yt = dpro(gmu1(:,:,0),dgmu2(:,:,0,2),l1,l2) - zt = dpro(gmu1(:,:,0),dgmu2(:,:,0,3),l1,l2) - SELECT CASE (lm) - CASE (0) -! s-ds - CASE (1) -! s-dp - xt = abs(xt - dchi2(1)) - yt = abs(yt - dchi2(2)) - zt = abs(zt - dchi2(3)) - CASE (2) -! s-dd - xt = abs(xt - 3._dbl*chi*dchi2(1)) - yt = abs(yt - 3._dbl*chi*dchi2(2)) - zt = abs(zt - 3._dbl*chi*dchi2(3)) - CASE (3) -! s-df - xt = abs(xt - 0.5_dbl*(15._dbl*chi*chi-3._dbl)*dchi2(1)) - yt = abs(yt - 0.5_dbl*(15._dbl*chi*chi-3._dbl)*dchi2(2)) - zt = abs(zt - 0.5_dbl*(15._dbl*chi*chi-3._dbl)*dchi2(3)) - END SELECT - IF (xt>1.E-12) WRITE (*,*) ' Error in test for dgmu 0x', l1, l2, xt - IF (yt>1.E-12) WRITE (*,*) ' Error in test for dgmu 0y', l1, l2, yt - IF (zt>1.E-12) WRITE (*,*) ' Error in test for dgmu 0z', l1, l2, zt - emax = max(emax,xt,yt,zt) - END SUBROUTINE ds_test - SUBROUTINE dp_test(chi,dchi1,dchi2,gmu1,gmu2,dgmu1,dgmu2, & - dll1,dll2,ddll1,ddll2,l1,l2,emax) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (OUT) :: emax - REAL (dbl), INTENT (IN) :: chi, dchi1(3), dchi2(3) - REAL (dbl), INTENT (IN) :: gmu1(0:6,0:6,0:3), gmu2(0:6,0:6,0:3) - REAL (dbl), INTENT (IN) :: dgmu1(0:6,0:6,0:3,1:3), dgmu2(0:6,0:6,0:3,1:3) - REAL (dbl), INTENT (IN) :: dll1(0:6,0:6,0:6), dll2(0:6,0:6,0:6) - REAL (dbl), INTENT (IN) :: ddll1(0:6,0:6,0:6,1:3), ddll2(0:6,0:6,0:6,1:3) - REAL (dbl) :: xt1, xt2, xt3 - REAL (dbl) :: yt1, yt2, yt3 - REAL (dbl) :: zt1, zt2, zt3 - REAL (dbl) :: dx1, dx2, dx3 - REAL (dbl) :: dy1, dy2, dy3 - REAL (dbl) :: dz1, dz2, dz3 - INTEGER :: lm, lu - - emax = 0._dbl - lm = max(l1,l2) - lu = min(l1,l2) - xt1 = dpro(dgmu1(:,:,0,1),gmu2(:,:,0),l1,l2) - xt2 = dpro(dgmu1(:,:,0,1),gmu2(:,:,1),l1,l2) - xt3 = dpro(dgmu1(:,:,1,1),gmu2(:,:,1),l1,l2) - yt1 = dpro(dgmu1(:,:,0,2),gmu2(:,:,0),l1,l2) - yt2 = dpro(dgmu1(:,:,0,2),gmu2(:,:,1),l1,l2) - yt3 = dpro(dgmu1(:,:,1,2),gmu2(:,:,1),l1,l2) - zt1 = dpro(dgmu1(:,:,0,3),gmu2(:,:,0),l1,l2) - zt2 = dpro(dgmu1(:,:,0,3),gmu2(:,:,1),l1,l2) - zt3 = dpro(dgmu1(:,:,1,3),gmu2(:,:,1),l1,l2) - SELECT CASE (lm) - CASE (1) -! dp-p - xt1 = abs(xt1 - 2._dbl*chi*dchi1(1)) - xt2 = abs(xt2 + 2._dbl*chi*dchi1(1)) - xt3 = abs(xt3 - 2._dbl*chi*dchi1(1)) - yt1 = abs(yt1 - 2._dbl*chi*dchi1(2)) - yt2 = abs(yt2 + 2._dbl*chi*dchi1(2)) - yt3 = abs(yt3 - 2._dbl*chi*dchi1(2)) - zt1 = abs(zt1 - 2._dbl*chi*dchi1(3)) - zt2 = abs(zt2 + 2._dbl*chi*dchi1(3)) - zt3 = abs(zt3 - 2._dbl*chi*dchi1(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 x0', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 x0', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 x0', l1, l2, xt3 - emax = max(emax,xt1,xt2,xt3) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 y0', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 y0', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 y0', l1, l2, yt3 - emax = max(emax,yt1,yt2,yt3) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 z0', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 z0', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 z0', l1, l2, zt3 - emax = max(emax,zt1,zt2,zt3) - dx1 = dpro(ddll1(:,:,0,1),dll2(:,:,0),l1,l2) - dx2 = dpro(ddll1(:,:,0,1),dll2(:,:,2),l1,l2) - dx3 = dpro(ddll1(:,:,2,1),dll2(:,:,2),l1,l2) - dy1 = dpro(ddll1(:,:,0,2),dll2(:,:,0),l1,l2) - dy2 = dpro(ddll1(:,:,0,2),dll2(:,:,2),l1,l2) - dy3 = dpro(ddll1(:,:,2,2),dll2(:,:,2),l1,l2) - dz1 = dpro(ddll1(:,:,0,3),dll2(:,:,0),l1,l2) - dz2 = dpro(ddll1(:,:,0,3),dll2(:,:,2),l1,l2) - dz3 = dpro(ddll1(:,:,2,3),dll2(:,:,2),l1,l2) - dx1 = abs(dx1) - dx2 = abs(dx2) - dx3 = abs(dx3-2._dbl*chi*dchi1(1)) - dy1 = abs(dy1) - dy2 = abs(dy2) - dy3 = abs(dy3-2._dbl*chi*dchi1(2)) - dz1 = abs(dz1) - dz2 = abs(dz2) - dz3 = abs(dz3-2._dbl*chi*dchi1(3)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 x0', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 x0', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 x0', l1, l2, dx3 - emax = max(emax,dx1,dx2,dx3) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 y0', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 y0', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 y0', l1, l2, dy3 - emax = max(emax,dy1,dy2,dy3) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 z0', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 z0', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 z0', l1, l2, dz3 - emax = max(emax,dz1,dz2,dz3) - CASE (2) -! dp-d - xt1 = abs(xt1 - 0.5_dbl*(9._dbl*chi*chi-1._dbl)*dchi1(1)) - xt2 = abs(xt2 + sqrt(3._dbl)*(3._dbl*chi*chi-1._dbl)*dchi1(1)) - xt3 = abs(xt3 - 6._dbl*chi*chi*dchi1(1)) - yt1 = abs(yt1 - 0.5_dbl*(9._dbl*chi*chi-1._dbl)*dchi1(2)) - yt2 = abs(yt2 + sqrt(3._dbl)*(3._dbl*chi*chi-1._dbl)*dchi1(2)) - yt3 = abs(yt3 - 6._dbl*chi*chi*dchi1(2)) - zt1 = abs(zt1 - 0.5_dbl*(9._dbl*chi*chi-1._dbl)*dchi1(3)) - zt2 = abs(zt2 + sqrt(3._dbl)*(3._dbl*chi*chi-1._dbl)*dchi1(3)) - zt3 = abs(zt3 - 6._dbl*chi*chi*dchi1(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 x0', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 x0', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 x0', l1, l2, xt3 - emax = max(emax,xt1,xt2,xt3) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 y0', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 y0', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 y0', l1, l2, yt3 - emax = max(emax,yt1,yt2,yt3) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 z0', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 z0', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 z0', l1, l2, zt3 - emax = max(emax,zt1,zt2,zt3) - dx1 = dpro(ddll1(:,:,1,1),dll2(:,:,1),l1,l2) - dx2 = dpro(ddll1(:,:,1,1),dll2(:,:,3),l1,l2) - dx3 = dpro(ddll1(:,:,3,1),dll2(:,:,3),l1,l2) - dy1 = dpro(ddll1(:,:,1,2),dll2(:,:,1),l1,l2) - dy2 = dpro(ddll1(:,:,1,2),dll2(:,:,3),l1,l2) - dy3 = dpro(ddll1(:,:,3,2),dll2(:,:,3),l1,l2) - dz1 = dpro(ddll1(:,:,1,3),dll2(:,:,1),l1,l2) - dz2 = dpro(ddll1(:,:,1,3),dll2(:,:,3),l1,l2) - dz3 = dpro(ddll1(:,:,3,3),dll2(:,:,3),l1,l2) - dx1 = abs(dx1-10._dbl/3._dbl*dchi1(1)) - dx2 = abs(dx2-2._dbl*dchi1(1)/sqrt(3._dbl)) - dx3 = abs(dx3-0.5_dbl*dchi1(1)*(9._dbl*chi*chi-1._dbl)) - dy1 = abs(dy1-10._dbl/3._dbl*dchi1(2)) - dy2 = abs(dy2-2._dbl*dchi1(2)/sqrt(3._dbl)) - dy3 = abs(dy3-0.5_dbl*dchi1(2)*(9._dbl*chi*chi-1._dbl)) - dz1 = abs(dz1-10._dbl/3._dbl*dchi1(3)) - dz2 = abs(dz2-2._dbl*dchi1(3)/sqrt(3._dbl)) - dz3 = abs(dz3-0.5_dbl*dchi1(3)*(9._dbl*chi*chi-1._dbl)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 x0', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 x0', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 x0', l1, l2, dx3 - emax = max(emax,dx1,dx2,dx3) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 y0', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 y0', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 y0', l1, l2, dy3 - emax = max(emax,dy1,dy2,dy3) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 z0', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 z0', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 z0', l1, l2, dz3 - emax = max(emax,dz1,dz2,dz3) - CASE (3) -! dp-f - xt1 = abs(xt1 - (10._dbl*chi*chi-3._dbl)*chi*dchi1(1)) - xt2 = abs(xt2 + sqrt(0.375_dbl)*(20._dbl*chi*chi-12._dbl)*chi*dchi1(1)) - xt3 = abs(xt3 - (15._dbl*chi*chi-3._dbl)*chi*dchi1(1)) - yt1 = abs(yt1 - (10._dbl*chi*chi-3._dbl)*chi*dchi1(2)) - yt2 = abs(yt2 + sqrt(0.375_dbl)*(20._dbl*chi*chi-12._dbl)*chi*dchi1(2)) - yt3 = abs(yt3 - (15._dbl*chi*chi-3._dbl)*chi*dchi1(2)) - zt1 = abs(zt1 - (10._dbl*chi*chi-3._dbl)*chi*dchi1(3)) - zt2 = abs(zt2 + sqrt(0.375_dbl)*(20._dbl*chi*chi-12._dbl)*chi*dchi1(3)) - zt3 = abs(zt3 - (15._dbl*chi*chi-3._dbl)*chi*dchi1(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 x0', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 x0', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 x0', l1, l2, xt3 - emax = max(emax,xt1,xt2,xt3) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 y0', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 y0', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 y0', l1, l2, yt3 - emax = max(emax,yt1,yt2,yt3) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 z0', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 z0', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 z0', l1, l2, zt3 - emax = max(emax,zt1,zt2,zt3) - dx1 = dpro(ddll1(:,:,2,1),dll2(:,:,2),l1,l2) - dx2 = dpro(ddll1(:,:,2,1),dll2(:,:,4),l1,l2) - dx3 = dpro(ddll1(:,:,4,1),dll2(:,:,4),l1,l2) - dy1 = dpro(ddll1(:,:,2,2),dll2(:,:,2),l1,l2) - dy2 = dpro(ddll1(:,:,2,2),dll2(:,:,4),l1,l2) - dy3 = dpro(ddll1(:,:,4,2),dll2(:,:,4),l1,l2) - dz1 = dpro(ddll1(:,:,2,3),dll2(:,:,2),l1,l2) - dz2 = dpro(ddll1(:,:,2,3),dll2(:,:,4),l1,l2) - dz3 = dpro(ddll1(:,:,4,3),dll2(:,:,4),l1,l2) - dx1 = abs(dx1-42._dbl*chi*dchi1(1)) - dx2 = abs(dx2-sqrt(1.5_dbl)*6._dbl*chi*dchi1(1)) - dx3 = abs(dx3-chi*dchi1(1)*(10._dbl*chi*chi-3._dbl)) - dy1 = abs(dy1-42._dbl*chi*dchi1(2)) - dy2 = abs(dy2-sqrt(1.5_dbl)*6._dbl*chi*dchi1(2)) - dy3 = abs(dy3-chi*dchi1(2)*(10._dbl*chi*chi-3._dbl)) - dz1 = abs(dz1-42._dbl*chi*dchi1(3)) - dz2 = abs(dz2-sqrt(1.5_dbl)*6._dbl*chi*dchi1(3)) - dz3 = abs(dz3-chi*dchi1(3)*(10._dbl*chi*chi-3._dbl)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 x0', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 x0', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 x0', l1, l2, dx3 - emax = max(emax,dx1,dx2,dx3) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 y0', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 y0', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 y0', l1, l2, dy3 - emax = max(emax,dy1,dy2,dy3) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 z0', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 z0', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 z0', l1, l2, dz3 - emax = max(emax,dz1,dz2,dz3) - END SELECT - xt1 = dpro(gmu1(:,:,0),dgmu2(:,:,0,1),l1,l2) - xt2 = dpro(gmu1(:,:,0),dgmu2(:,:,1,1),l1,l2) - xt3 = dpro(gmu1(:,:,1),dgmu2(:,:,1,1),l1,l2) - yt1 = dpro(gmu1(:,:,0),dgmu2(:,:,0,2),l1,l2) - yt2 = dpro(gmu1(:,:,0),dgmu2(:,:,1,2),l1,l2) - yt3 = dpro(gmu1(:,:,1),dgmu2(:,:,1,2),l1,l2) - zt1 = dpro(gmu1(:,:,0),dgmu2(:,:,0,3),l1,l2) - zt2 = dpro(gmu1(:,:,0),dgmu2(:,:,1,3),l1,l2) - zt3 = dpro(gmu1(:,:,1),dgmu2(:,:,1,3),l1,l2) - SELECT CASE (lm) - CASE (1) -! p-dp - xt1 = abs(xt1 - 2._dbl*chi*dchi2(1)) - xt2 = abs(xt2 + 2._dbl*chi*dchi2(1)) - xt3 = abs(xt3 - 2._dbl*chi*dchi2(1)) - yt1 = abs(yt1 - 2._dbl*chi*dchi2(2)) - yt2 = abs(yt2 + 2._dbl*chi*dchi2(2)) - yt3 = abs(yt3 - 2._dbl*chi*dchi2(2)) - zt1 = abs(zt1 - 2._dbl*chi*dchi2(3)) - zt2 = abs(zt2 + 2._dbl*chi*dchi2(3)) - zt3 = abs(zt3 - 2._dbl*chi*dchi2(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0x', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0x', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0x', l1, l2, xt3 - emax = max(emax,xt1,xt2,xt3) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0y', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0y', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0y', l1, l2, yt3 - emax = max(emax,yt1,yt2,yt3) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0z', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0z', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0z', l1, l2, zt3 - emax = max(emax,zt1,zt2,zt3) - dx1 = dpro(dll1(:,:,0),ddll2(:,:,0,1),l1,l2) - dx2 = dpro(dll1(:,:,0),ddll2(:,:,2,1),l1,l2) - dx3 = dpro(dll1(:,:,2),ddll2(:,:,2,1),l1,l2) - dy1 = dpro(dll1(:,:,0),ddll2(:,:,0,2),l1,l2) - dy2 = dpro(dll1(:,:,0),ddll2(:,:,2,2),l1,l2) - dy3 = dpro(dll1(:,:,2),ddll2(:,:,2,2),l1,l2) - dz1 = dpro(dll1(:,:,0),ddll2(:,:,0,3),l1,l2) - dz2 = dpro(dll1(:,:,0),ddll2(:,:,2,3),l1,l2) - dz3 = dpro(dll1(:,:,2),ddll2(:,:,2,3),l1,l2) - dx1 = abs(dx1) - dx2 = abs(dx2) - dx3 = abs(dx3-2._dbl*chi*dchi2(1)) - dy1 = abs(dy1) - dy2 = abs(dy2) - dy3 = abs(dy3-2._dbl*chi*dchi2(2)) - dz1 = abs(dz1) - dz2 = abs(dz2) - dz3 = abs(dz3-2._dbl*chi*dchi2(3)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0x', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0x', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0x', l1, l2, dx3 - emax = max(emax,dx1,dx2,dx3) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0y', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0y', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0y', l1, l2, dy3 - emax = max(emax,dy1,dy2,dy3) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0z', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0z', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0z', l1, l2, dz3 - emax = max(emax,dz1,dz2,dz3) - CASE (2) -! p-dd - xt1 = abs(xt1 - 0.5_dbl*(9._dbl*chi*chi-1._dbl)*dchi2(1)) - xt2 = abs(xt2 + sqrt(3._dbl)*(3._dbl*chi*chi-1._dbl)*dchi2(1)) - xt3 = abs(xt3 - 6._dbl*chi*chi*dchi2(1)) - yt1 = abs(yt1 - 0.5_dbl*(9._dbl*chi*chi-1._dbl)*dchi2(2) ) - yt2 = abs(yt2 + sqrt(3._dbl)*(3._dbl*chi*chi-1._dbl)*dchi2(2)) - yt3 = abs(yt3 - 6._dbl*chi*chi*dchi2(2)) - zt1 = abs(zt1 - 0.5_dbl*(9._dbl*chi*chi-1._dbl)*dchi2(3) ) - zt2 = abs(zt2 + sqrt(3._dbl)*(3._dbl*chi*chi-1._dbl)*dchi2(3)) - zt3 = abs(zt3 - 6._dbl*chi*chi*dchi2(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0x', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0x', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0x', l1, l2, xt3 - emax = max(emax,xt1,xt2,xt3) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0y', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0y', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0y', l1, l2, yt3 - emax = max(emax,yt1,yt2,yt3) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0z', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0z', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0z', l1, l2, zt3 - emax = max(emax,zt1,zt2,zt3) - dx1 = dpro(dll1(:,:,1),ddll2(:,:,1,1),l1,l2) - dx2 = dpro(dll1(:,:,1),ddll2(:,:,3,1),l1,l2) - dx3 = dpro(dll1(:,:,3),ddll2(:,:,3,1),l1,l2) - dy1 = dpro(dll1(:,:,1),ddll2(:,:,1,2),l1,l2) - dy2 = dpro(dll1(:,:,1),ddll2(:,:,3,2),l1,l2) - dy3 = dpro(dll1(:,:,3),ddll2(:,:,3,2),l1,l2) - dz1 = dpro(dll1(:,:,1),ddll2(:,:,1,3),l1,l2) - dz2 = dpro(dll1(:,:,1),ddll2(:,:,3,3),l1,l2) - dz3 = dpro(dll1(:,:,3),ddll2(:,:,3,3),l1,l2) - dx1 = abs(dx1-10._dbl/3._dbl*dchi2(1)) - dx2 = abs(dx2-2._dbl*dchi2(1)/sqrt(3._dbl)) - dx3 = abs(dx3-0.5_dbl*dchi2(1)*(9._dbl*chi*chi-1._dbl)) - dy1 = abs(dy1-10._dbl/3._dbl*dchi2(2)) - dy2 = abs(dy2-2._dbl*dchi2(2)/sqrt(3._dbl)) - dy3 = abs(dy3-0.5_dbl*dchi2(2)*(9._dbl*chi*chi-1._dbl)) - dz1 = abs(dz1-10._dbl/3._dbl*dchi2(3)) - dz2 = abs(dz2-2._dbl*dchi2(3)/sqrt(3._dbl)) - dz3 = abs(dz3-0.5_dbl*dchi2(3)*(9._dbl*chi*chi-1._dbl)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0x', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0x', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0x', l1, l2, dx3 - emax = max(emax,dx1,dx2,dx3) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0y', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0y', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0y', l1, l2, dy3 - emax = max(emax,dy1,dy2,dy3) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0z', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0z', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0z', l1, l2, dz3 - emax = max(emax,dz1,dz2,dz3) - CASE (3) -! p-df - xt1 = abs(xt1 - (10._dbl*chi*chi-3._dbl)*chi*dchi2(1)) - xt2 = abs(xt2 + sqrt(0.375_dbl)*(20._dbl*chi*chi-12._dbl)*chi*dchi2(1)) - xt3 = abs(xt3 - (15._dbl*chi*chi-3._dbl)*chi*dchi2(1)) - yt1 = abs(yt1 - (10._dbl*chi*chi-3._dbl)*chi*dchi2(2)) - yt2 = abs(yt2 + sqrt(0.375_dbl)*(20._dbl*chi*chi-12._dbl)*chi*dchi2(2)) - yt3 = abs(yt3 - (15._dbl*chi*chi-3._dbl)*chi*dchi2(2)) - zt1 = abs(zt1 - (10._dbl*chi*chi-3._dbl)*chi*dchi2(3)) - zt2 = abs(zt2 + sqrt(0.375_dbl)*(20._dbl*chi*chi-12._dbl)*chi*dchi2(3)) - zt3 = abs(zt3 - (15._dbl*chi*chi-3._dbl)*chi*dchi2(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0x', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0x', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0x', l1, l2, xt3 - emax = max(emax,xt1,xt2,xt3) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0y', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0y', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0y', l1, l2, yt3 - emax = max(emax,yt1,yt2,yt3) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0z', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0z', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0z', l1, l2, zt3 - emax = max(emax,zt1,zt2,zt3) - dx1 = dpro(dll1(:,:,2),ddll2(:,:,2,1),l1,l2) - dx2 = dpro(dll1(:,:,2),ddll2(:,:,4,1),l1,l2) - dx3 = dpro(dll1(:,:,4),ddll2(:,:,4,1),l1,l2) - dy1 = dpro(dll1(:,:,2),ddll2(:,:,2,2),l1,l2) - dy2 = dpro(dll1(:,:,2),ddll2(:,:,4,2),l1,l2) - dy3 = dpro(dll1(:,:,4),ddll2(:,:,4,2),l1,l2) - dz1 = dpro(dll1(:,:,2),ddll2(:,:,2,3),l1,l2) - dz2 = dpro(dll1(:,:,2),ddll2(:,:,4,3),l1,l2) - dz3 = dpro(dll1(:,:,4),ddll2(:,:,4,3),l1,l2) - dx1 = abs(dx1-42._dbl*chi*dchi2(1)) - dx2 = abs(dx2-sqrt(1.5_dbl)*6._dbl*chi*dchi2(1)) - dx3 = abs(dx3-chi*dchi2(1)*(10._dbl*chi*chi-3._dbl)) - dy1 = abs(dy1-42._dbl*chi*dchi2(2)) - dy2 = abs(dy2-sqrt(1.5_dbl)*6._dbl*chi*dchi2(2)) - dy3 = abs(dy3-chi*dchi2(2)*(10._dbl*chi*chi-3._dbl)) - dz1 = abs(dz1-42._dbl*chi*dchi2(3)) - dz2 = abs(dz2-sqrt(1.5_dbl)*6._dbl*chi*dchi2(3)) - dz3 = abs(dz3-chi*dchi2(3)*(10._dbl*chi*chi-3._dbl)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0x', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0x', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0x', l1, l2, dx3 - emax = max(emax,dx1,dx2,dx3) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0y', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0y', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0y', l1, l2, dy3 - emax = max(emax,dy1,dy2,dy3) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0z', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0z', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0z', l1, l2, dz3 - emax = max(emax,dz1,dz2,dz3) - END SELECT - END SUBROUTINE dp_test - SUBROUTINE dd_test(chi,dchi1,dchi2,gmu1,gmu2,dgmu1,dgmu2, & - dll1,dll2,ddll1,ddll2,l1,l2,emax) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (OUT) :: emax - REAL (dbl), INTENT (IN) :: chi, dchi1(3), dchi2(3) - REAL (dbl), INTENT (IN) :: gmu1(0:6,0:6,0:3), gmu2(0:6,0:6,0:3) - REAL (dbl), INTENT (IN) :: dgmu1(0:6,0:6,0:3,1:3), dgmu2(0:6,0:6,0:3,1:3) - REAL (dbl), INTENT (IN) :: dll1(0:6,0:6,0:6), dll2(0:6,0:6,0:6) - REAL (dbl), INTENT (IN) :: ddll1(0:6,0:6,0:6,1:3), ddll2(0:6,0:6,0:6,1:3) - REAL (dbl) :: c2, c4, c6 - REAL (dbl) :: xt1, xt2, xt3, xt4, xt5, xt6 - REAL (dbl) :: yt1, yt2, yt3, yt4, yt5, yt6 - REAL (dbl) :: zt1, zt2, zt3, zt4, zt5, zt6 - REAL (dbl) :: dx1, dx2, dx3, dx4, dx5, dx6 - REAL (dbl) :: dy1, dy2, dy3, dy4, dy5, dy6 - REAL (dbl) :: dz1, dz2, dz3, dz4, dz5, dz6 - INTEGER :: lm, lu - - emax = 0._dbl - lm = max(l1,l2) - lu = min(l1,l2) - - xt1 = dpro(dgmu1(:,:,0,1),gmu2(:,:,0),l1,l2) - xt2 = dpro(dgmu1(:,:,0,1),gmu2(:,:,1),l1,l2) - xt3 = dpro(dgmu1(:,:,0,1),gmu2(:,:,2),l1,l2) - xt4 = dpro(dgmu1(:,:,1,1),gmu2(:,:,1),l1,l2) - xt5 = dpro(dgmu1(:,:,1,1),gmu2(:,:,2),l1,l2) - xt6 = dpro(dgmu1(:,:,2,1),gmu2(:,:,2),l1,l2) - yt1 = dpro(dgmu1(:,:,0,2),gmu2(:,:,0),l1,l2) - yt2 = dpro(dgmu1(:,:,0,2),gmu2(:,:,1),l1,l2) - yt3 = dpro(dgmu1(:,:,0,2),gmu2(:,:,2),l1,l2) - yt4 = dpro(dgmu1(:,:,1,2),gmu2(:,:,1),l1,l2) - yt5 = dpro(dgmu1(:,:,1,2),gmu2(:,:,2),l1,l2) - yt6 = dpro(dgmu1(:,:,2,2),gmu2(:,:,2),l1,l2) - zt1 = dpro(dgmu1(:,:,0,3),gmu2(:,:,0),l1,l2) - zt2 = dpro(dgmu1(:,:,0,3),gmu2(:,:,1),l1,l2) - zt3 = dpro(dgmu1(:,:,0,3),gmu2(:,:,2),l1,l2) - zt4 = dpro(dgmu1(:,:,1,3),gmu2(:,:,1),l1,l2) - zt5 = dpro(dgmu1(:,:,1,3),gmu2(:,:,2),l1,l2) - zt6 = dpro(dgmu1(:,:,2,3),gmu2(:,:,2),l1,l2) - SELECT CASE (lm) - CASE (2) -! dd-d - xt1 = abs(xt1 - 3._dbl*chi*(3._dbl*chi*chi-1._dbl)*dchi1(1)) - xt2 = abs(xt2 + 6._dbl*chi*(2._dbl*chi*chi-1._dbl)*dchi1(1)) - xt3 = abs(xt3 - 3._dbl*chi*(chi*chi-1._dbl)*dchi1(1)) - xt4 = abs(xt4 - 2._dbl*chi*(8._dbl*chi*chi-3._dbl)*dchi1(1)) - xt5 = abs(xt5 + 4._dbl*chi*chi*chi*dchi1(1)) - xt6 = abs(xt6 - chi*(chi*chi+3._dbl)*dchi1(1)) - yt1 = abs(yt1 - 3._dbl*chi*(3._dbl*chi*chi-1._dbl)*dchi1(2)) - yt2 = abs(yt2 + 6._dbl*chi*(2._dbl*chi*chi-1._dbl)*dchi1(2)) - yt3 = abs(yt3 - 3._dbl*chi*(chi*chi-1._dbl)*dchi1(2)) - yt4 = abs(yt4 - 2._dbl*chi*(8._dbl*chi*chi-3._dbl)*dchi1(2)) - yt5 = abs(yt5 + 4._dbl*chi*chi*chi*dchi1(2)) - yt6 = abs(yt6 - chi*(chi*chi+3._dbl)*dchi1(2)) - zt1 = abs(zt1 - 3._dbl*chi*(3._dbl*chi*chi-1._dbl)*dchi1(3)) - zt2 = abs(zt2 + 6._dbl*chi*(2._dbl*chi*chi-1._dbl)*dchi1(3)) - zt3 = abs(zt3 - 3._dbl*chi*(chi*chi-1._dbl)*dchi1(3)) - zt4 = abs(zt4 - 2._dbl*chi*(8._dbl*chi*chi-3._dbl)*dchi1(3)) - zt5 = abs(zt5 + 4._dbl*chi*chi*chi*dchi1(3)) - zt6 = abs(zt6 - chi*(chi*chi+3._dbl)*dchi1(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 x0', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 x0', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 x0', l1, l2, xt3 - IF (xt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 x0', l1, l2, xt4 - IF (xt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 x0', l1, l2, xt5 - IF (xt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 x0', l1, l2, xt6 - emax = max(emax,xt1,xt2,xt3,xt4,xt5,xt6) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 y0', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 y0', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 y0', l1, l2, yt3 - IF (yt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 y0', l1, l2, yt4 - IF (yt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 y0', l1, l2, yt5 - IF (yt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 y0', l1, l2, yt6 - emax = max(emax,yt1,yt2,yt3,yt4,yt5,yt6) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 z0', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 z0', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 z0', l1, l2, zt3 - IF (zt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 z0', l1, l2, zt4 - IF (zt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 z0', l1, l2, zt5 - IF (zt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 z0', l1, l2, zt6 - emax = max(emax,zt1,zt2,zt3,zt4,zt5,zt6) - dx1 = dpro(ddll1(:,:,0,1),dll2(:,:,0),l1,l2) - dx2 = dpro(ddll1(:,:,0,1),dll2(:,:,2),l1,l2) - dx3 = dpro(ddll1(:,:,0,1),dll2(:,:,4),l1,l2) - dx4 = dpro(ddll1(:,:,2,1),dll2(:,:,2),l1,l2) - dx5 = dpro(ddll1(:,:,2,1),dll2(:,:,4),l1,l2) - dx6 = dpro(ddll1(:,:,4,1),dll2(:,:,4),l1,l2) - dy1 = dpro(ddll1(:,:,0,2),dll2(:,:,0),l1,l2) - dy2 = dpro(ddll1(:,:,0,2),dll2(:,:,2),l1,l2) - dy3 = dpro(ddll1(:,:,0,2),dll2(:,:,4),l1,l2) - dy4 = dpro(ddll1(:,:,2,2),dll2(:,:,2),l1,l2) - dy5 = dpro(ddll1(:,:,2,2),dll2(:,:,4),l1,l2) - dy6 = dpro(ddll1(:,:,4,2),dll2(:,:,4),l1,l2) - dz1 = dpro(ddll1(:,:,0,3),dll2(:,:,0),l1,l2) - dz2 = dpro(ddll1(:,:,0,3),dll2(:,:,2),l1,l2) - dz3 = dpro(ddll1(:,:,0,3),dll2(:,:,4),l1,l2) - dz4 = dpro(ddll1(:,:,2,3),dll2(:,:,2),l1,l2) - dz5 = dpro(ddll1(:,:,2,3),dll2(:,:,4),l1,l2) - dz6 = dpro(ddll1(:,:,4,3),dll2(:,:,4),l1,l2) - dx1 = abs(dx1) - dx2 = abs(dx2) - dx3 = abs(dx3) - dx4 = abs(dx4-14._dbl/3._dbl*chi*dchi1(1)) - dx5 = abs(dx5-2._dbl*chi*dchi1(1)) - dx6 = abs(dx6-3._dbl*(3._dbl*chi*chi-1._dbl)*chi*dchi1(1)) - dy1 = abs(dy1) - dy2 = abs(dy2) - dy3 = abs(dy3) - dy4 = abs(dy4-14._dbl/3._dbl*chi*dchi1(2)) - dy5 = abs(dy5-2._dbl*chi*dchi1(2)) - dy6 = abs(dy6-3._dbl*(3._dbl*chi*chi-1._dbl)*chi*dchi1(2)) - dz1 = abs(dz1) - dz2 = abs(dz2) - dz3 = abs(dz3) - dz4 = abs(dz4-14._dbl/3._dbl*chi*dchi1(3)) - dz5 = abs(dz5-2._dbl*chi*dchi1(3)) - dz6 = abs(dz6-3._dbl*(3._dbl*chi*chi-1._dbl)*chi*dchi1(3)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 x0', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 x0', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 x0', l1, l2, dx3 - IF (dx4>1.E-12) WRITE (*,*) ' Error in test for dll #4 x0', l1, l2, dx4 - IF (dx5>1.E-12) WRITE (*,*) ' Error in test for dll #5 x0', l1, l2, dx5 - IF (dx6>1.E-12) WRITE (*,*) ' Error in test for dll #6 x0', l1, l2, dx6 - emax = max(emax,dx1,dx2,dx3,dx4,dx5,dx6) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 y0', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 y0', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 y0', l1, l2, dy3 - IF (dy4>1.E-12) WRITE (*,*) ' Error in test for dll #4 y0', l1, l2, dy4 - IF (dy5>1.E-12) WRITE (*,*) ' Error in test for dll #5 y0', l1, l2, dy5 - IF (dy6>1.E-12) WRITE (*,*) ' Error in test for dll #6 y0', l1, l2, dy6 - emax = max(emax,dy1,dy2,dy3,dy4,dy5,dy6) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 z0', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 z0', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 z0', l1, l2, dz3 - IF (dz4>1.E-12) WRITE (*,*) ' Error in test for dll #4 z0', l1, l2, dz4 - IF (dz5>1.E-12) WRITE (*,*) ' Error in test for dll #5 z0', l1, l2, dz5 - IF (dz6>1.E-12) WRITE (*,*) ' Error in test for dll #6 z0', l1, l2, dz6 - emax = max(emax,dx1,dx2,dx3,dx4,dx5,dx6) - CASE (3) -! dd-f - c2 = chi*chi - c4 = c2*c2 - xt1 = abs(xt1 - 0.25_dbl*(75._dbl*c4-42._dbl*c2+3._dbl)*dchi1(1)) - xt2 = abs(xt2 + 3._dbl/sqrt(8._dbl)*(25._dbl*c4-18._dbl*c2+1._dbl)*dchi1(1)) - xt3 = abs(xt3 - sqrt(45._dbl)/4._dbl*(5._dbl*c4-6._dbl*c2+1._dbl)*dchi1(1)) - xt4 = abs(xt4 - 0.5_dbl*(75._dbl*c4-48._dbl*c2+5._dbl)*dchi1(1)) - xt5 = abs(xt5 + sqrt(0.625_dbl)*(15._dbl*c4-6._dbl*c2-1._dbl)*dchi1(1)) - xt6 = abs(xt6 - 0.25_dbl*(15._dbl*c4+30._dbl*c2-5._dbl)*dchi1(1)) - yt1 = abs(yt1 - 0.25_dbl*(75._dbl*c4-42._dbl*c2+3._dbl)*dchi1(2)) - yt2 = abs(yt2 + 3._dbl/sqrt(8._dbl)*(25._dbl*c4-18._dbl*c2+1._dbl)*dchi1(2)) - yt3 = abs(yt3 - sqrt(45._dbl)/4._dbl*(5._dbl*c4-6._dbl*c2+1._dbl)*dchi1(2)) - yt4 = abs(yt4 - 0.5_dbl*(75._dbl*c4-48._dbl*c2+5._dbl)*dchi1(2)) - yt5 = abs(yt5 + sqrt(0.625_dbl)*(15._dbl*c4-6._dbl*c2-1._dbl)*dchi1(2)) - yt6 = abs(yt6 - 0.25_dbl*(15._dbl*c4+30._dbl*c2-5._dbl)*dchi1(2)) - zt1 = abs(zt1 - 0.25_dbl*(75._dbl*c4-42._dbl*c2+3._dbl)*dchi1(3)) - zt2 = abs(zt2 + 3._dbl/sqrt(8._dbl)*(25._dbl*c4-18._dbl*c2+1._dbl)*dchi1(3)) - zt3 = abs(zt3 - sqrt(45._dbl)/4._dbl*(5._dbl*c4-6._dbl*c2+1._dbl)*dchi1(3)) - zt4 = abs(zt4 - 0.5_dbl*(75._dbl*c4-48._dbl*c2+5._dbl)*dchi1(3)) - zt5 = abs(zt5 + sqrt(0.625_dbl)*(15._dbl*c4-6._dbl*c2-1._dbl)*dchi1(3)) - zt6 = abs(zt6 - 0.25_dbl*(15._dbl*c4+30._dbl*c2-5._dbl)*dchi1(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 x0', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 x0', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 x0', l1, l2, xt3 - IF (xt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 x0', l1, l2, xt4 - IF (xt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 x0', l1, l2, xt5 - IF (xt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 x0', l1, l2, xt6 - emax = max(emax,xt1,xt2,xt3,xt4,xt5,xt6) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 y0', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 y0', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 y0', l1, l2, yt3 - IF (yt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 y0', l1, l2, yt4 - IF (yt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 y0', l1, l2, yt5 - IF (yt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 y0', l1, l2, yt6 - emax = max(emax,yt1,yt2,yt3,yt4,yt5,yt6) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 z0', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 z0', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 z0', l1, l2, zt3 - IF (zt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 z0', l1, l2, zt4 - IF (zt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 z0', l1, l2, zt5 - IF (zt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 z0', l1, l2, zt6 - emax = max(emax,zt1,zt2,zt3,zt4,zt5,zt6) - dx1 = dpro(ddll1(:,:,1,1),dll2(:,:,1),l1,l2) - dx2 = dpro(ddll1(:,:,1,1),dll2(:,:,3),l1,l2) - dx3 = dpro(ddll1(:,:,1,1),dll2(:,:,5),l1,l2) - dx4 = dpro(ddll1(:,:,3,1),dll2(:,:,3),l1,l2) - dx5 = dpro(ddll1(:,:,3,1),dll2(:,:,5),l1,l2) - dx6 = dpro(ddll1(:,:,5,1),dll2(:,:,5),l1,l2) - dy1 = dpro(ddll1(:,:,1,2),dll2(:,:,1),l1,l2) - dy2 = dpro(ddll1(:,:,1,2),dll2(:,:,3),l1,l2) - dy3 = dpro(ddll1(:,:,1,2),dll2(:,:,5),l1,l2) - dy4 = dpro(ddll1(:,:,3,2),dll2(:,:,3),l1,l2) - dy5 = dpro(ddll1(:,:,3,2),dll2(:,:,5),l1,l2) - dy6 = dpro(ddll1(:,:,5,2),dll2(:,:,5),l1,l2) - dz1 = dpro(ddll1(:,:,1,3),dll2(:,:,1),l1,l2) - dz2 = dpro(ddll1(:,:,1,3),dll2(:,:,3),l1,l2) - dz3 = dpro(ddll1(:,:,1,3),dll2(:,:,5),l1,l2) - dz4 = dpro(ddll1(:,:,3,3),dll2(:,:,3),l1,l2) - dz5 = dpro(ddll1(:,:,3,3),dll2(:,:,5),l1,l2) - dz6 = dpro(ddll1(:,:,5,3),dll2(:,:,5),l1,l2) - dx1 = abs(dx1-17.5_dbl*dchi1(1)) - dx2 = abs(dx2+3.5_dbl*dchi1(1)) - dx3 = abs(dx3-3._dbl/sqrt(2._dbl)*dchi1(1)) - dx4 = abs(dx4-0.5_dbl*(72._dbl*c2-13._dbl)*dchi1(1)) - dx5 = abs(dx5-1._dbl/sqrt(2._dbl)*dchi1(1)*(12._dbl*c2-3._dbl)) - dx6 = abs(dx6-0.25_dbl*dchi1(1)*(75._dbl*c4-42._dbl*c2+3._dbl)) - dy1 = abs(dy1-17.5_dbl*dchi1(2)) - dy2 = abs(dy2+3.5_dbl*dchi1(2)) - dy3 = abs(dy3-3._dbl/sqrt(2._dbl)*dchi1(2)) - dy4 = abs(dy4-0.5_dbl*(72._dbl*c2-13._dbl)*dchi1(2)) - dy5 = abs(dy5-1._dbl/sqrt(2._dbl)*dchi1(2)*(12._dbl*c2-3._dbl)) - dy6 = abs(dy6-0.25_dbl*dchi1(2)*(75._dbl*c4-42._dbl*c2+3._dbl)) - dz1 = abs(dz1-17.5_dbl*dchi1(3)) - dz2 = abs(dz2+3.5_dbl*dchi1(3)) - dz3 = abs(dz3-3._dbl/sqrt(2._dbl)*dchi1(3)) - dz4 = abs(dz4-0.5_dbl*(72._dbl*c2-13._dbl)*dchi1(3)) - dz5 = abs(dz5-1._dbl/sqrt(2._dbl)*dchi1(3)*(12._dbl*c2-3._dbl)) - dz6 = abs(dz6-0.25_dbl*dchi1(3)*(75._dbl*c4-42._dbl*c2+3._dbl)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 x0', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 x0', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 x0', l1, l2, dx3 - IF (dx4>1.E-12) WRITE (*,*) ' Error in test for dll #4 x0', l1, l2, dx4 - IF (dx5>1.E-12) WRITE (*,*) ' Error in test for dll #5 x0', l1, l2, dx5 - IF (dx6>1.E-12) WRITE (*,*) ' Error in test for dll #6 x0', l1, l2, dx6 - emax = max(emax,dx1,dx2,dx3,dx4,dx5,dx6) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 y0', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 y0', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 y0', l1, l2, dy3 - IF (dy4>1.E-12) WRITE (*,*) ' Error in test for dll #4 y0', l1, l2, dy4 - IF (dy5>1.E-12) WRITE (*,*) ' Error in test for dll #5 y0', l1, l2, dy5 - IF (dy6>1.E-12) WRITE (*,*) ' Error in test for dll #6 y0', l1, l2, dy6 - emax = max(emax,dy1,dy2,dy3,dy4,dy5,dy6) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 z0', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 z0', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 z0', l1, l2, dz3 - IF (dz4>1.E-12) WRITE (*,*) ' Error in test for dll #4 z0', l1, l2, dz4 - IF (dz5>1.E-12) WRITE (*,*) ' Error in test for dll #5 z0', l1, l2, dz5 - IF (dz6>1.E-12) WRITE (*,*) ' Error in test for dll #6 z0', l1, l2, dz6 - emax = max(emax,dx1,dx2,dx3,dx4,dx5,dx6) - END SELECT - xt1 = dpro(gmu1(:,:,0),dgmu2(:,:,0,1),l1,l2) - xt2 = dpro(gmu1(:,:,0),dgmu2(:,:,1,1),l1,l2) - xt3 = dpro(gmu1(:,:,0),dgmu2(:,:,2,1),l1,l2) - xt4 = dpro(gmu1(:,:,1),dgmu2(:,:,1,1),l1,l2) - xt5 = dpro(gmu1(:,:,1),dgmu2(:,:,2,1),l1,l2) - xt6 = dpro(gmu1(:,:,2),dgmu2(:,:,2,1),l1,l2) - yt1 = dpro(gmu1(:,:,0),dgmu2(:,:,0,2),l1,l2) - yt2 = dpro(gmu1(:,:,0),dgmu2(:,:,1,2),l1,l2) - yt3 = dpro(gmu1(:,:,0),dgmu2(:,:,2,2),l1,l2) - yt4 = dpro(gmu1(:,:,1),dgmu2(:,:,1,2),l1,l2) - yt5 = dpro(gmu1(:,:,1),dgmu2(:,:,2,2),l1,l2) - yt6 = dpro(gmu1(:,:,2),dgmu2(:,:,2,2),l1,l2) - zt1 = dpro(gmu1(:,:,0),dgmu2(:,:,0,3),l1,l2) - zt2 = dpro(gmu1(:,:,0),dgmu2(:,:,1,3),l1,l2) - zt3 = dpro(gmu1(:,:,0),dgmu2(:,:,2,3),l1,l2) - zt4 = dpro(gmu1(:,:,1),dgmu2(:,:,1,3),l1,l2) - zt5 = dpro(gmu1(:,:,1),dgmu2(:,:,2,3),l1,l2) - zt6 = dpro(gmu1(:,:,2),dgmu2(:,:,2,3),l1,l2) - SELECT CASE (lm) - CASE (2) -! d-dd - xt1 = abs(xt1 - 3._dbl*chi*(3._dbl*chi*chi-1._dbl)*dchi2(1)) - xt2 = abs(xt2 + 6._dbl*chi*(2._dbl*chi*chi-1._dbl)*dchi2(1)) - xt3 = abs(xt3 - 3._dbl*chi*(chi*chi-1._dbl)*dchi2(1)) - xt4 = abs(xt4 - 2._dbl*chi*(8._dbl*chi*chi-3._dbl)*dchi2(1)) - xt5 = abs(xt5 + 4._dbl*chi*chi*chi*dchi2(1)) - xt6 = abs(xt6 - chi*(chi*chi+3._dbl)*dchi2(1)) - yt1 = abs(yt1 - 3._dbl*chi*(3._dbl*chi*chi-1._dbl)*dchi2(2)) - yt2 = abs(yt2 + 6._dbl*chi*(2._dbl*chi*chi-1._dbl)*dchi2(2)) - yt3 = abs(yt3 - 3._dbl*chi*(chi*chi-1._dbl)*dchi2(2)) - yt4 = abs(yt4 - 2._dbl*chi*(8._dbl*chi*chi-3._dbl)*dchi2(2)) - yt5 = abs(yt5 + 4._dbl*chi*chi*chi*dchi2(2)) - yt6 = abs(yt6 - chi*(chi*chi+3._dbl)*dchi2(2)) - zt1 = abs(zt1 - 3._dbl*chi*(3._dbl*chi*chi-1._dbl)*dchi2(3)) - zt2 = abs(zt2 + 6._dbl*chi*(2._dbl*chi*chi-1._dbl)*dchi2(3)) - zt3 = abs(zt3 - 3._dbl*chi*(chi*chi-1._dbl)*dchi2(3)) - zt4 = abs(zt4 - 2._dbl*chi*(8._dbl*chi*chi-3._dbl)*dchi2(3)) - zt5 = abs(zt5 + 4._dbl*chi*chi*chi*dchi2(3)) - zt6 = abs(zt6 - chi*(chi*chi+3._dbl)*dchi2(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0x', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0x', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0x', l1, l2, xt3 - IF (xt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 0x', l1, l2, xt4 - IF (xt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 0x', l1, l2, xt5 - IF (xt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 0x', l1, l2, xt6 - emax = max(emax,xt1,xt2,xt3,xt4,xt5,xt6) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0y', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0y', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0y', l1, l2, yt3 - IF (yt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 0y', l1, l2, yt4 - IF (yt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 0y', l1, l2, yt5 - IF (yt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 0y', l1, l2, yt6 - emax = max(emax,yt1,yt2,yt3,yt4,yt5,yt6) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0z', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0z', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0z', l1, l2, zt3 - IF (zt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 0z', l1, l2, zt4 - IF (zt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 0z', l1, l2, zt5 - IF (zt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 0z', l1, l2, zt6 - emax = max(emax,zt1,zt2,zt3,zt4,zt5,zt6) - dx1 = dpro(dll1(:,:,0),ddll2(:,:,0,1),l1,l2) - dx2 = dpro(dll1(:,:,0),ddll2(:,:,2,1),l1,l2) - dx3 = dpro(dll1(:,:,0),ddll2(:,:,4,1),l1,l2) - dx4 = dpro(dll1(:,:,2),ddll2(:,:,2,1),l1,l2) - dx5 = dpro(dll1(:,:,2),ddll2(:,:,4,1),l1,l2) - dx6 = dpro(dll1(:,:,4),ddll2(:,:,4,1),l1,l2) - dy1 = dpro(dll1(:,:,0),ddll2(:,:,0,2),l1,l2) - dy2 = dpro(dll1(:,:,0),ddll2(:,:,2,2),l1,l2) - dy3 = dpro(dll1(:,:,0),ddll2(:,:,4,2),l1,l2) - dy4 = dpro(dll1(:,:,2),ddll2(:,:,2,2),l1,l2) - dy5 = dpro(dll1(:,:,2),ddll2(:,:,4,2),l1,l2) - dy6 = dpro(dll1(:,:,4),ddll2(:,:,4,2),l1,l2) - dz1 = dpro(dll1(:,:,0),ddll2(:,:,0,3),l1,l2) - dz2 = dpro(dll1(:,:,0),ddll2(:,:,2,3),l1,l2) - dz3 = dpro(dll1(:,:,0),ddll2(:,:,4,3),l1,l2) - dz4 = dpro(dll1(:,:,2),ddll2(:,:,2,3),l1,l2) - dz5 = dpro(dll1(:,:,2),ddll2(:,:,4,3),l1,l2) - dz6 = dpro(dll1(:,:,4),ddll2(:,:,4,3),l1,l2) - dx1 = abs(dx1) - dx2 = abs(dx2) - dx3 = abs(dx3) - dx4 = abs(dx4-14._dbl/3._dbl*chi*dchi2(1)) - dx5 = abs(dx5-2._dbl*chi*dchi2(1)) - dx6 = abs(dx6-3._dbl*(3._dbl*chi*chi-1._dbl)*chi*dchi2(1)) - dy1 = abs(dy1) - dy2 = abs(dy2) - dy3 = abs(dy3) - dy4 = abs(dy4-14._dbl/3._dbl*chi*dchi2(2)) - dy5 = abs(dy5-2._dbl*chi*dchi2(2)) - dy6 = abs(dy6-3._dbl*(3._dbl*chi*chi-1._dbl)*chi*dchi2(2)) - dz1 = abs(dz1) - dz2 = abs(dz2) - dz3 = abs(dz3) - dz4 = abs(dz4-14._dbl/3._dbl*chi*dchi2(3)) - dz5 = abs(dz5-2._dbl*chi*dchi2(3)) - dz6 = abs(dz6-3._dbl*(3._dbl*chi*chi-1._dbl)*chi*dchi2(3)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0x', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0x', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0x', l1, l2, dx3 - IF (dx4>1.E-12) WRITE (*,*) ' Error in test for dll #4 0x', l1, l2, dx4 - IF (dx5>1.E-12) WRITE (*,*) ' Error in test for dll #5 0x', l1, l2, dx5 - IF (dx6>1.E-12) WRITE (*,*) ' Error in test for dll #6 0x', l1, l2, dx6 - emax = max(emax,dx1,dx2,dx3,dx4,dx5,dx6) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0y', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0y', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0y', l1, l2, dy3 - IF (dy4>1.E-12) WRITE (*,*) ' Error in test for dll #4 0y', l1, l2, dy4 - IF (dy5>1.E-12) WRITE (*,*) ' Error in test for dll #5 0y', l1, l2, dy5 - IF (dy6>1.E-12) WRITE (*,*) ' Error in test for dll #6 0y', l1, l2, dy6 - emax = max(emax,dy1,dy2,dy3,dy4,dy5,dy6) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0z', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0z', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0z', l1, l2, dz3 - IF (dz4>1.E-12) WRITE (*,*) ' Error in test for dll #4 0z', l1, l2, dz4 - IF (dz5>1.E-12) WRITE (*,*) ' Error in test for dll #5 0z', l1, l2, dz5 - IF (dz6>1.E-12) WRITE (*,*) ' Error in test for dll #6 0z', l1, l2, dz6 - emax = max(emax,dx1,dx2,dx3,dx4,dx5,dx6) - CASE (3) -! d-df - c2 = chi*chi - c4 = c2*c2 - xt1 = abs(xt1 - 0.25_dbl*(75._dbl*c4-42._dbl*c2+3._dbl)*dchi2(1)) - xt2 = abs(xt2 + 3._dbl/sqrt(8._dbl)*(25._dbl*c4-18._dbl*c2+1._dbl)*dchi2(1)) - xt3 = abs(xt3 - sqrt(45._dbl)/4._dbl*(5._dbl*c4-6._dbl*c2+1._dbl)*dchi2(1)) - xt4 = abs(xt4 - 0.5_dbl*(75._dbl*c4-48._dbl*c2+5._dbl)*dchi2(1)) - xt5 = abs(xt5 + sqrt(0.625_dbl)*(15._dbl*c4-6._dbl*c2-1._dbl)*dchi2(1)) - xt6 = abs(xt6 - 0.25_dbl*(15._dbl*c4+30._dbl*c2-5._dbl)*dchi2(1)) - yt1 = abs(yt1 - 0.25_dbl*(75._dbl*c4-42._dbl*c2+3._dbl)*dchi2(2)) - yt2 = abs(yt2 + 3._dbl/sqrt(8._dbl)*(25._dbl*c4-18._dbl*c2+1._dbl)*dchi2(2)) - yt3 = abs(yt3 - sqrt(45._dbl)/4._dbl*(5._dbl*c4-6._dbl*c2+1._dbl)*dchi2(2)) - yt4 = abs(yt4 - 0.5_dbl*(75._dbl*c4-48._dbl*c2+5._dbl)*dchi2(2)) - yt5 = abs(yt5 + sqrt(0.625_dbl)*(15._dbl*c4-6._dbl*c2-1._dbl)*dchi2(2)) - yt6 = abs(yt6 - 0.25_dbl*(15._dbl*c4+30._dbl*c2-5._dbl)*dchi2(2)) - zt1 = abs(zt1 - 0.25_dbl*(75._dbl*c4-42._dbl*c2+3._dbl)*dchi2(3)) - zt2 = abs(zt2 + 3._dbl/sqrt(8._dbl)*(25._dbl*c4-18._dbl*c2+1._dbl)*dchi2(3)) - zt3 = abs(zt3 - sqrt(45._dbl)/4._dbl*(5._dbl*c4-6._dbl*c2+1._dbl)*dchi2(3)) - zt4 = abs(zt4 - 0.5_dbl*(75._dbl*c4-48._dbl*c2+5._dbl)*dchi2(3)) - zt5 = abs(zt5 + sqrt(0.625_dbl)*(15._dbl*c4-6._dbl*c2-1._dbl)*dchi2(3)) - zt6 = abs(zt6 - 0.25_dbl*(15._dbl*c4+30._dbl*c2-5._dbl)*dchi2(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0x', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0x', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0x', l1, l2, xt3 - IF (xt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 0x', l1, l2, xt4 - IF (xt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 0x', l1, l2, xt5 - IF (xt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 0x', l1, l2, xt6 - emax = max(emax,xt1,xt2,xt3,xt4,xt5,xt6) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0y', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0y', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0y', l1, l2, yt3 - IF (yt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 0y', l1, l2, yt4 - IF (yt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 0y', l1, l2, yt5 - IF (yt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 0y', l1, l2, yt6 - emax = max(emax,yt1,yt2,yt3,yt4,yt5,yt6) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0z', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0z', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0z', l1, l2, zt3 - IF (zt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 0z', l1, l2, zt4 - IF (zt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 0z', l1, l2, zt5 - IF (zt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 0z', l1, l2, zt6 - emax = max(emax,zt1,zt2,zt3,zt4,zt5,zt6) - dx1 = dpro(dll1(:,:,1),ddll2(:,:,1,1),l1,l2) - dx2 = dpro(dll1(:,:,1),ddll2(:,:,3,1),l1,l2) - dx3 = dpro(dll1(:,:,1),ddll2(:,:,5,1),l1,l2) - dx4 = dpro(dll1(:,:,3),ddll2(:,:,3,1),l1,l2) - dx5 = dpro(dll1(:,:,3),ddll2(:,:,5,1),l1,l2) - dx6 = dpro(dll1(:,:,5),ddll2(:,:,5,1),l1,l2) - dy1 = dpro(dll1(:,:,1),ddll2(:,:,1,2),l1,l2) - dy2 = dpro(dll1(:,:,1),ddll2(:,:,3,2),l1,l2) - dy3 = dpro(dll1(:,:,1),ddll2(:,:,5,2),l1,l2) - dy4 = dpro(dll1(:,:,3),ddll2(:,:,3,2),l1,l2) - dy5 = dpro(dll1(:,:,3),ddll2(:,:,5,2),l1,l2) - dy6 = dpro(dll1(:,:,5),ddll2(:,:,5,2),l1,l2) - dz1 = dpro(dll1(:,:,1),ddll2(:,:,1,3),l1,l2) - dz2 = dpro(dll1(:,:,1),ddll2(:,:,3,3),l1,l2) - dz3 = dpro(dll1(:,:,1),ddll2(:,:,5,3),l1,l2) - dz4 = dpro(dll1(:,:,3),ddll2(:,:,3,3),l1,l2) - dz5 = dpro(dll1(:,:,3),ddll2(:,:,5,3),l1,l2) - dz6 = dpro(dll1(:,:,5),ddll2(:,:,5,3),l1,l2) - dx1 = abs(dx1-17.5_dbl*dchi2(1)) - dx2 = abs(dx2+3.5_dbl*dchi2(1)) - dx3 = abs(dx3-3._dbl/sqrt(2._dbl)*dchi2(1)) - dx4 = abs(dx4-0.5_dbl*(72._dbl*c2-13._dbl)*dchi2(1)) - dx5 = abs(dx5-1._dbl/sqrt(2._dbl)*dchi2(1)*(12._dbl*c2-3._dbl)) - dx6 = abs(dx6-0.25_dbl*dchi2(1)*(75._dbl*c4-42._dbl*c2+3._dbl)) - dy1 = abs(dy1-17.5_dbl*dchi2(2)) - dy2 = abs(dy2+3.5_dbl*dchi2(2)) - dy3 = abs(dy3-3._dbl/sqrt(2._dbl)*dchi2(2)) - dy4 = abs(dy4-0.5_dbl*(72._dbl*c2-13._dbl)*dchi2(2)) - dy5 = abs(dy5-1._dbl/sqrt(2._dbl)*dchi2(2)*(12._dbl*c2-3._dbl)) - dy6 = abs(dy6-0.25_dbl*dchi2(2)*(75._dbl*c4-42._dbl*c2+3._dbl)) - dz1 = abs(dz1-17.5_dbl*dchi2(3)) - dz2 = abs(dz2+3.5_dbl*dchi2(3)) - dz3 = abs(dz3-3._dbl/sqrt(2._dbl)*dchi2(3)) - dz4 = abs(dz4-0.5_dbl*(72._dbl*c2-13._dbl)*dchi2(3)) - dz5 = abs(dz5-1._dbl/sqrt(2._dbl)*dchi2(3)*(12._dbl*c2-3._dbl)) - dz6 = abs(dz6-0.25_dbl*dchi2(3)*(75._dbl*c4-42._dbl*c2+3._dbl)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0x', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0x', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0x', l1, l2, dx3 - IF (dx4>1.E-12) WRITE (*,*) ' Error in test for dll #4 0x', l1, l2, dx4 - IF (dx5>1.E-12) WRITE (*,*) ' Error in test for dll #5 0x', l1, l2, dx5 - IF (dx6>1.E-12) WRITE (*,*) ' Error in test for dll #6 0x', l1, l2, dx6 - emax = max(emax,dx1,dx2,dx3,dx4,dx5,dx6) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0y', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0y', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0y', l1, l2, dy3 - IF (dy4>1.E-12) WRITE (*,*) ' Error in test for dll #4 0y', l1, l2, dy4 - IF (dy5>1.E-12) WRITE (*,*) ' Error in test for dll #5 0y', l1, l2, dy5 - IF (dy6>1.E-12) WRITE (*,*) ' Error in test for dll #6 0y', l1, l2, dy6 - emax = max(emax,dy1,dy2,dy3,dy4,dy5,dy6) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0z', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0z', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0z', l1, l2, dz3 - IF (dz4>1.E-12) WRITE (*,*) ' Error in test for dll #4 0z', l1, l2, dz4 - IF (dz5>1.E-12) WRITE (*,*) ' Error in test for dll #5 0z', l1, l2, dz5 - IF (dz6>1.E-12) WRITE (*,*) ' Error in test for dll #6 0z', l1, l2, dz6 - emax = max(emax,dx1,dx2,dx3,dx4,dx5,dx6) - END SELECT - END SUBROUTINE dd_test - SUBROUTINE df_test(chi,dchi1,dchi2,gmu1,gmu2,dgmu1,dgmu2, & - dll1,dll2,ddll1,ddll2,l1,l2,emax) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (OUT) :: emax - REAL (dbl), INTENT (IN) :: chi, dchi1(3), dchi2(3) - REAL (dbl), INTENT (IN) :: gmu1(0:6,0:6,0:3), gmu2(0:6,0:6,0:3) - REAL (dbl), INTENT (IN) :: dgmu1(0:6,0:6,0:3,1:3), dgmu2(0:6,0:6,0:3,1:3) - REAL (dbl), INTENT (IN) :: dll1(0:6,0:6,0:6), dll2(0:6,0:6,0:6) - REAL (dbl), INTENT (IN) :: ddll1(0:6,0:6,0:6,1:3), ddll2(0:6,0:6,0:6,1:3) - REAL (dbl) :: c2, c4 - REAL (dbl) :: xt1, xt2, xt3, xt4, xt5, xt6, xt7, xt8, xt9, xt0 - REAL (dbl) :: yt1, yt2, yt3, yt4, yt5, yt6, yt7, yt8, yt9, yt0 - REAL (dbl) :: zt1, zt2, zt3, zt4, zt5, zt6, zt7, zt8, zt9, zt0 - REAL (dbl) :: dx1, dx2, dx3, dx4, dx5, dx6, dx7, dx8, dx9, dx0 - REAL (dbl) :: dy1, dy2, dy3, dy4, dy5, dy6, dy7, dy8, dy9, dy0 - REAL (dbl) :: dz1, dz2, dz3, dz4, dz5, dz6, dz7, dz8, dz9, dz0 - INTEGER :: lm, lu - - emax = 0._dbl - lm = max(l1,l2) - lu = min(l1,l2) - c2 = chi*chi - c4 = c2*c2 -! df-f - xt1 = dpro(dgmu1(:,:,0,1),gmu2(:,:,0),l1,l2) - xt2 = dpro(dgmu1(:,:,0,1),gmu2(:,:,1),l1,l2) - xt3 = dpro(dgmu1(:,:,0,1),gmu2(:,:,2),l1,l2) - xt4 = dpro(dgmu1(:,:,0,1),gmu2(:,:,3),l1,l2) - xt5 = dpro(dgmu1(:,:,1,1),gmu2(:,:,1),l1,l2) - xt6 = dpro(dgmu1(:,:,1,1),gmu2(:,:,2),l1,l2) - xt7 = dpro(dgmu1(:,:,1,1),gmu2(:,:,3),l1,l2) - xt8 = dpro(dgmu1(:,:,2,1),gmu2(:,:,2),l1,l2) - xt9 = dpro(dgmu1(:,:,2,1),gmu2(:,:,3),l1,l2) - xt0 = dpro(dgmu1(:,:,3,1),gmu2(:,:,3),l1,l2) - yt1 = dpro(dgmu1(:,:,0,2),gmu2(:,:,0),l1,l2) - yt2 = dpro(dgmu1(:,:,0,2),gmu2(:,:,1),l1,l2) - yt3 = dpro(dgmu1(:,:,0,2),gmu2(:,:,2),l1,l2) - yt4 = dpro(dgmu1(:,:,0,2),gmu2(:,:,3),l1,l2) - yt5 = dpro(dgmu1(:,:,1,2),gmu2(:,:,1),l1,l2) - yt6 = dpro(dgmu1(:,:,1,2),gmu2(:,:,2),l1,l2) - yt7 = dpro(dgmu1(:,:,1,2),gmu2(:,:,3),l1,l2) - yt8 = dpro(dgmu1(:,:,2,2),gmu2(:,:,2),l1,l2) - yt9 = dpro(dgmu1(:,:,2,2),gmu2(:,:,3),l1,l2) - yt0 = dpro(dgmu1(:,:,3,2),gmu2(:,:,3),l1,l2) - zt1 = dpro(dgmu1(:,:,0,3),gmu2(:,:,0),l1,l2) - zt2 = dpro(dgmu1(:,:,0,3),gmu2(:,:,1),l1,l2) - zt3 = dpro(dgmu1(:,:,0,3),gmu2(:,:,2),l1,l2) - zt4 = dpro(dgmu1(:,:,0,3),gmu2(:,:,3),l1,l2) - zt5 = dpro(dgmu1(:,:,1,3),gmu2(:,:,1),l1,l2) - zt6 = dpro(dgmu1(:,:,1,3),gmu2(:,:,2),l1,l2) - zt7 = dpro(dgmu1(:,:,1,3),gmu2(:,:,3),l1,l2) - zt8 = dpro(dgmu1(:,:,2,3),gmu2(:,:,2),l1,l2) - zt9 = dpro(dgmu1(:,:,2,3),gmu2(:,:,3),l1,l2) - zt0 = dpro(dgmu1(:,:,3,3),gmu2(:,:,3),l1,l2) - xt1 = abs(xt1 - 0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi1(1)) - xt2 = abs(xt2 + 0.375_dbl*chi*(150._dbl*c4-140._dbl*c2+22._dbl)*dchi1(1)) - xt3 = abs(xt3 - 3.75_dbl*chi*(6._dbl*c4-8._dbl*c2+2._dbl)*dchi1(1)) - xt4 = abs(xt4 + 0.625_dbl*chi*(6._dbl*c4-12._dbl*c2+6._dbl)*dchi1(1)) - xt5 = abs(xt5 - 0.0625_dbl*chi*(1350._dbl*c4-1220._dbl*c2+222._dbl)*dchi1(1)) - xt6 = abs(xt6 + 0.625_dbl*chi*(54._dbl*c4-44._dbl*c2+6._dbl)*dchi1(1)) - xt7 = abs(xt7 - 0.9375_dbl*chi*(6._dbl*c4-4._dbl*c2-2._dbl)*dchi1(1)) - xt8 = abs(xt8 - 0.25_dbl*chi*(54._dbl*c4+40._dbl*c2-30._dbl)*dchi1(1)) - xt9 = abs(xt9 + 0.375_dbl*chi*(6._dbl*c4+20._dbl*c2-10._dbl)*dchi1(1)) - xt0 = abs(xt0 - 0.0625_dbl*chi*(6._dbl*c4+60._dbl*c2+30._dbl)*dchi1(1)) - yt1 = abs(yt1 - 0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi1(2)) - yt2 = abs(yt2 + 0.375_dbl*chi*(150._dbl*c4-140._dbl*c2+22._dbl)*dchi1(2)) - yt3 = abs(yt3 - 3.75_dbl*chi*(6._dbl*c4-8._dbl*c2+2._dbl)*dchi1(2)) - yt4 = abs(yt4 + 0.625_dbl*chi*(6._dbl*c4-12._dbl*c2+6._dbl)*dchi1(2)) - yt5 = abs(yt5 - 0.0625_dbl*chi*(1350._dbl*c4-1220._dbl*c2+222._dbl)*dchi1(2)) - yt6 = abs(yt6 + 0.625_dbl*chi*(54._dbl*c4-44._dbl*c2+6._dbl)*dchi1(2)) - yt7 = abs(yt7 - 0.9375_dbl*chi*(6._dbl*c4-4._dbl*c2-2._dbl)*dchi1(2)) - yt8 = abs(yt8 - 0.25_dbl*chi*(54._dbl*c4+40._dbl*c2-30._dbl)*dchi1(2)) - yt9 = abs(yt9 + 0.375_dbl*chi*(6._dbl*c4+20._dbl*c2-10._dbl)*dchi1(2)) - yt0 = abs(yt0 - 0.0625_dbl*chi*(6._dbl*c4+60._dbl*c2+30._dbl)*dchi1(2)) - zt1 = abs(zt1 - 0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi1(3)) - zt2 = abs(zt2 + 0.375_dbl*chi*(150._dbl*c4-140._dbl*c2+22._dbl)*dchi1(3)) - zt3 = abs(zt3 - 3.75_dbl*chi*(6._dbl*c4-8._dbl*c2+2._dbl)*dchi1(3)) - zt4 = abs(zt4 + 0.625_dbl*chi*(6._dbl*c4-12._dbl*c2+6._dbl)*dchi1(3)) - zt5 = abs(zt5 - 0.0625_dbl*chi*(1350._dbl*c4-1220._dbl*c2+222._dbl)*dchi1(3)) - zt6 = abs(zt6 + 0.625_dbl*chi*(54._dbl*c4-44._dbl*c2+6._dbl)*dchi1(3)) - zt7 = abs(zt7 - 0.9375_dbl*chi*(6._dbl*c4-4._dbl*c2-2._dbl)*dchi1(3)) - zt8 = abs(zt8 - 0.25_dbl*chi*(54._dbl*c4+40._dbl*c2-30._dbl)*dchi1(3)) - zt9 = abs(zt9 + 0.375_dbl*chi*(6._dbl*c4+20._dbl*c2-10._dbl)*dchi1(3)) - zt0 = abs(zt0 - 0.0625_dbl*chi*(6._dbl*c4+60._dbl*c2+30._dbl)*dchi1(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 x0', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 x0', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 x0', l1, l2, xt3 - IF (xt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 x0', l1, l2, xt4 - IF (xt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 x0', l1, l2, xt5 - IF (xt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 x0', l1, l2, xt6 - IF (xt7>1.E-12) WRITE (*,*) ' Error in test for gmu #7 x0', l1, l2, xt7 - IF (xt8>1.E-12) WRITE (*,*) ' Error in test for gmu #8 x0', l1, l2, xt8 - IF (xt9>1.E-12) WRITE (*,*) ' Error in test for gmu #9 x0', l1, l2, xt9 - IF (xt0>1.E-12) WRITE (*,*) ' Error in test for gmu #0 x0', l1, l2, xt0 - emax = max(emax,xt1,xt2,xt3,xt4,xt5,xt6,xt7,xt8,xt9,xt0) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 y0', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 y0', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 y0', l1, l2, yt3 - IF (yt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 y0', l1, l2, yt4 - IF (yt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 y0', l1, l2, yt5 - IF (yt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 y0', l1, l2, yt6 - IF (yt7>1.E-12) WRITE (*,*) ' Error in test for gmu #7 y0', l1, l2, yt7 - IF (yt8>1.E-12) WRITE (*,*) ' Error in test for gmu #8 y0', l1, l2, yt8 - IF (yt9>1.E-12) WRITE (*,*) ' Error in test for gmu #9 y0', l1, l2, yt9 - IF (yt0>1.E-12) WRITE (*,*) ' Error in test for gmu #0 y0', l1, l2, yt0 - emax = max(emax,yt1,yt2,yt3,yt4,yt5,yt6,yt7,yt8,yt9,yt0) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 z0', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 z0', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 z0', l1, l2, zt3 - IF (zt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 z0', l1, l2, zt4 - IF (zt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 z0', l1, l2, zt5 - IF (zt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 z0', l1, l2, zt6 - IF (zt7>1.E-12) WRITE (*,*) ' Error in test for gmu #7 z0', l1, l2, zt7 - IF (zt8>1.E-12) WRITE (*,*) ' Error in test for gmu #8 z0', l1, l2, zt8 - IF (zt9>1.E-12) WRITE (*,*) ' Error in test for gmu #9 z0', l1, l2, zt9 - IF (zt0>1.E-12) WRITE (*,*) ' Error in test for gmu #0 z0', l1, l2, zt0 - emax = max(emax,zt1,zt2,zt3,zt4,zt5,zt6,zt7,zt8,zt9,zt0) - dx1 = dpro(ddll1(:,:,0,1),dll2(:,:,0),l1,l2) - dx2 = dpro(ddll1(:,:,0,1),dll2(:,:,2),l1,l2) - dx3 = dpro(ddll1(:,:,0,1),dll2(:,:,4),l1,l2) - dx4 = dpro(ddll1(:,:,0,1),dll2(:,:,6),l1,l2) - dx5 = dpro(ddll1(:,:,2,1),dll2(:,:,2),l1,l2) - dx6 = dpro(ddll1(:,:,2,1),dll2(:,:,4),l1,l2) - dx7 = dpro(ddll1(:,:,2,1),dll2(:,:,6),l1,l2) - dx8 = dpro(ddll1(:,:,4,1),dll2(:,:,4),l1,l2) - dx9 = dpro(ddll1(:,:,4,1),dll2(:,:,6),l1,l2) - dx0 = dpro(ddll1(:,:,6,1),dll2(:,:,6),l1,l2) - dy1 = dpro(ddll1(:,:,0,2),dll2(:,:,0),l1,l2) - dy2 = dpro(ddll1(:,:,0,2),dll2(:,:,2),l1,l2) - dy3 = dpro(ddll1(:,:,0,2),dll2(:,:,4),l1,l2) - dy4 = dpro(ddll1(:,:,0,2),dll2(:,:,6),l1,l2) - dy5 = dpro(ddll1(:,:,2,2),dll2(:,:,2),l1,l2) - dy6 = dpro(ddll1(:,:,2,2),dll2(:,:,4),l1,l2) - dy7 = dpro(ddll1(:,:,2,2),dll2(:,:,6),l1,l2) - dy8 = dpro(ddll1(:,:,4,2),dll2(:,:,4),l1,l2) - dy9 = dpro(ddll1(:,:,4,2),dll2(:,:,6),l1,l2) - dy0 = dpro(ddll1(:,:,6,2),dll2(:,:,6),l1,l2) - dz1 = dpro(ddll1(:,:,0,3),dll2(:,:,0),l1,l2) - dz2 = dpro(ddll1(:,:,0,3),dll2(:,:,2),l1,l2) - dz3 = dpro(ddll1(:,:,0,3),dll2(:,:,4),l1,l2) - dz4 = dpro(ddll1(:,:,0,3),dll2(:,:,6),l1,l2) - dz5 = dpro(ddll1(:,:,2,3),dll2(:,:,2),l1,l2) - dz6 = dpro(ddll1(:,:,2,3),dll2(:,:,4),l1,l2) - dz7 = dpro(ddll1(:,:,2,3),dll2(:,:,6),l1,l2) - dz8 = dpro(ddll1(:,:,4,3),dll2(:,:,4),l1,l2) - dz9 = dpro(ddll1(:,:,4,3),dll2(:,:,6),l1,l2) - dz0 = dpro(ddll1(:,:,6,3),dll2(:,:,6),l1,l2) - dx1 = abs(dx1) - dx2 = abs(dx2) - dx3 = abs(dx3) - dx4 = abs(dx4) - dx5 = abs(dx5-10.08_dbl*chi*dchi1(1)) - dx6 = abs(dx6-1.44_dbl*chi*dchi1(1)) - dx7 = abs(dx7-2.4_dbl*chi*dchi1(1)) - dx8 = abs(dx8-0.04_dbl*chi*(880._dbl*c2-372._dbl)*dchi1(1)) - dx9 = abs(dx9-0.6_dbl*chi*(20._dbl*c2-8._dbl)*dchi1(1)) - dx0 = abs(dx0-0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi1(1)) - dy1 = abs(dy1) - dy2 = abs(dy2) - dy3 = abs(dy3) - dy4 = abs(dy4) - dy5 = abs(dy5-10.08_dbl*chi*dchi1(2)) - dy6 = abs(dy6-1.44_dbl*chi*dchi1(2)) - dy7 = abs(dy7-2.4_dbl*chi*dchi1(2)) - dy8 = abs(dy8-0.04_dbl*chi*(880._dbl*c2-372._dbl)*dchi1(2)) - dy9 = abs(dy9-0.6_dbl*chi*(20._dbl*c2-8._dbl)*dchi1(2)) - dy0 = abs(dy0-0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi1(2)) - dz1 = abs(dz1) - dz2 = abs(dz2) - dz3 = abs(dz3) - dz4 = abs(dz4) - dz5 = abs(dz5-10.08_dbl*chi*dchi1(3)) - dz6 = abs(dz6-1.44_dbl*chi*dchi1(3)) - dz7 = abs(dz7-2.4_dbl*chi*dchi1(3)) - dz8 = abs(dz8-0.04_dbl*chi*(880._dbl*c2-372._dbl)*dchi1(3)) - dz9 = abs(dz9-0.6_dbl*chi*(20._dbl*c2-8._dbl)*dchi1(3)) - dz0 = abs(dz0-0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi1(3)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 x0', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 x0', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 x0', l1, l2, dx3 - IF (dx4>1.E-12) WRITE (*,*) ' Error in test for dll #4 x0', l1, l2, dx4 - IF (dx5>1.E-12) WRITE (*,*) ' Error in test for dll #5 x0', l1, l2, dx5 - IF (dx6>1.E-12) WRITE (*,*) ' Error in test for dll #6 x0', l1, l2, dx6 - IF (dx7>1.E-12) WRITE (*,*) ' Error in test for dll #7 x0', l1, l2, dx7 - IF (dx8>1.E-12) WRITE (*,*) ' Error in test for dll #8 x0', l1, l2, dx8 - IF (dx9>1.E-12) WRITE (*,*) ' Error in test for dll #9 x0', l1, l2, dx9 - IF (dx0>1.E-12) WRITE (*,*) ' Error in test for dll #0 x0', l1, l2, dx0 - emax = max(emax,dx1,dx2,dx3,dx4,dx5,dx6,dx7,dx8,dx9,dx0) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 y0', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 y0', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 y0', l1, l2, dy3 - IF (dy4>1.E-12) WRITE (*,*) ' Error in test for dll #4 y0', l1, l2, dy4 - IF (dy5>1.E-12) WRITE (*,*) ' Error in test for dll #5 y0', l1, l2, dy5 - IF (dy6>1.E-12) WRITE (*,*) ' Error in test for dll #6 y0', l1, l2, dy6 - IF (dy7>1.E-12) WRITE (*,*) ' Error in test for dll #7 y0', l1, l2, dy7 - IF (dy8>1.E-12) WRITE (*,*) ' Error in test for dll #8 y0', l1, l2, dy8 - IF (dy9>1.E-12) WRITE (*,*) ' Error in test for dll #9 y0', l1, l2, dy9 - IF (dy0>1.E-12) WRITE (*,*) ' Error in test for dll #0 y0', l1, l2, dy0 - emax = max(emax,dy1,dy2,dy3,dy4,dy5,dy6,dy7,dy8,dy9,dy0) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 z0', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 z0', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 z0', l1, l2, dz3 - IF (dz4>1.E-12) WRITE (*,*) ' Error in test for dll #4 z0', l1, l2, dz4 - IF (dz5>1.E-12) WRITE (*,*) ' Error in test for dll #5 z0', l1, l2, dz5 - IF (dz6>1.E-12) WRITE (*,*) ' Error in test for dll #6 z0', l1, l2, dz6 - IF (dz7>1.E-12) WRITE (*,*) ' Error in test for dll #7 z0', l1, l2, dz7 - IF (dz8>1.E-12) WRITE (*,*) ' Error in test for dll #8 z0', l1, l2, dz8 - IF (dz9>1.E-12) WRITE (*,*) ' Error in test for dll #9 z0', l1, l2, dz9 - IF (dz0>1.E-12) WRITE (*,*) ' Error in test for dll #0 z0', l1, l2, dz0 - emax = max(emax,dz1,dz2,dz3,dz4,dz5,dz6,dz7,dz8,dz9,dz0) -! f-df - xt1 = dpro(gmu1(:,:,0),dgmu2(:,:,0,1),l1,l2) - xt2 = dpro(gmu1(:,:,0),dgmu2(:,:,1,1),l1,l2) - xt3 = dpro(gmu1(:,:,0),dgmu2(:,:,2,1),l1,l2) - xt4 = dpro(gmu1(:,:,0),dgmu2(:,:,3,1),l1,l2) - xt5 = dpro(gmu1(:,:,1),dgmu2(:,:,1,1),l1,l2) - xt6 = dpro(gmu1(:,:,1),dgmu2(:,:,2,1),l1,l2) - xt7 = dpro(gmu1(:,:,1),dgmu2(:,:,3,1),l1,l2) - xt8 = dpro(gmu1(:,:,2),dgmu2(:,:,2,1),l1,l2) - xt9 = dpro(gmu1(:,:,2),dgmu2(:,:,3,1),l1,l2) - xt0 = dpro(gmu1(:,:,3),dgmu2(:,:,3,1),l1,l2) - yt1 = dpro(gmu1(:,:,0),dgmu2(:,:,0,2),l1,l2) - yt2 = dpro(gmu1(:,:,0),dgmu2(:,:,1,2),l1,l2) - yt3 = dpro(gmu1(:,:,0),dgmu2(:,:,2,2),l1,l2) - yt4 = dpro(gmu1(:,:,0),dgmu2(:,:,3,2),l1,l2) - yt5 = dpro(gmu1(:,:,1),dgmu2(:,:,1,2),l1,l2) - yt6 = dpro(gmu1(:,:,1),dgmu2(:,:,2,2),l1,l2) - yt7 = dpro(gmu1(:,:,1),dgmu2(:,:,3,2),l1,l2) - yt8 = dpro(gmu1(:,:,2),dgmu2(:,:,2,2),l1,l2) - yt9 = dpro(gmu1(:,:,2),dgmu2(:,:,3,2),l1,l2) - yt0 = dpro(gmu1(:,:,3),dgmu2(:,:,3,2),l1,l2) - zt1 = dpro(gmu1(:,:,0),dgmu2(:,:,0,3),l1,l2) - zt2 = dpro(gmu1(:,:,0),dgmu2(:,:,1,3),l1,l2) - zt3 = dpro(gmu1(:,:,0),dgmu2(:,:,2,3),l1,l2) - zt4 = dpro(gmu1(:,:,0),dgmu2(:,:,3,3),l1,l2) - zt5 = dpro(gmu1(:,:,1),dgmu2(:,:,1,3),l1,l2) - zt6 = dpro(gmu1(:,:,1),dgmu2(:,:,2,3),l1,l2) - zt7 = dpro(gmu1(:,:,1),dgmu2(:,:,3,3),l1,l2) - zt8 = dpro(gmu1(:,:,2),dgmu2(:,:,2,3),l1,l2) - zt9 = dpro(gmu1(:,:,2),dgmu2(:,:,3,3),l1,l2) - zt0 = dpro(gmu1(:,:,3),dgmu2(:,:,3,3),l1,l2) - xt1 = abs(xt1 - 0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi2(1)) - xt2 = abs(xt2 + 0.375_dbl*chi*(150._dbl*c4-140._dbl*c2+22._dbl)*dchi2(1)) - xt3 = abs(xt3 - 3.75_dbl*chi*(6._dbl*c4-8._dbl*c2+2._dbl)*dchi2(1)) - xt4 = abs(xt4 + 0.625_dbl*chi*(6._dbl*c4-12._dbl*c2+6._dbl)*dchi2(1)) - xt5 = abs(xt5 - 0.0625_dbl*chi*(1350._dbl*c4-1220._dbl*c2+222._dbl)*dchi2(1)) - xt6 = abs(xt6 + 0.625_dbl*chi*(54._dbl*c4-44._dbl*c2+6._dbl)*dchi2(1)) - xt7 = abs(xt7 - 0.9375_dbl*chi*(6._dbl*c4-4._dbl*c2-2._dbl)*dchi2(1)) - xt8 = abs(xt8 - 0.25_dbl*chi*(54._dbl*c4+40._dbl*c2-30._dbl)*dchi2(1)) - xt9 = abs(xt9 + 0.375_dbl*chi*(6._dbl*c4+20._dbl*c2-10._dbl)*dchi2(1)) - xt0 = abs(xt0 - 0.0625_dbl*chi*(6._dbl*c4+60._dbl*c2+30._dbl)*dchi2(1)) - yt1 = abs(yt1 - 0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi2(2)) - yt2 = abs(yt2 + 0.375_dbl*chi*(150._dbl*c4-140._dbl*c2+22._dbl)*dchi2(2)) - yt3 = abs(yt3 - 3.75_dbl*chi*(6._dbl*c4-8._dbl*c2+2._dbl)*dchi2(2)) - yt4 = abs(yt4 + 0.625_dbl*chi*(6._dbl*c4-12._dbl*c2+6._dbl)*dchi2(2)) - yt5 = abs(yt5 - 0.0625_dbl*chi*(1350._dbl*c4-1220._dbl*c2+222._dbl)*dchi2(2)) - yt6 = abs(yt6 + 0.625_dbl*chi*(54._dbl*c4-44._dbl*c2+6._dbl)*dchi2(2)) - yt7 = abs(yt7 - 0.9375_dbl*chi*(6._dbl*c4-4._dbl*c2-2._dbl)*dchi2(2)) - yt8 = abs(yt8 - 0.25_dbl*chi*(54._dbl*c4+40._dbl*c2-30._dbl)*dchi2(2)) - yt9 = abs(yt9 + 0.375_dbl*chi*(6._dbl*c4+20._dbl*c2-10._dbl)*dchi2(2)) - yt0 = abs(yt0 - 0.0625_dbl*chi*(6._dbl*c4+60._dbl*c2+30._dbl)*dchi2(2)) - zt1 = abs(zt1 - 0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi2(3)) - zt2 = abs(zt2 + 0.375_dbl*chi*(150._dbl*c4-140._dbl*c2+22._dbl)*dchi2(3)) - zt3 = abs(zt3 - 3.75_dbl*chi*(6._dbl*c4-8._dbl*c2+2._dbl)*dchi2(3)) - zt4 = abs(zt4 + 0.625_dbl*chi*(6._dbl*c4-12._dbl*c2+6._dbl)*dchi2(3)) - zt5 = abs(zt5 - 0.0625_dbl*chi*(1350._dbl*c4-1220._dbl*c2+222._dbl)*dchi2(3)) - zt6 = abs(zt6 + 0.625_dbl*chi*(54._dbl*c4-44._dbl*c2+6._dbl)*dchi2(3)) - zt7 = abs(zt7 - 0.9375_dbl*chi*(6._dbl*c4-4._dbl*c2-2._dbl)*dchi2(3)) - zt8 = abs(zt8 - 0.25_dbl*chi*(54._dbl*c4+40._dbl*c2-30._dbl)*dchi2(3)) - zt9 = abs(zt9 + 0.375_dbl*chi*(6._dbl*c4+20._dbl*c2-10._dbl)*dchi2(3)) - zt0 = abs(zt0 - 0.0625_dbl*chi*(6._dbl*c4+60._dbl*c2+30._dbl)*dchi2(3)) - IF (xt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0x', l1, l2, xt1 - IF (xt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0x', l1, l2, xt2 - IF (xt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0x', l1, l2, xt3 - IF (xt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 0x', l1, l2, xt4 - IF (xt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 0x', l1, l2, xt5 - IF (xt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 0x', l1, l2, xt6 - IF (xt7>1.E-12) WRITE (*,*) ' Error in test for gmu #7 0x', l1, l2, xt7 - IF (xt8>1.E-12) WRITE (*,*) ' Error in test for gmu #8 0x', l1, l2, xt8 - IF (xt9>1.E-12) WRITE (*,*) ' Error in test for gmu #9 0x', l1, l2, xt9 - IF (xt0>1.E-12) WRITE (*,*) ' Error in test for gmu #0 0x', l1, l2, xt0 - emax = max(emax,xt1,xt2,xt3,xt4,xt5,xt6,xt7,xt8,xt9,xt0) - IF (yt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0y', l1, l2, yt1 - IF (yt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0y', l1, l2, yt2 - IF (yt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0y', l1, l2, yt3 - IF (yt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 0y', l1, l2, yt4 - IF (yt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 0y', l1, l2, yt5 - IF (yt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 0y', l1, l2, yt6 - IF (yt7>1.E-12) WRITE (*,*) ' Error in test for gmu #7 0y', l1, l2, yt7 - IF (yt8>1.E-12) WRITE (*,*) ' Error in test for gmu #8 0y', l1, l2, yt8 - IF (yt9>1.E-12) WRITE (*,*) ' Error in test for gmu #9 0y', l1, l2, yt9 - IF (yt0>1.E-12) WRITE (*,*) ' Error in test for gmu #0 0y', l1, l2, yt0 - emax = max(emax,yt1,yt2,yt3,yt4,yt5,yt6,yt7,yt8,yt9,yt0) - IF (zt1>1.E-12) WRITE (*,*) ' Error in test for gmu #1 0z', l1, l2, zt1 - IF (zt2>1.E-12) WRITE (*,*) ' Error in test for gmu #2 0z', l1, l2, zt2 - IF (zt3>1.E-12) WRITE (*,*) ' Error in test for gmu #3 0z', l1, l2, zt3 - IF (zt4>1.E-12) WRITE (*,*) ' Error in test for gmu #4 0z', l1, l2, zt4 - IF (zt5>1.E-12) WRITE (*,*) ' Error in test for gmu #5 0z', l1, l2, zt5 - IF (zt6>1.E-12) WRITE (*,*) ' Error in test for gmu #6 0z', l1, l2, zt6 - IF (zt7>1.E-12) WRITE (*,*) ' Error in test for gmu #7 0z', l1, l2, zt7 - IF (zt8>1.E-12) WRITE (*,*) ' Error in test for gmu #8 0z', l1, l2, zt8 - IF (zt9>1.E-12) WRITE (*,*) ' Error in test for gmu #9 0z', l1, l2, zt9 - IF (zt0>1.E-12) WRITE (*,*) ' Error in test for gmu #0 0z', l1, l2, zt0 - emax = max(emax,zt1,zt2,zt3,zt4,zt5,zt6,zt7,zt8,zt9,zt0) - dx1 = dpro(dll1(:,:,0),ddll2(:,:,0,1),l1,l2) - dx2 = dpro(dll1(:,:,0),ddll2(:,:,2,1),l1,l2) - dx3 = dpro(dll1(:,:,0),ddll2(:,:,4,1),l1,l2) - dx4 = dpro(dll1(:,:,0),ddll2(:,:,6,1),l1,l2) - dx5 = dpro(dll1(:,:,2),ddll2(:,:,2,1),l1,l2) - dx6 = dpro(dll1(:,:,2),ddll2(:,:,4,1),l1,l2) - dx7 = dpro(dll1(:,:,2),ddll2(:,:,6,1),l1,l2) - dx8 = dpro(dll1(:,:,4),ddll2(:,:,4,1),l1,l2) - dx9 = dpro(dll1(:,:,4),ddll2(:,:,6,1),l1,l2) - dx0 = dpro(dll1(:,:,6),ddll2(:,:,6,1),l1,l2) - dy1 = dpro(dll1(:,:,0),ddll2(:,:,0,2),l1,l2) - dy2 = dpro(dll1(:,:,0),ddll2(:,:,2,2),l1,l2) - dy3 = dpro(dll1(:,:,0),ddll2(:,:,4,2),l1,l2) - dy4 = dpro(dll1(:,:,0),ddll2(:,:,6,2),l1,l2) - dy5 = dpro(dll1(:,:,2),ddll2(:,:,2,2),l1,l2) - dy6 = dpro(dll1(:,:,2),ddll2(:,:,4,2),l1,l2) - dy7 = dpro(dll1(:,:,2),ddll2(:,:,6,2),l1,l2) - dy8 = dpro(dll1(:,:,4),ddll2(:,:,4,2),l1,l2) - dy9 = dpro(dll1(:,:,4),ddll2(:,:,6,2),l1,l2) - dy0 = dpro(dll1(:,:,6),ddll2(:,:,6,2),l1,l2) - dz1 = dpro(dll1(:,:,0),ddll2(:,:,0,3),l1,l2) - dz2 = dpro(dll1(:,:,0),ddll2(:,:,2,3),l1,l2) - dz3 = dpro(dll1(:,:,0),ddll2(:,:,4,3),l1,l2) - dz4 = dpro(dll1(:,:,0),ddll2(:,:,6,3),l1,l2) - dz5 = dpro(dll1(:,:,2),ddll2(:,:,2,3),l1,l2) - dz6 = dpro(dll1(:,:,2),ddll2(:,:,4,3),l1,l2) - dz7 = dpro(dll1(:,:,2),ddll2(:,:,6,3),l1,l2) - dz8 = dpro(dll1(:,:,4),ddll2(:,:,4,3),l1,l2) - dz9 = dpro(dll1(:,:,4),ddll2(:,:,6,3),l1,l2) - dz0 = dpro(dll1(:,:,6),ddll2(:,:,6,3),l1,l2) - dx1 = abs(dx1) - dx2 = abs(dx2) - dx3 = abs(dx3) - dx4 = abs(dx4) - dx5 = abs(dx5-10.08_dbl*chi*dchi2(1)) - dx6 = abs(dx6-1.44_dbl*chi*dchi2(1)) - dx7 = abs(dx7-2.4_dbl*chi*dchi2(1)) - dx8 = abs(dx8-0.04_dbl*chi*(880._dbl*c2-372._dbl)*dchi2(1)) - dx9 = abs(dx9-0.6_dbl*chi*(20._dbl*c2-8._dbl)*dchi2(1)) - dx0 = abs(dx0-0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi2(1)) - dy1 = abs(dy1) - dy2 = abs(dy2) - dy3 = abs(dy3) - dy4 = abs(dy4) - dy5 = abs(dy5-10.08_dbl*chi*dchi2(2)) - dy6 = abs(dy6-1.44_dbl*chi*dchi2(2)) - dy7 = abs(dy7-2.4_dbl*chi*dchi2(2)) - dy8 = abs(dy8-0.04_dbl*chi*(880._dbl*c2-372._dbl)*dchi2(2)) - dy9 = abs(dy9-0.6_dbl*chi*(20._dbl*c2-8._dbl)*dchi2(2)) - dy0 = abs(dy0-0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi2(2)) - dz1 = abs(dz1) - dz2 = abs(dz2) - dz3 = abs(dz3) - dz4 = abs(dz4) - dz5 = abs(dz5-10.08_dbl*chi*dchi2(3)) - dz6 = abs(dz6-1.44_dbl*chi*dchi2(3)) - dz7 = abs(dz7-2.4_dbl*chi*dchi2(3)) - dz8 = abs(dz8-0.04_dbl*chi*(880._dbl*c2-372._dbl)*dchi2(3)) - dz9 = abs(dz9-0.6_dbl*chi*(20._dbl*c2-8._dbl)*dchi2(3)) - dz0 = abs(dz0-0.25_dbl*chi*(150._dbl*c4-120._dbl*c2+18._dbl)*dchi2(3)) - IF (dx1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0x', l1, l2, dx1 - IF (dx2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0x', l1, l2, dx2 - IF (dx3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0x', l1, l2, dx3 - IF (dx4>1.E-12) WRITE (*,*) ' Error in test for dll #4 0x', l1, l2, dx4 - IF (dx5>1.E-12) WRITE (*,*) ' Error in test for dll #5 0x', l1, l2, dx5 - IF (dx6>1.E-12) WRITE (*,*) ' Error in test for dll #6 0x', l1, l2, dx6 - IF (dx7>1.E-12) WRITE (*,*) ' Error in test for dll #7 0x', l1, l2, dx7 - IF (dx8>1.E-12) WRITE (*,*) ' Error in test for dll #8 0x', l1, l2, dx8 - IF (dx9>1.E-12) WRITE (*,*) ' Error in test for dll #9 0x', l1, l2, dx9 - IF (dx0>1.E-12) WRITE (*,*) ' Error in test for dll #0 0x', l1, l2, dx0 - emax = max(emax,dx1,dx2,dx3,dx4,dx5,dx6,dx7,dx8,dx9,dx0) - IF (dy1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0y', l1, l2, dy1 - IF (dy2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0y', l1, l2, dy2 - IF (dy3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0y', l1, l2, dy3 - IF (dy4>1.E-12) WRITE (*,*) ' Error in test for dll #4 0y', l1, l2, dy4 - IF (dy5>1.E-12) WRITE (*,*) ' Error in test for dll #5 0y', l1, l2, dy5 - IF (dy6>1.E-12) WRITE (*,*) ' Error in test for dll #6 0y', l1, l2, dy6 - IF (dy7>1.E-12) WRITE (*,*) ' Error in test for dll #7 0y', l1, l2, dy7 - IF (dy8>1.E-12) WRITE (*,*) ' Error in test for dll #8 0y', l1, l2, dy8 - IF (dy9>1.E-12) WRITE (*,*) ' Error in test for dll #9 0y', l1, l2, dy9 - IF (dy0>1.E-12) WRITE (*,*) ' Error in test for dll #0 0y', l1, l2, dy0 - emax = max(emax,dy1,dy2,dy3,dy4,dy5,dy6,dy7,dy8,dy9,dy0) - IF (dz1>1.E-12) WRITE (*,*) ' Error in test for dll #1 0z', l1, l2, dz1 - IF (dz2>1.E-12) WRITE (*,*) ' Error in test for dll #2 0z', l1, l2, dz2 - IF (dz3>1.E-12) WRITE (*,*) ' Error in test for dll #3 0z', l1, l2, dz3 - IF (dz4>1.E-12) WRITE (*,*) ' Error in test for dll #4 0z', l1, l2, dz4 - IF (dz5>1.E-12) WRITE (*,*) ' Error in test for dll #5 0z', l1, l2, dz5 - IF (dz6>1.E-12) WRITE (*,*) ' Error in test for dll #6 0z', l1, l2, dz6 - IF (dz7>1.E-12) WRITE (*,*) ' Error in test for dll #7 0z', l1, l2, dz7 - IF (dz8>1.E-12) WRITE (*,*) ' Error in test for dll #8 0z', l1, l2, dz8 - IF (dz9>1.E-12) WRITE (*,*) ' Error in test for dll #9 0z', l1, l2, dz9 - IF (dz0>1.E-12) WRITE (*,*) ' Error in test for dll #0 0z', l1, l2, dz0 - emax = max(emax,dz1,dz2,dz3,dz4,dz5,dz6,dz7,dz8,dz9,dz0) - END SUBROUTINE df_test -!------------------------------------------------------------------------------! - END MODULE slater_koster_test -!------------------------------------------------------------------------------! diff --git a/src/slater_koster_util.cpp b/src/slater_koster_util.cpp index 9da14f9..475008d 100644 --- a/src/slater_koster_util.cpp +++ b/src/slater_koster_util.cpp @@ -2,7 +2,7 @@ /*----------------------------------------------------------------------------*/ /* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2000 CP2K developers group */ +/* Copyright (C) 2024 CP2K developers group */ /*----------------------------------------------------------------------------*/ // Some utility functions for the Slater-Koster Modules // diff --git a/src/splines.F b/src/splines.c similarity index 100% rename from src/splines.F rename to src/splines.c diff --git a/src/stop.h b/src/stop.h new file mode 100644 index 0000000..ba31a1c --- /dev/null +++ b/src/stop.h @@ -0,0 +1,16 @@ +#ifndef _STOP_H +#define _STOP_H + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + void set_stop(int); + void stop_prg(char *, char *, char *, char *, char *, char *); + void stop_allocate(char *, char *, int); + void stop_deallocate(); + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/stop_program.F b/src/stop_program.F deleted file mode 100644 index 6ff43b7..0000000 --- a/src/stop_program.F +++ /dev/null @@ -1,172 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE stop_program - - USE kinds, ONLY : dbl - USE mp, ONLY : mp_stop - USE string_utilities, ONLY : compress - - IMPLICIT NONE - - INTERFACE stop_memory - MODULE PROCEDURE stop_allocate,stop_deallocate - END INTERFACE - - PRIVATE - PUBLIC :: set_stop, stop_prg, stop_memory - - INTEGER :: iw - -CONTAINS - -!****************************************************************************** - -!! Initialise the output channel and the processor number - -SUBROUTINE set_stop ( output_channel ) - - IMPLICIT NONE - - INTEGER :: output_channel - - iw = output_channel - -END SUBROUTINE set_stop - -!****************************************************************************** - -!! stop the program and write some final comments to the output - -SUBROUTINE stop_prg ( routine, & - comment1, comment2, comment3, comment4, comment5 ) - - IMPLICIT NONE - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ), OPTIONAL :: & - routine, comment1, comment2, comment3, comment4, comment5 - -! Locals - INTEGER :: i - CHARACTER ( LEN = 50 ) :: outline - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( routine ) ) THEN - i = LEN_TRIM ( routine ) - outline = routine ( 1:i ) - WRITE ( iw, '( A, T31, A )' ) & - " Last routine executed ", ADJUSTR ( outline ) - END IF - - IF ( PRESENT ( comment1 ) ) THEN - i = LEN_TRIM ( comment1 ) - outline = comment1 ( 1:i ) - WRITE ( iw, '( A, T31, A )' ) " Comment ", ADJUSTR ( outline ) - END IF - - IF ( PRESENT ( comment2 ) ) THEN - i = LEN_TRIM ( comment2 ) - outline = comment2 ( 1:i ) - WRITE ( iw, '( A, T31, A )' ) " Comment ", ADJUSTR ( outline ) - END IF - - IF ( PRESENT ( comment3 ) ) THEN - i = LEN_TRIM ( comment3 ) - outline = comment3 ( 1:i ) - WRITE ( iw, '( A, T31, A )' ) " Comment ", ADJUSTR ( outline ) - END IF - - IF ( PRESENT ( comment4 ) ) THEN - i = LEN_TRIM ( comment4 ) - outline = comment4 ( 1:i ) - WRITE ( iw, '( A, T31, A )' ) " Comment ", ADJUSTR ( outline ) - END IF - - IF ( PRESENT ( comment5 ) ) THEN - i = LEN_TRIM ( comment5 ) - outline = comment5 ( 1:i ) - WRITE ( iw, '( A, T31, A )' ) " Comment ", ADJUSTR ( outline ) - END IF - - CALL mp_stop ( 999 ) - -END SUBROUTINE stop_prg - -!****************************************************************************** - -SUBROUTINE stop_allocate ( routine, array, memory ) - -! Purpose: The memory allocation for an array failed. Print an error message -! and stop the program execution. - -! History: - Creation (12.10.1999, Matthias Krack) -! CP2K by JH 21.08.2000 - -! array: Name of the array. -! memory: Size of array in bytes. -! routine: Name of the calling routine. - -! *************************************************************************** - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: array, routine - INTEGER, INTENT ( IN ) :: memory - -! Locals - CHARACTER ( LEN = 50 ) :: message_1, message_2 - -!------------------------------------------------------------------------------ - - IF (memory == 0) THEN - WRITE (message_1,"(A)")& - "Memory allocation for <"//TRIM(array)//"> failed" - CALL stop_prg(routine,message_1) - ELSE - WRITE (message_1,"(A,I12,A)")& - "Memory allocation for <"//TRIM(array)//"> failed" - WRITE (message_2,"(A,I12,A)")& - "Requested memory size is ",memory/1024," Kbytes" - CALL compress(message_2) - CALL stop_prg(routine,message_1,message_2) - END IF - -END SUBROUTINE stop_allocate - -!****************************************************************************** - -SUBROUTINE stop_deallocate ( routine, array ) - -! Purpose: The memory deallocation for an array failed. Print an error -! message and stop the program execution. - -! History: - Creation (20.10.1999, Matthias Krack) -! CP2K by JH 21.08.2000 - -! *************************************************************************** - -! array: Name of the array. -! routine: Name of the calling routine. - -! *************************************************************************** - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: array, routine - -! Locals - CHARACTER ( LEN = 50 ) :: message - -!------------------------------------------------------------------------------ - - WRITE ( message, '( A )' ) & - "Memory allocation for <" // TRIM ( array ) // "> failed" - CALL stop_prg ( routine, message ) - -END SUBROUTINE stop_deallocate - -!****************************************************************************** - -END MODULE stop_program diff --git a/src/stop_program.cpp b/src/stop_program.cpp new file mode 100644 index 0000000..fbdec3e --- /dev/null +++ b/src/stop_program.cpp @@ -0,0 +1,66 @@ +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ + +#include +#include + +int iw; + +// Initialise the output channel and the processor number +void set_stop(int output_channel) { + iw = output_channel; +} + +void stop_prg(std::string routine, std::string comment1, std::string comment2, + std::string comment3, std::string comment4, std::string comment5) { + int i; + char outline[50]; + + if (routine) { + i = routine.length(); + outline = routine.copy(); + std::cout << " Last routine executed " << outline << "\n"; + } + + if (comment1) { + i = comment1.length(); + outline = comment1.copy(); + std::cout << " Comment " << outline << "\n"; + } + + if (comment2) { + i = comment1.length(); + outline = comment2.copy(); + std::cout << " Comment " << outline << "\n"; + } + + if (comment3) { + i = comment1.length(); + outline = comment3.copy(); + std::cout << " Comment " << outline << "\n"; + } + + if (comment4) { + i = comment1.length(); + outline = comment4.copy(); + std::cout << " Comment " << outline << "\n"; + } + + if (comment5) { + i = comment1.length(); + outline = comment5.copy(); + std::cout << " Comment " << outline << "\n"; + } + + mp_stop(999); +} + +void stop_allocate(std::string routine, std::string array, int memory) { + char message_1[50], message_2[50]; + + if (memory == 0) { + std::cout << "Memory allocation for <" << array << "failed"; + } +} \ No newline at end of file diff --git a/src/string_utilities.F b/src/string_utilities.c similarity index 100% rename from src/string_utilities.F rename to src/string_utilities.c diff --git a/src/structure.h b/src/structure.h new file mode 100644 index 0000000..5b2049a --- /dev/null +++ b/src/structure.h @@ -0,0 +1,27 @@ +#ifndef _STRUCTURE_H +#define _STRUCTURE_H + +#include "timings.h" +#include + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + + typedef struct structure_factor_type { + double complex **ex, **ey, **ez; + int **centre; + int lb[3]; + } structure_factor_type; + + void structure_factor_deallocate(structure_factor_type); + void structure_factor_allocate(int*, int, structure_factor_type, bool); + + void structure_factor_evaluate(double*, int*, int*, double complex*, + double complex*, double complex*); + +#ifdef __cplusplus +} +#endif + +#endif \ No newline at end of file diff --git a/src/structure_factor_types.F b/src/structure_factor_types.c similarity index 100% rename from src/structure_factor_types.F rename to src/structure_factor_types.c diff --git a/src/structure_factors.F b/src/structure_factors.F deleted file mode 100644 index 0732436..0000000 --- a/src/structure_factors.F +++ /dev/null @@ -1,150 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE structure_factors - - USE kinds, ONLY : dbl - USE mathconstants, ONLY : twopi - USE stop_program, ONLY : stop_memory - USE structure_factor_types, ONLY : structure_factor_type - - IMPLICIT NONE - - PRIVATE - PUBLIC :: structure_factor_evaluate, structure_factor_allocate - PUBLIC :: structure_factor_deallocate - -CONTAINS - -!***************************************************************************** - -SUBROUTINE structure_factor_deallocate ( exp_igr ) - - IMPLICIT NONE - -! Arguments - TYPE ( structure_factor_type ), INTENT ( INOUT ) :: exp_igr - -! Locals - INTEGER :: isos - -!------------------------------------------------------------------------------ - - DEALLOCATE ( exp_igr % ex, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ('ewald_polynomial', 'ex') - DEALLOCATE ( exp_igr % ey, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ('ewald_polynomial', 'ey') - DEALLOCATE ( exp_igr % ez, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ('ewald_polynomial', 'ez') - - IF ( ASSOCIATED ( exp_igr % centre ) ) THEN - DEALLOCATE ( exp_igr % centre, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ('ewald_polynomial', 'centre' ) - END IF - -END SUBROUTINE structure_factor_deallocate - -!***************************************************************************** - -SUBROUTINE structure_factor_allocate ( bds, nparts, exp_igr, & - allocate_centre) - IMPLICIT NONE - -! Arguments - TYPE ( structure_factor_type ), INTENT ( OUT ) :: exp_igr - INTEGER, DIMENSION ( :, : ), INTENT ( IN ) :: bds - INTEGER, INTENT ( IN ) :: nparts - LOGICAL, INTENT ( IN ), OPTIONAL :: allocate_centre - -! Locals - INTEGER :: isos - -!------------------------------------------------------------------------------ - - ALLOCATE ( exp_igr % ex ( bds ( 1, 1 ):bds ( 2, 1 ) + 1, nparts ), & - STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'ewald_gaussian', 'ex', 0 ) - ALLOCATE ( exp_igr % ey ( bds ( 1, 2 ):bds ( 2, 2 ) + 1, nparts ), & - STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ('ewald_gaussian', 'ey', 0 ) - ALLOCATE ( exp_igr % ez ( bds ( 1, 3 ):bds ( 2, 3 ) + 1, nparts ), & - STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ('ewald_gaussian', 'ez', 0 ) - NULLIFY ( exp_igr % centre ) - - exp_igr % lb(1) = LBOUND ( exp_igr % ex, 1 ) - exp_igr % lb(2) = LBOUND ( exp_igr % ey, 1 ) - exp_igr % lb(3) = LBOUND ( exp_igr % ez, 1 ) - - IF ( PRESENT ( allocate_centre ) ) THEN - IF ( allocate_centre ) THEN - ALLOCATE ( exp_igr % centre ( 3, nparts ), STAT = isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( 'ewald_gaussian', 'centre', 3 * nparts) - END IF - END IF - -END SUBROUTINE structure_factor_allocate - -!***************************************************************************** - -SUBROUTINE structure_factor_evaluate ( delta, npts, lb, ex, ey, ez ) - - IMPLICIT NONE - -! Arguments - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: lb, npts - COMPLEX ( dbl ), DIMENSION ( lb(1): ), INTENT ( out ) :: ex - COMPLEX ( dbl ), DIMENSION ( lb(2): ), INTENT ( out ) :: ey - COMPLEX ( dbl ), DIMENSION ( lb(3): ), INTENT ( out ) :: ez - REAL ( dbl ), DIMENSION ( : ), INTENT ( in ) :: delta - -! Locals - REAL ( dbl ) :: vec ( 3 ) - COMPLEX ( dbl ) :: fp, fm - INTEGER :: l0, m0, n0, j, l1, m1, n1 - -!------------------------------------------------------------------------------ - - l0 = LBOUND ( ex, 1 ) - l1 = UBOUND ( ex, 1 ) - m0 = LBOUND ( ey, 1 ) - m1 = UBOUND ( ey, 1 ) - n0 = LBOUND ( ez, 1 ) - n1 = UBOUND ( ez, 1 ) - -! delta is in scaled coordinates - vec ( : ) = twopi * ( delta ( : ) + 0.5_dbl ) - - ex ( l0 ) = 1.0_dbl - ey ( m0 ) = 1.0_dbl - ez ( n0 ) = 1.0_dbl - ex ( l1 ) = 1.0_dbl - ey ( m1 ) = 1.0_dbl - ez ( n1 ) = 1.0_dbl - - fp = CMPLX ( COS ( vec ( 1 ) ), -SIN ( vec ( 1 ) ) ); fm = CONJG ( fp ) - DO j = 1, -l0 - ex ( j + l0 ) = ex ( j + l0 - 1 ) * fp - ex ( -j + l1 ) = ex ( -j + l1 + 1 ) * fm - END DO - - fp = CMPLX ( COS ( vec ( 2 ) ), -SIN ( vec ( 2 ) ) ); fm = CONJG ( fp ) - DO j = 1, -m0 - ey ( j + m0 ) = ey ( j + m0 - 1 ) * fp - ey ( -j + m1 ) = ey ( -j + m1 + 1 ) * fm - END DO - - fp = CMPLX ( COS ( vec ( 3 ) ), -SIN ( vec ( 3 ) ) ); fm = CONJG ( fp ) - DO j = 1, -n0 - ez ( j + n0 ) = ez ( j + n0 - 1 ) * fp - ez ( -j + n1 ) = ez ( -j + n1 + 1 ) * fm - END DO - -END SUBROUTINE structure_factor_evaluate - -!***************************************************************************** - -END MODULE structure_factors diff --git a/src/structure_factors.c b/src/structure_factors.c new file mode 100644 index 0000000..00fb20c --- /dev/null +++ b/src/structure_factors.c @@ -0,0 +1,91 @@ +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ + +#include +#include + +void structure_factor_deallocate(structure_factor_type exp_igr) { + + free(exp_igr.ex); + free(exp_igr.ey); + free(exp_igr.ez); + if (exp_igr.centre != NULL) { + free(exp_igr.centre); + } + +} + +void structure_factor_allocate(int *bds, int nparts, structure_factor_type exp_igr, bool allocate_centre) { + + int isos; + + exp_igr.ex = (double complex *)malloc((bds[1][1] - bds[2][1] + 1) * nparts * sizeof(double complex)); + + + exp_igr.ey = (double complex *)malloc((bds[1][2] - bds[2][2] + 1) * nparts * sizeof(double complex)); + + exp_igr.ez = (double complex *)malloc((bds[1][3] - bds[2][3] + 1) * nparts * sizeof(double complex)); + + exp_igr.centre = NULL; + + + exp_igr.lb[0] = 0; + exp_igr.lb[1] = 0; + exp_igr.lb[2] = 0; + + if (allocate_centre) { + exp_igr.centre = (double *)malloc(3 * nparts * sizeof(double)); + } + +} + +void structure_factor_evaluate(double *delta, int *npts, int *lb, double complex *ex, + double complex *ey, double complex *ez) { + + double vec[3]; + double complex fp, fm; + int l0, m0, n0, j, l1, m1, n1; + + l0 = lb[0]; + l1 = lb[1]; + m0 = lb[2]; + m1 = lb[3]; + n0 = lb[4]; + n1 = lb[5]; + + // delta is in scaled coordinates + vec[0] = twopi * (delta[0] + 0.5); + vec[1] = twopi * (delta[1] + 0.5); + vec[2] = twopi * (delta[2] + 0.5); + + ex[l0] = 1.0; + ey[m0] = 1.0; + ez[n0] = 1.0; + ex[l1] = 1.0; + ey[m1] = 1.0; + ez[n1] = 1.0; + + fp = cos(vec[0]) - I * sin(vec[0]); + fm = conj(fp); + for (j = 0; j >= -l0; j--) { + ex[j + l0] = ex[j + l0 - 1] * fp; + ex[-j + l1] = ex[-j + l1 + 1] * fm; + } + + fp = cos(vec[1]) - I * sin(vec[1]); + fm = conj(fp); + for (j = 0; j >= -m0; j--) { + ey[j + m0] = ey[j + m0 - 1] * fp; + ey[-j + m1] = ey[-j + m1 + 1] * fm; + } + + fp = cos(vec[2]) - I * sin(vec[2]); + fm = conj(fp); + for (j = 0; j >= -n0; j--) { + ez[j + n0] = ez[j + n0 - 1] * fp; + ez[-j + n1] = ez[-j + n1 + 1] * fm; + } + +} diff --git a/src/structure_types.F b/src/structure_types.c similarity index 100% rename from src/structure_types.F rename to src/structure_types.c diff --git a/src/tbmd.F b/src/tbmd.c similarity index 100% rename from src/tbmd.F rename to src/tbmd.c diff --git a/src/tbmd_debug.F b/src/tbmd_debug.c similarity index 100% rename from src/tbmd_debug.F rename to src/tbmd_debug.c diff --git a/src/tbmd_force.F b/src/tbmd_force.c similarity index 100% rename from src/tbmd_force.F rename to src/tbmd_force.c diff --git a/src/tbmd_global.F b/src/tbmd_global.c similarity index 100% rename from src/tbmd_global.F rename to src/tbmd_global.c diff --git a/src/tbmd_input.F b/src/tbmd_input.c similarity index 100% rename from src/tbmd_input.F rename to src/tbmd_input.c diff --git a/src/tbmd_types.F b/src/tbmd_types.c similarity index 100% rename from src/tbmd_types.F rename to src/tbmd_types.c diff --git a/src/timesl.F b/src/timesl.c similarity index 100% rename from src/timesl.F rename to src/timesl.c diff --git a/src/timings.F b/src/timings.c similarity index 88% rename from src/timings.F rename to src/timings.c index fad792c..b8202fb 100644 --- a/src/timings.F +++ b/src/timings.c @@ -1,7 +1,7 @@ -!-----------------------------------------------------------------------------! +/*----------------------------------------------------------------------------! ! CP2K: A general program to perform molecular dynamics simulations ! ! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! +!----------------------------------------------------------------------------*/ MODULE timings @@ -37,28 +37,17 @@ MODULE timings CONTAINS -!****************************************************************************** +/*****************************************************************************/ -SUBROUTINE timeset ( name, ct, pu, handle ) - - IMPLICIT NONE - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: name - CHARACTER ( LEN = 1 ), INTENT ( IN ) :: ct ! Clock type [0|1] - CHARACTER ( LEN = * ), INTENT ( IN ) :: pu ! Performance unit - INTEGER, INTENT ( OUT ) :: handle - -! Locals - INTEGER :: i - -!------------------------------------------------------------------------------ - -!..add name to subroutine stack - stack_size = stack_size + 1 - routine_stack ( stack_size ) = name - -!..is this a new timer or has this routine been called before +void timeset(char *name, char ct, char *pu, int handle) { + int i; + +/*---------------------------------------------------------------------------*/ + // add name to subroutine stack + stack_size += 1; + routine_stack[stack_size] = name; + + // is this a new timer or has this routine been called before handle = 0 routine_name = name DO i = 1, num_timer @@ -89,7 +78,7 @@ SUBROUTINE timeset ( name, ct, pu, handle ) routine_calls ( handle ) = routine_calls ( handle ) + 1 -END SUBROUTINE timeset +} !****************************************************************************** diff --git a/src/unit.F b/src/unit.c similarity index 100% rename from src/unit.F rename to src/unit.c diff --git a/src/util.F b/src/util.c similarity index 71% rename from src/util.F rename to src/util.c index 928a19b..c23dd14 100644 --- a/src/util.F +++ b/src/util.c @@ -1,29 +1,16 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! +/*---------------------------------------------------------------------------*/ +/* CP2K: A general program to perform molecular dynamics simulations */ +/* Copyright (C) 2024 CP2K developers group */ +/*---------------------------------------------------------------------------*/ -MODULE util +#include +#include - USE kinds, ONLY : dbl - - IMPLICIT NONE - - PRIVATE - PUBLIC :: sort, ran2, get_unit, gasdev, close_unit, & - get_share, get_limit, include_list, getinv3x3, & - matmul_3x3, dotprod_3d, crossprod_3d, matvec_3x3, & - transpose_3d - - INTERFACE sort - MODULE PROCEDURE sort2, sort2i - END INTERFACE - -CONTAINS +#include "util.h" -!****************************************************************************** +/*****************************************************************************/ -SUBROUTINE sort2 ( arr, n, index ) +void sort2(double *arr, int n, int index) { IMPLICIT NONE @@ -131,11 +118,11 @@ SUBROUTINE sort2 ( arr, n, index ) GO TO 1 -END SUBROUTINE sort2 +} !****************************************************************************** -SUBROUTINE sort2i ( iarr, n, index ) +void sort2i( int *iarr, int n, int index) { IMPLICIT NONE @@ -243,7 +230,7 @@ SUBROUTINE sort2i ( iarr, n, index ) GO TO 1 -END SUBROUTINE sort2i +} !****************************************************************************** @@ -251,222 +238,204 @@ END SUBROUTINE sort2i !! call with negative idum to initialize !!> then do not alter idum from successive calls -FUNCTION ran2 ( idum, icontrol ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( INOUT ) :: idum - INTEGER, OPTIONAL, INTENT ( IN ) :: icontrol - -! Locals - REAL ( dbl ) :: ran2 - INTEGER :: im1, im2, imm1, ia1, ia2, iq1, iq2, ir1, ir2, ntab, ndiv - REAL ( dbl ) am, eps, rnmx - PARAMETER (im1=2147483563,im2=2147483399,am=1./im1,imm1=im1-1, & - ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=12211,ir2=3791,ntab=32, & - ndiv=1+imm1/ntab,eps=1.2E-7,rnmx=1.-eps) - INTEGER idum2, j, k, iv(ntab), iy, iounit - SAVE iv, iy, idum2 - DATA idum2/123456789/, iv/ntab*0/, iy/0/, iounit/10/ - -!------------------------------------------------------------------------------ +double ran2(int idum, int icontrol) { + + double ret_val; + int im1, im2, imm1, ia1, ia2, iq1, iq2, ir1, ir2, ntab, ndiv; + double am, eps, rnmx; + + const double im1=2147483563; + const double im2=2147483399; + const double am=1./im1; + const double imm1=im1-1; + const double ia1=40014; + const double ia2=40692; + const double iq1=53668; + const double iq2=52774; + const double ir1=12211; + const double ir2=3791; + const double ntab=32; + const double ndiv=1+imm1/ntab; + const double eps=1.2E-7; + const double rnmx=1.-eps; + + int idum2 = 123456789; + int iy = 0; + int iounit = 10; + int j, k, iv[ntab]; + + for (j = 0; j < ntab; j++) { + iv[j] = 0.0; + } +/*----------------------------------------------------------------------------- + ! ! if icontrol=0, generate a random number normally ! if icontrol=1, load old random number table, dont get a new # ! if icontrol=2, save current random number table and dont get a ! new random number -! - - IF ( .NOT. PRESENT ( icontrol)) THEN - IF (idum<=0) THEN - idum = max(-idum,1) - idum2 = idum - DO j = ntab + 8, 1, -1 - k = idum/iq1 - idum = ia1*(idum-k*iq1) - k*ir1 - IF (idum<0) idum = idum + im1 - IF (j<=ntab) iv(j) = idum - END DO - iy = iv(1) - END IF - k = idum/iq1 - idum = ia1*(idum-k*iq1) - k*ir1 - IF (idum<0) idum = idum + im1 - k = idum2/iq2 - idum2 = ia2*(idum2-k*iq2) - k*ir2 - IF (idum2<0) idum2 = idum2 + im2 - j = 1 + iy/ndiv - iy = iv(j) - idum2 - iv(j) = idum - IF (iy<1) iy = iy + imm1 - ran2 = min(am*iy,rnmx) - ELSE IF (icontrol==1) THEN - OPEN (unit=iounit,file='random.table') - DO j = 1, ntab - READ (iounit,*) iv(j) - END DO - READ (iounit,*) iy - READ (iounit,*) idum - READ (iounit,*) idum2 - CLOSE (iounit) - ELSE IF (icontrol==2) THEN - OPEN (unit=iounit,file='random.table') - DO j = 1, ntab - WRITE (iounit,*) iv(j) - END DO - WRITE (iounit,*) iy - WRITE (iounit,*) idum - WRITE (iounit,*) idum2 - CLOSE (iounit) - END IF - -END FUNCTION ran2 +*/ + + if (!icontrol) { + if (idum<=0) { + idum = std::max(-idum,1); + idum2 = idum; + for (j = ntab + 8; j > 1; j--) { + k = idum/iq1; + idum = ia1*(idum-k*iq1) - k*ir1; + if (idum<0) idum += im1; + if (j <= ntab) iv[j] = idum; + } + iy = iv[0]; + } + k = idum/iq1; + idum = ia1*(idum-k*iq1); + if (idum < 0) idum += im1; + k = idum2/iq2; + idum2 = ia2*idum2-k*iq2; + if (idum2 < 0) idum2 += im2; + j = iy/ndiv; + iy = iv[j] - idum2; + iv[j] = idum; + if (iy < 1) iy += imm1; + ret_val = std::min(am*iy,rnmx); + } else if (icontrol == 1) { + fstream iounit("random.table"); + for (j = 0; j < ntab; j++) { + getline(iounit, iv[j]); + } + getline(iounit, iy); + getline(iounit, idum); + getline(iounit, idum2); + + iounit.close(); + + } else if (icontrol == 2) { + ifstream iounit("random.table"); + for (j = 0; j < ntab; j++) { + getline(iounit, iv[j]); + } + getline(iounit, iy); + getline(iounit, idum); + getline(iounit, idum2); + + iounit.close(); + } + + return ret_val; + +} !****************************************************************************** -FUNCTION gasdev(idum) +double gasdev(int idum) { + + double v1, v2, r, fac, gset, ret_val; + int iset = 0; + + +!------------------------------------------------------------------------------ - IMPLICIT NONE - -! Return value - REAL ( dbl ) :: gasdev - -! Arguments - INTEGER, INTENT ( INOUT ) :: idum - -! Locals - REAL ( dbl ) :: v1, v2, r, fac, gset - INTEGER :: iset - DATA iset/0/ - SAVE iset, gset + if (iset = 0) { + while (r >= 1.0) { + v1 = 2.0*ran2[idum] - 1.00; + v2 = 2.0*ran2[idum] - 1.00; + r = v1*v1 + v2*v2; + } + fac = std::sqrt(-2.0*std::log(r)/r); + gset = v1*fac; + ret_val = v2*fac; + iset = 1; + } else { + ret_val = gset; + iset = 0; + } + + return ret_val; +} + + +!****************************************************************************** + +int get_unit() { + + FILE unit; + bool exists; !------------------------------------------------------------------------------ - IF (iset==0) THEN -1 CONTINUE - v1 = 2._dbl*ran2(idum) - 1.0_dbl - v2 = 2._dbl*ran2(idum) - 1.0_dbl - r = v1*v1 + v2*v2 - IF (r>=1._dbl) GO TO 1 - fac = sqrt(-2._dbl*log(r)/r) - gset = v1*fac - gasdev = v2*fac - iset = 1 - ELSE - gasdev = gset - iset = 0 - END IF - -END FUNCTION gasdev + //..find a not associated unit + unit = 10; + + while (true) { + exists = false; + exists = unit.is_opened(); + if (!exists) return unit; + unit = unit + 1; + } +} !****************************************************************************** -FUNCTION get_unit() RESULT (unit) - - IMPLICIT NONE - -! Return value - INTEGER :: unit - -! Locals - LOGICAL :: exists - -!------------------------------------------------------------------------------ - -!..find a not associated unit - unit = 10 - DO - exists = .FALSE. - INQUIRE (unit=unit,opened=exists) - IF ( .NOT. exists) EXIT - unit = unit + 1 - END DO - -END FUNCTION get_unit - -!****************************************************************************** - -SUBROUTINE close_unit ( u1, u2 ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: u1, u2 - -! Locals - INTEGER :: iunit - LOGICAL :: exists +void close_unit(FILE u1, FILE u2) { + int iunit; + bool exists; !------------------------------------------------------------------------------ !..close all open units from u1 to u2 - DO iunit = u1, u2 - exists = .FALSE. - INQUIRE (unit=iunit,opened=exists) - IF (exists) CLOSE (iunit) - END DO - -END SUBROUTINE close_unit + for (iunit = u1; iunit< u2, iunit++) { + exists = false; + exists = iunit.is_opened(); + if (exists) iunit.close(); + } +} + !****************************************************************************** !..divide m entries into n parts, return size of part me -FUNCTION get_share ( m, n, me ) RESULT ( nme ) +int get_share(int m,int n,int me) { - IMPLICIT NONE - -! Return value - INTEGER :: nme + int nme; + + int nl, nu; + double part; -! Arguments - INTEGER, INTENT ( IN ) :: m, n, me - -! Locals - INTEGER :: nl, nu - REAL ( dbl ) :: part - !------------------------------------------------------------------------------ - part = float(m)/float(n) - nl = nint(float(me)*part) + 1 - nu = nint(float(me+1)*part) - nl = max(1,nl) - nu = min(m,nu) - nme = nu - nl + 1 - nme = max(nme,0) - -END FUNCTION get_share + part = (double)m / (double)n; + nl = nint((float)me*part) + 1; + nu = nint(((float)me + 1.0) * part); + nl = std::max(1,nl); + nu = std::min(m,nu); + nme = nu - nl + 1; + nme = std::max(nme,0); + + return nme; +} !****************************************************************************** !..divide m entries into n parts, return size of part me -FUNCTION get_limit(m,n,me) RESULT (nlim) - - IMPLICIT NONE - -! Return value - INTEGER :: nlim ( 2 ) - -! Arguments - INTEGER, INTENT ( IN ) :: m, n, me - -! Locals - INTEGER :: nl, nu - REAL ( dbl ) :: part +int *get_limit(int m, int n, int me) { + int nlim[2]; + + int nl, nu; + double part; !------------------------------------------------------------------------------ - part = float(m)/float(n) - nl = nint(float(me)*part) + 1 + part = (float)m/(float)n; + nl = nint((float)me*part) + 1; nu = nint(float(me+1)*part) nlim(1) = max(1,nl) nlim(2) = min(m,nu) -END FUNCTION get_limit +} !****************************************************************************** diff --git a/src/util.h b/src/util.h new file mode 100644 index 0000000..7dbcb87 --- /dev/null +++ b/src/util.h @@ -0,0 +1,21 @@ +#ifndef _UTIL_H +#define _UTIL_H + +#ifdef __cplusplus +namespace CP2K_NS { +#endif + + void sort2(double*, int, int); + + void sort2i(int*, int, int*); + + double run2(int, int); + + void matvec_3x3(double[3][3], double[3], double*); + +#ifdef __cplusplus +} +#endif + + +#endif \ No newline at end of file diff --git a/src/util/HashTable.c b/src/util/HashTable.c new file mode 100644 index 0000000..a992b94 --- /dev/null +++ b/src/util/HashTable.c @@ -0,0 +1,388 @@ +#include +#include +#include + +#define CAPACITY 50000 // Size of the HashTable. + +unsigned long hash_function(char *str) +{ + unsigned long i = 0; + + for (int j = 0; str[j]; j++) + i += str[j]; + + return i % CAPACITY; +} + +// Defines the HashTable item. +typedef struct Ht_item +{ + char *key; + char *value; +} Ht_item; + +// Defines the LinkedList. +typedef struct LinkedList +{ + Ht_item *item; + LinkedList *next; +} LinkedList; + +// Defines the HashTable. +typedef struct HashTable +{ + // Contains an array of pointers to items. + Ht_item **items; + LinkedList **overflow_buckets; + int size; + int count; +} HashTable; + +LinkedList *allocate_list() +{ + // Allocates memory for a LinkedList pointer. + LinkedList *list = (LinkedList *)malloc(sizeof(LinkedList)); + return list; +} + +LinkedList *linkedlist_insert(LinkedList *list, Ht_item *item) +{ + // Inserts the item onto the LinkedList. + if (!list) + { + LinkedList *head = allocate_list(); + head->item = item; + head->next = NULL; + list = head; + return list; + } + else if (list->next == NULL) + { + LinkedList *node = allocate_list(); + node->item = item; + node->next = NULL; + list->next = node; + return list; + } + + LinkedList *temp = list; + + while (temp->next->next) + { + temp = temp->next; + } + + LinkedList *node = allocate_list(); + node->item = item; + node->next = NULL; + temp->next = node; + return list; +} + +Ht_item *linkedlist_remove(LinkedList *list) +{ + // Removes the head from the LinkedList. + // Returns the item of the popped element. + if (!list) + return NULL; + + if (!list->next) + return NULL; + + LinkedList *node = list->next; + LinkedList *temp = list; + temp->next = NULL; + list = node; + Ht_item *it = NULL; + memcpy(temp->item, it, sizeof(Ht_item)); + free(temp->item->key); + free(temp->item->value); + free(temp->item); + free(temp); + return it; +} + +void free_linkedlist(LinkedList *list) +{ + LinkedList *temp = list; + + while (list) + { + temp = list; + list = list->next; + free(temp->item->key); + free(temp->item->value); + free(temp->item); + free(temp); + } +} + +LinkedList **create_overflow_buckets(HashTable *table) +{ + // Create the overflow buckets; an array of LinkedLists. + LinkedList **buckets = (LinkedList **)calloc(table->size, sizeof(LinkedList *)); + + for (int i = 0; i < table->size; i++) + buckets[i] = NULL; + + return buckets; +} + +void free_overflow_buckets(HashTable *table) +{ + // Free all the overflow bucket lists. + LinkedList **buckets = table->overflow_buckets; + + for (int i = 0; i < table->size; i++) + free_linkedlist(buckets[i]); + + free(buckets); +} + +Ht_item *create_item(char *key, char *value) +{ + // Creates a pointer to a new HashTable item. + Ht_item *item = (Ht_item *)malloc(sizeof(Ht_item)); + item->key = (char *)malloc(strlen(key) + 1); + item->value = (char *)malloc(strlen(value) + 1); + strcpy(item->key, key); + strcpy(item->value, value); + return item; +} + +HashTable *create_table(int size) +{ + // Creates a new HashTable. + HashTable *table = (HashTable *)malloc(sizeof(HashTable)); + table->size = size; + table->count = 0; + table->items = (Ht_item **)calloc(table->size, sizeof(Ht_item *)); + + for (int i = 0; i < table->size; i++) + table->items[i] = NULL; + + table->overflow_buckets = create_overflow_buckets(table); + + return table; +} + +void free_item(Ht_item *item) +{ + // Frees an item. + free(item->key); + free(item->value); + free(item); +} + +void free_table(HashTable *table) +{ + // Frees the table. + for (int i = 0; i < table->size; i++) + { + Ht_item *item = table->items[i]; + + if (item != NULL) + free_item(item); + } + + // Free the overflow bucket lists and its items. + free_overflow_buckets(table); + free(table->items); + free(table); +} + +void handle_collision(HashTable *table, unsigned long index, Ht_item *item) +{ + LinkedList *head = table->overflow_buckets[index]; + + if (head == NULL) + { + // Creates the list. + head = allocate_list(); + head->item = item; + table->overflow_buckets[index] = head; + return; + } + else + { + // Insert to the list. + table->overflow_buckets[index] = linkedlist_insert(head, item); + return; + } +} + +void ht_insert(HashTable *table, char *key, char *value) +{ + // Creates the item. + Ht_item *item = create_item(key, value); + + // Computes the index. + int index = hash_function(key); + + Ht_item *current_item = table->items[index]; + + if (current_item == NULL) + { + // Key does not exist. + if (table->count == table->size) + { + // HashTable is full. + printf("Insert Error: Hash Table is full\n"); + free_item(item); + return; + } + + // Insert directly. + table->items[index] = item; + table->count++; + } + else + { + // Scenario 1: Update the value. + if (strcmp(current_item->key, key) == 0) + { + strcpy(table->items[index]->value, value); + return; + } + else + { + // Scenario 2: Handle the collision. + handle_collision(table, index, item); + return; + } + } +} + +char *ht_search(HashTable *table, char *key) +{ + // Searches for the key in the HashTable. + // Returns NULL if it doesn't exist. + int index = hash_function(key); + Ht_item *item = table->items[index]; + LinkedList *head = table->overflow_buckets[index]; + + // Provide only non-NULL values. + if (item != NULL) + { + if (strcmp(item->key, key) == 0) + return item->value; + + if (head == NULL) + return NULL; + + item = head->item; + head = head->next; + } + + return NULL; +} + +void ht_delete(HashTable *table, char *key) +{ + // Deletes an item from the table. + int index = hash_function(key); + Ht_item *item = table->items[index]; + LinkedList *head = table->overflow_buckets[index]; + + if (item == NULL) { + // Does not exist. + return; + } else { + if (head == NULL && strcmp(item->key, key) == 0) + { + // Collision chain does not exist. + // Remove the item. + // Set table index to NULL. + table->items[index] = NULL; + free_item(item); + table->count--; + return; + } else if (head != NULL) { + // Collision chain exists. + if (strcmp(item->key, key) == 0) + { + // Remove this item. + // Set the head of the list as the new item. + free_item(item); + LinkedList *node = head; + head = head->next; + node->next = NULL; + table->items[index] = create_item(node->item->key, node->item->value); + free_linkedlist(node); + table->overflow_buckets[index] = head; + return; + } + + LinkedList *curr = head; + LinkedList *prev = NULL; + + while (curr) { + if (strcmp(curr->item->key, key) == 0) { + if (prev == NULL) { + // First element of the chain. + // Remove the chain. + free_linkedlist(head); + table->overflow_buckets[index] = NULL; + return; + } else { + // This is somewhere in the chain. + prev->next = curr->next; + curr->next = NULL; + free_linkedlist(curr); + table->overflow_buckets[index] = head; + return; + } + } + + curr = curr->next; + prev = curr; + } + } + } +} + +void print_search(HashTable *table, char *key) +{ + char *val; + + if ((val = ht_search(table, key)) == NULL) + { + printf("Key:%s does not exist\n", key); + return; + } else { + printf("Key:%s, Value:%s\n", key, val); + } +} + +void print_table(HashTable *table) { + printf("\nHash Table\n-------------------\n"); + + for (int i = 0; i < table->size; i++) + { + if (table->items[i]) + { + printf("Index:%d, Key:%s, Value:%s\n", i, table->items[i]->key, table->items[i]->value); + } + } + + printf("-------------------\n\n"); +} + +int main() { + HashTable *ht = create_table(CAPACITY); + ht_insert(ht, (char *)"1", (char *)"First address"); + ht_insert(ht, (char *)"2", (char *)"Second address"); + ht_insert(ht, (char *)"Hel", (char *)"Third address"); + ht_insert(ht, (char *)"Cau", (char *)"Fourth address"); + print_search(ht, (char *)"1"); + print_search(ht, (char *)"2"); + print_search(ht, (char *)"3"); + print_search(ht, (char *)"Hel"); + print_search(ht, (char *)"Cau"); // Collision! + print_table(ht); + ht_delete(ht, (char *)"1"); + ht_delete(ht, (char *)"Cau"); + print_table(ht); + free_table(ht); + return 0; +} \ No newline at end of file diff --git a/tools/forlex.c b/tools/forlex.c index 23a2f16..fbae2f2 100644 --- a/tools/forlex.c +++ b/tools/forlex.c @@ -11,7 +11,6 @@ #include - /* cfront 1.2 defines "c_plusplus" instead of "__cplusplus" */ #ifdef c_plusplus #ifndef __cplusplus @@ -19,7 +18,6 @@ #endif #endif - #ifdef __cplusplus #include @@ -31,19 +29,19 @@ /* The "const" storage-class-modifier is valid. */ #define YY_USE_CONST -#else /* ! __cplusplus */ +#else /* ! __cplusplus */ #if __STDC__ #define YY_USE_PROTOS #define YY_USE_CONST -#endif /* __STDC__ */ -#endif /* ! __cplusplus */ +#endif /* __STDC__ */ +#endif /* ! __cplusplus */ #ifdef __TURBOC__ - #pragma warn -rch - #pragma warn -use +#pragma warn - rch +#pragma warn - use #include #include #define YY_USE_CONST @@ -56,7 +54,6 @@ #define yyconst #endif - #ifdef YY_USE_PROTOS #define YY_PROTO(proto) proto #else @@ -90,7 +87,7 @@ #define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) /* Special action meaning "start processing a new file". */ -#define YY_NEW_FILE yyrestart( yyin ) +#define YY_NEW_FILE yyrestart(yyin) #define YY_END_OF_BUFFER_CHAR 0 diff --git a/tools/forpar.tab.c b/tools/forpar.tab.c index ff55d6b..7b8f82f 100644 --- a/tools/forpar.tab.c +++ b/tools/forpar.tab.c @@ -808,7 +808,7 @@ int yydebug; /* nonzero means print parse trace */ #ifdef __GNUC__ YYPARSE_RETURN_TYPE yyparse (void); #endif - + #if __GNUC__ > 1 /* GNU C and GNU C++ define this. */ #define __yy_memcpy(TO,FROM,COUNT) __builtin_memcpy(TO,FROM,COUNT) #else /* not GNU C or C++ */ @@ -847,7 +847,7 @@ __yy_memcpy (char *to, char *from, int count) #endif #endif - + #line 196 "/usr/share/bison.simple" /* The user can define YYPARSE_PARAM as the name of an argument to be passed @@ -1171,7 +1171,7 @@ case 5: case 6: #line 87 "forpar.y" { - if( !filedep ) { + if( !filedep ) { fclose(flout); flout=NULL; if( chkint ) do_chkint(fnout,fnold); } @@ -1408,7 +1408,7 @@ case 105: break;} case 106: #line 274 "forpar.y" -{ +{ yyval=spr(0,"Dimension(%s)",yyvsp[-2]); ; break;} case 107: @@ -1619,7 +1619,7 @@ case 161: case 162: #line 350 "forpar.y" { if( strcmp(yyvsp[-3],"kind")!=0 ) - yyerror("expecting \"Kind\"\n"); + yyerror("expecting \"Kind\"\n"); yyval=spr(0,"(Kind=%s)",yyvsp[-1]); ; break;} @@ -1641,7 +1641,7 @@ case 165: case 166: #line 361 "forpar.y" { if( strcmp(yyvsp[-3],"len")!=0 ) - yyerror("expecting \"Len\"\n"); + yyerror("expecting \"Len\"\n"); yyval=spr(0,"(Len=%s)",yyvsp[-1]); ; break;} @@ -2003,7 +2003,7 @@ case 282: break;} case 284: #line 612 "forpar.y" -{ +{ if( *yyvsp[-1] && strcmp(yyvsp[-1],modname)!=0 ) parerr("end module: non-matching name (\"%s <-> %s\")",modname,yyvsp[-1]); if( cont ){ indent-=dind; printw(0,"\n"); printw(-1,"End Interface\n\n"); } @@ -2019,7 +2019,7 @@ case 284: } /* the action file gets copied in in place of this dollarsign */ #line 498 "/usr/share/bison.simple" - + yyvsp -= yylen; yyssp -= yylen; #ifdef YYLSP_NEEDED @@ -2384,7 +2384,7 @@ int mydirname(char *file, char *path){ } -/* choose new filename; if it exists, move the old int-file +/* choose new filename; if it exists, move the old int-file if moddep (i.e. !filedep), put path in front of fnout NB: very dirty: fnin and fnout are passed, fnold and path are global */ @@ -2481,7 +2481,7 @@ int main(int argc, char* argv[]){ parerr("with the \"-chkint\" option you MUST specify the input file\n"); if( chkint && *fnout ) parerr("with the \"-chkint\" option you CANNOT specify the output file\n"); - + if( argc==2 ){ strcpy(fnin,*argv); mydirname(fnin,path); } if( chkint ){ diff --git a/tools/sfmakedepend b/tools/sfmakedepend index 4988c6b..958f815 100755 --- a/tools/sfmakedepend +++ b/tools/sfmakedepend @@ -170,7 +170,7 @@ sub find_includes { $included = $1; $after = $'; # Fortran 90 "use" - } elsif (/^\s*use\s+(\w+)/i) { + } elsif (/^\s*use\s+(\w+)/i) { $use = $1; # Make the module name lowercase except for SGI & HP. # May be compiler dependent!! @@ -282,7 +282,7 @@ sub find_mods { foreach $modname (@mod_list) { $self->{'uses'}{$modname} = 1; } - + # now find the filename that contains the module information foreach $modname (keys %{$self->{'uses'}}) { if ($main::cray || $main::parasoft) { diff --git a/tools/slist.c b/tools/slist.c index 8a2fc6d..7870de4 100644 --- a/tools/slist.c +++ b/tools/slist.c @@ -67,5 +67,3 @@ void ins_lele(slist **list, char* newele){ strcpy(s,newele); pn->ele=s; } - -