├── tests ├── wavelength ├── expected_results │ ├── BETA_TEST1.txt │ ├── BETA_TEST2.txt │ ├── BETA_TEST3.txt │ ├── 2PA_TEST1.txt │ ├── 2PA_TEST2.txt │ ├── 2PA_TEST3.txt │ ├── EXCI_TEST1.dat │ ├── EXCI_TEST2.dat │ └── EXCI_TEST3.dat ├── run_tests.sh ├── water_sto3g.molden └── compare.py ├── std2_manual.pdf ├── std2logo_git.png ├── param ├── param_default ├── subprojects └── libcint.wrap ├── wfbas.inc ├── meson_options.txt ├── qc2molden.sh ├── linal.f ├── io.f ├── header.f ├── g2molden ├── Makefile └── stringmod.f90 ├── INFO ├── block.f ├── g_spec └── Makefile ├── Makefile ├── stdacommon.f90 ├── onetri.f ├── pckao.f ├── sosor.f ├── readl.f ├── prmat.f ├── molden.f ├── meson.build ├── velo.f ├── readxtb.f ├── COPYING.LESSER ├── readbasa.f ├── normalize.f ├── intslvm.f ├── srpapack.f ├── README.md ├── 2PA.f90 └── stringmod.f90 /tests/wavelength: -------------------------------------------------------------------------------- 1 | 1907 2 | 1064 3 | -------------------------------------------------------------------------------- /std2_manual.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grimme-lab/std2/HEAD/std2_manual.pdf -------------------------------------------------------------------------------- /std2logo_git.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grimme-lab/std2/HEAD/std2logo_git.png -------------------------------------------------------------------------------- /param: -------------------------------------------------------------------------------- 1 | parameter (ndi22 =100000) 2 | parameter (maxat =3000) 3 | parameter (maxconf=1000000) 4 | -------------------------------------------------------------------------------- /param_default: -------------------------------------------------------------------------------- 1 | parameter (ndi22 =24000) 2 | parameter (maxat =2000) 3 | parameter (maxconf=100000) 4 | -------------------------------------------------------------------------------- /tests/expected_results/BETA_TEST1.txt: -------------------------------------------------------------------------------- 1 | 0.00000000 3.8684883130827541 2 | 0.650153160 3.8896786186568040 3 | 1.16526508 3.9373102946817227 4 | -------------------------------------------------------------------------------- /tests/expected_results/BETA_TEST2.txt: -------------------------------------------------------------------------------- 1 | 0.00000000 2.1702449693748593 2 | 0.650153160 2.1768514651053148 3 | 1.16526508 2.1915914414174331 4 | -------------------------------------------------------------------------------- /tests/expected_results/BETA_TEST3.txt: -------------------------------------------------------------------------------- 1 | 0.00000000 3.5053039084722921 2 | 0.650153160 3.5222514169638854 3 | 1.16526508 3.5602659034625943 4 | -------------------------------------------------------------------------------- /tests/expected_results/2PA_TEST1.txt: -------------------------------------------------------------------------------- 1 | 1 14.084 0.000 0.000 0.001 1.333 2 | 2 16.786 1.675 0.259 0.519 6.458 3 | 3 17.507 0.003 0.002 0.005 1.333 4 | -------------------------------------------------------------------------------- /tests/expected_results/2PA_TEST2.txt: -------------------------------------------------------------------------------- 1 | 1 20.484 0.000 0.000 0.000 1.333 2 | 2 23.037 0.801 0.121 0.242 6.608 3 | 3 23.977 0.001 0.000 0.001 1.333 4 | -------------------------------------------------------------------------------- /tests/expected_results/2PA_TEST3.txt: -------------------------------------------------------------------------------- 1 | 1 15.854 0.000 0.000 0.000 1.333 2 | 2 18.378 1.599 0.238 0.476 6.722 3 | 3 19.200 0.002 0.001 0.003 1.333 4 | -------------------------------------------------------------------------------- /subprojects/libcint.wrap: -------------------------------------------------------------------------------- 1 | [wrap-file] 2 | source_url = https://github.com/pierre-24/libcint-meson/releases/download/v0.3.0/libcint_v6.1.2.tar.gz 3 | source_filename = libcint_v6.1.2.tar.gz 4 | source_hash = e5e14786bc9d145279eacf0dd70dc774d148452a2a5df73f873ef031b9091dbd 5 | 6 | lead_directory_missing = libcint 7 | 8 | [provide] 9 | libcint = libcint_dep 10 | -------------------------------------------------------------------------------- /wfbas.inc: -------------------------------------------------------------------------------- 1 | C------------------------------------------------------------ 2 | C wavefunction and basis common block 3 | COMMON/WFN/CO(MAXAT,4),IPAT(NDI22),IPTY(NDI22), 4 | . EXIP(NDI22),OCC(NDI22),EPS(NDI22), 5 | . ATNAM(MAXAT),CXIP(NDI22),IPAO(NDI22), 6 | . IAOAT(NDI22) 7 | CHARACTER*2 ATNAM 8 | -------------------------------------------------------------------------------- /tests/expected_results/EXCI_TEST1.dat: -------------------------------------------------------------------------------- 1 | NM 2 | VELO 3 | MMASS 4 | 18.015200000000000 5 | LFAKTOR 6 | 0.5 7 | RFAKTOR 8 | 1.0 9 | WIDTH 10 | 0.20 11 | SHIFT 12 | 0.00 13 | DATXY 14 | 1 14.0839 0.003718 0.024292 -0.000001 -0.000002 15 | 2 16.8121 0.140138 0.189382 0.000000 0.000000 16 | 3 17.5071 0.000000 0.000000 -0.000000 -0.000000 17 | 4 19.8865 0.291637 0.151505 0.000001 0.000001 18 | -------------------------------------------------------------------------------- /tests/expected_results/EXCI_TEST2.dat: -------------------------------------------------------------------------------- 1 | NM 2 | VELO 3 | MMASS 4 | 18.015200000000000 5 | LFAKTOR 6 | 0.5 7 | RFAKTOR 8 | 1.0 9 | WIDTH 10 | 0.20 11 | SHIFT 12 | 0.00 13 | DATXY 14 | 1 20.4845 0.005407 0.016702 -0.000022 -0.000014 15 | 2 23.0717 0.168656 0.124823 0.000000 0.000000 16 | 3 23.9769 0.000000 0.000000 -0.000000 -0.000000 17 | 4 26.0985 0.242207 0.069563 -0.000003 -0.000004 18 | 5 28.5816 1.307409 0.400764 0.000025 0.000014 19 | -------------------------------------------------------------------------------- /tests/expected_results/EXCI_TEST3.dat: -------------------------------------------------------------------------------- 1 | NM 2 | VELO 3 | MMASS 4 | 18.015200000000000 5 | LFAKTOR 6 | 0.5 7 | RFAKTOR 8 | 1.0 9 | WIDTH 10 | 0.20 11 | SHIFT 12 | 0.00 13 | DATXY 14 | 1 15.8543 0.004185 0.021579 0.000000 0.000000 15 | 2 18.3873 0.190150 0.206896 0.000000 0.000000 16 | 3 19.2001 0.000000 0.000000 -0.000000 -0.000000 17 | 4 21.5984 0.427986 0.194846 -0.000000 -0.000000 18 | 5 24.1600 0.862816 0.383928 0.000000 0.000000 19 | 6 28.1492 0.601623 0.178281 0.000000 0.000000 20 | -------------------------------------------------------------------------------- /meson_options.txt: -------------------------------------------------------------------------------- 1 | # This file is part of stda. 2 | # 3 | # Copyright (C) 2019 Sebastian Ehlert 4 | # Copyright (C) 2024 Marc de Wergifosse 5 | 6 | # Modified by P. Beaujean 7 | 8 | option( 9 | 'openmp', 10 | type: 'boolean', 11 | value: true, 12 | description: 'use OpenMP parallelisation' 13 | ) 14 | 15 | option( 16 | 'la_backend', 17 | type: 'combo', 18 | value: 'mkl', 19 | choices: ['mkl', 'openblas', 'netlib', 'custom'], 20 | description : 'linear algebra backend' 21 | ) 22 | 23 | option( 24 | 'custom_libraries', 25 | type: 'array', 26 | value: [], 27 | description: 'libraries to load for custom linear algebra backend' 28 | ) 29 | 30 | option( 31 | 'static', 32 | type: 'boolean', 33 | value: false, 34 | description: 'Produce statically linked executables' 35 | ) 36 | 37 | option( 38 | 'interface', 39 | type: 'combo', 40 | value: '32', 41 | choices: ['32', '64'], 42 | description: 'integer precision range in bits.' 43 | ) 44 | -------------------------------------------------------------------------------- /qc2molden.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | echo "For a molden file generated by q-chem, PRINT_ORBITALS needs to be set to a high number in order to have all virtual orbitals." 3 | echo "PURECART = 2222 is necessary." 4 | awk '/MOLDEN-FORMATTED INPUT FILE FOLLOWS/,/END OF MOLDEN-FORMATTED INPUT FILE/' $1 > molden.input 5 | sed -i s/'======= END OF MOLDEN-FORMATTED INPUT FILE ======='//g molden.input 6 | sed -i s/'======= MOLDEN-FORMATTED INPUT FILE FOLLOWS ======='//g molden.input 7 | sed -i s/"(Angs)"/"Angs"/g molden.input 8 | sed -i s/"S "/"s "/g molden.input 9 | sed -i s/"P "/"p "/g molden.input 10 | sed -i s/"D "/"d "/g molden.input 11 | sed -i s/"F "/"f "/g molden.input 12 | sed -i s/"G "/"g "/g molden.input 13 | sed -i s/"Sp "/"sp "/g molden.input 14 | sed -i s/"="/"= "/g molden.input 15 | if grep -q "Beta" molden.input 16 | then 17 | echo "Unrestricted" 18 | else 19 | echo "Restricted" 20 | sed -i s/"Occup= 1"/"Occup= 2"/g molden.input 21 | fi 22 | -------------------------------------------------------------------------------- /linal.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | subroutine blow(nbf,F,X) 20 | implicit none 21 | real*8 F(nbf*(nbf+1)/2),X(nbf,nbf) 22 | integer nbf,i,j,k 23 | 24 | c blow it up 25 | k=0 26 | do i=1,nbf 27 | do j=1,i 28 | k=k+1 29 | X(i,j)=F(k) 30 | X(j,i)=F(k) 31 | enddo 32 | enddo 33 | 34 | end 35 | -------------------------------------------------------------------------------- /io.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | *********************************************************************** 20 | 21 | subroutine mwrite(n,iwo,v,irec) 22 | IMPLICIT REAL*8 (A-H,O-Z) 23 | dimension v(n) 24 | write(iwo,rec=irec) v 25 | return 26 | end 27 | 28 | 29 | subroutine mread(n,iwo,v,irec) 30 | IMPLICIT REAL*8 (A-H,O-Z) 31 | dimension v(n) 32 | read(iwo,rec=irec) v 33 | return 34 | end 35 | -------------------------------------------------------------------------------- /header.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | subroutine header(aarg,iarg) 20 | IMPLICIT REAL*8(A-H,O-Z) 21 | character*(*) aarg 22 | 23 | write(*,110) 24 | if(iarg.ne.0) then 25 | write(*,120)aarg,iarg 26 | else 27 | write(*,121)aarg 28 | endif 29 | write(*,110) 30 | 110 format(70('=')) 31 | 130 format(/) 32 | 120 format(20x,a,5x,i4) 33 | 121 format(20x,a) 34 | 35 | return 36 | end 37 | -------------------------------------------------------------------------------- /g2molden/Makefile: -------------------------------------------------------------------------------- 1 | 2 | PROG = g2molden 3 | 4 | OSTYPE=LINUXI 5 | 6 | ifeq ($(OSTYPE),LINUXI) 7 | FC = ifort 8 | # FC = lfc 9 | CC = gcc 10 | 11 | LINKER = ifort -static 12 | LIBS = $(MKLROOT)/lib/intel64/libmkl_blas95_lp64.a $(MKLROOT)/lib/intel64/libmkl_lapack95_lp64.a -Wl,--start-group $(MKLROOT)/lib/intel64/libmkl_intel_lp64.a $(MKLROOT)/lib/intel64/libmkl_sequential.a $(MKLROOT)/lib/intel64/libmkl_core.a -Wl,--end-group -lpthread -lm 13 | CFLAGS = -O -DLINUX 14 | FFLAGS = -O3 -I$(MKLROOT)/include/intel64/lp64 -I$(MKLROOT)/include 15 | 16 | 17 | endif 18 | 19 | ifeq ($(OSTYPE),MACOS) 20 | FC = ifort 21 | CC = gcc 22 | LINKER = ifort -qopenmp -I$(MKLROOT)/include/intel64/lp64 -I$(MKLROOT)/include 23 | LIBS = ${MKLROOT}/lib/libmkl_blas95_lp64.a ${MKLROOT}/lib/libmkl_intel_lp64.a ${MKLROOT}/lib/libmkl_intel_thread.a ${MKLROOT}/lib/libmkl_core.a -liomp5 -lpthread -lm -ldl 24 | PREFLAG = -E -P 25 | FFLAGS = -O3 -qopenmp -I$(MKLROOT)/include/intel64/lp64 -I$(MKLROOT)/include #-check all 26 | FFLAGS = -O3 -I${MKLROOT}/include/intel64/lp64 -I${MKLROOT}/include 27 | CCFLAGS = -O3 -DLINUX 28 | endif 29 | 30 | ################################################# 31 | OBJS=\ 32 | stringmod.o main.o 33 | ################################################# 34 | 35 | %.o: %.f90 36 | @echo "making $@ from $<" 37 | $(FC) $(FFLAGS) -c $< -o $@ 38 | %.o: %.f 39 | @echo "making $@ from $<" 40 | $(FC) $(FFLAGS) -c $< -o $@ 41 | 42 | $(PROG): $(OBJS) 43 | @echo "Loading $(PROG) ... " 44 | @$(LINKER) $(OBJS) $(LIBS) -o $(PROG) 45 | 46 | clean: 47 | rm -f *.o $(PROG) 48 | -------------------------------------------------------------------------------- /INFO: -------------------------------------------------------------------------------- 1 | 20.02.2014: Version 1.2: 2 | 3 | -Molden file now serves as input 4 | -sTD-DFT method included 5 | 6 | 26.08.2014: Version 1.3: 7 | 8 | -Interfacing with Gaussian 09 possible (via g2molden) 9 | 10 | 29.10.2014: Version 1.4: 11 | 12 | -sTDA program is now interfaced to TeraChem 13 | -Eigenvectors may be printed (Turbomole format) 14 | -small bugfixes 15 | 16 | 01.03.2016: Version 1.5: 17 | 18 | -xTB 19 | -velocity correction 20 | -make UKS available to public 21 | 22 | 13.02.2018: Version 1.6: 23 | 24 | - linear and nonlinear response function (SHG) 25 | - two-photon absorption 26 | 27 | 26.11.2019: Version 1.6.1: 28 | 29 | - state to state transitions 30 | - SF-sTD-DFT 31 | - NTOs 32 | 33 | 10.09.2020: Version 1.6.2: 34 | 35 | - evaluation of the molecular optical rotation 36 | - for spin-flip states 37 | - speed-up for the response function deck 38 | 39 | 10.10.2022: Version 1.6.3: 40 | 41 | - evaluation of the two-photon cross-sections (now fully working) 42 | - RespA approach for the interpretation of molecular response properties 43 | - dual-threshold method for the efficient treatment of large systems 44 | - polarizability bug fixed 45 | 46 | 12.09.2023: Version 1.6.3.3: 47 | 48 | - Sources corrected for NTOs with dual threshold 49 | - Sign error in the response part of the calculation of 2PA strengths is corrected 50 | 51 | 08.01.2024: Version 2.0.0: 52 | 53 | - interfaced by default to libcint (magnetic moment one-electron integrals still computed with the old integral deck) 54 | - XsTDA (restricted and unrestricted[only excited states]) for global hybrids and range-separated hybrids 55 | - XsTD-DFT (restricted and unrestricted[only excited states]) for global hybrids and range-separated hybrids 56 | - SF-XsTD-DFT for global hybrids 57 | - CAM-B3LYP, wB97X-D2, wB97X-D3, wB97MV, SRC2R1, and SRC2R2 RSH functionals natively implemented with XsTD 58 | -------------------------------------------------------------------------------- /block.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | BLOCK DATA 20 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) 21 | 22 | common /amass / ams(107) 23 | 24 | data ams / 1.00790d0, 4.00260d0, 6.94000d0, 9.01218d0, 25 | 110.81000d0, 12.01100d0, 14.00670d0, 15.99940d0, 18.99840d0, 26 | 220.17900d0, 22.98977d0, 24.30500d0, 26.98154d0, 28.08550d0, 27 | 330.97376d0, 32.06000d0, 35.45300d0, 39.94800d0, 39.09830d0, 28 | 440.08000d0, 44.95590d0, 47.90000d0, 50.94150d0, 51.99600d0, 29 | 554.93800d0, 55.84700d0, 58.93320d0, 58.71000d0, 63.54600d0, 30 | 665.38000d0, 69.73500d0, 72.59000d0, 74.92160d0, 78.96000d0, 31 | 779.90400d0, 83.80000d0, 85.46780d0, 87.62000d0, 88.90590d0, 32 | 891.22000d0, 92.90640d0, 95.94000d0, 98.90620d0, 101.0700d0, 33 | 9102.9055d0, 106.4000d0, 107.8680d0, 112.4100d0, 114.8200d0, 34 | 1118.6900d0, 121.7500d0, 127.6000d0, 126.9045d0, 131.3000d0, 35 | 2132.9054d0, 137.3300d0, 15*0.000d0, 178.4900d0, 180.9479d0, 36 | 3183.8500d0, 186.2070d0, 190.2000d0, 192.2200d0, 195.0900d0, 37 | 4196.9665d0, 200.5900d0, 204.3700d0, 207.2000d0, 208.9804d0, 38 | 518*0.000d0, 1.0079d0, 5*0.000d0/ 39 | 40 | END 41 | -------------------------------------------------------------------------------- /g_spec/Makefile: -------------------------------------------------------------------------------- 1 | 2 | PROG = g_spec 3 | 4 | OSTYPE=LINUXI 5 | #-------------------------------------------------------------------------- 6 | 7 | #------------------------------------------------------------------------- 8 | 9 | ifeq ($(OSTYPE),LINUXI) 10 | FC = ifort 11 | # FC = lfc 12 | CC = gcc 13 | 14 | ### multithread ### 15 | LINKER = ifort -static -qopenmp -I$(MKLROOT)/include/intel64/lp64 -I$(MKLROOT)/include 16 | LIBS = $(MKLROOT)/lib/intel64/libmkl_blas95_lp64.a $(MKLROOT)/lib/intel64/libmkl_lapack95_lp64.a -Wl,--start-group $(MKLROOT)/lib/intel64/libmkl_intel_lp64.a $(MKLROOT)/lib/intel64/libmkl_core.a $(MKLROOT)/lib/intel64/libmkl_intel_thread.a -Wl,--end-group -lpthread -lm 17 | 18 | ### sequential ### 19 | # LINKER = ifort -static 20 | # LIBS = ${MKLROOT}/lib/intel64/libmkl_blas95_lp64.a ${MKLROOT}/lib/intel64/libmkl_lapack95_lp64.a -Wl,--start-group ${MKLROOT}/lib/intel64/libmkl_intel_lp64.a ${MKLROOT}/lib/intel64/libmkl_core.a $(MKLROOT)/lib/intel64/libmkl_sequential.a -Wl,--end-group -lpthread -lm 21 | 22 | CFLAGS = -O -DLINUX 23 | FFLAGS = -O3 -qopenmp -I$(MKLROOT)/include/intel64/lp64 -I$(MKLROOT)/include 24 | endif 25 | 26 | ifeq ($(OSTYPE),MACOS) 27 | FC = ifort 28 | CC = gcc 29 | LINKER = ifort -qopenmp -I$(MKLROOT)/include/intel64/lp64 -I$(MKLROOT)/include 30 | LIBS = ${MKLROOT}/lib/libmkl_blas95_lp64.a ${MKLROOT}/lib/libmkl_intel_lp64.a ${MKLROOT}/lib/libmkl_intel_thread.a ${MKLROOT}/lib/libmkl_core.a -liomp5 -lpthread -lm -ldl 31 | PREFLAG = -E -P 32 | FFLAGS = -O3 -qopenmp -I$(MKLROOT)/include/intel64/lp64 -I$(MKLROOT)/include #-check all 33 | FFLAGS = -O3 -I${MKLROOT}/include/intel64/lp64 -I${MKLROOT}/include 34 | CCFLAGS = -O3 -DLINUX 35 | endif 36 | 37 | ################################################# 38 | OBJS=\ 39 | g_spec.o 40 | ################################################# 41 | 42 | %.o: %.f90 43 | @echo "making $@ from $<" 44 | $(FC) $(FFLAGS) -c $< -o $@ 45 | %.o: %.f 46 | @echo "making $@ from $<" 47 | $(FC) $(FFLAGS) -c $< -o $@ 48 | 49 | $(PROG): $(OBJS) 50 | @echo "Loading $(PROG) ... " 51 | @$(LINKER) $(OBJS) $(LIBS) -o $(PROG) 52 | 53 | clean: 54 | rm -f *.o $(PROG) 55 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PROG = std2 2 | OSTYPE=LINUXI 3 | 4 | #-------------------------------------------------------------------------- 5 | # see https://www.intel.com/content/www/us/en/developer/tools/oneapi/onemkl-link-line-advisor.html details on these options 6 | 7 | ifeq ($(OSTYPE),LINUXI) 8 | FC = ifx 9 | CC = icx 10 | 11 | ifdef USEILP64 12 | LINKER = ifx -Bdynamic $(CURDIR)/libcint/build/libcint.so -Bstatic 13 | LIBS = -Wl,--start-group ${MKLROOT}/lib/libmkl_intel_ilp64.a ${MKLROOT}/lib/libmkl_intel_thread.a ${MKLROOT}/lib/libmkl_core.a -Wl,--end-group -liomp5 14 | FFLAGS = -O3 -qopenmp -I$(MKLROOT)/include/intel64/ilp64 -I$(MKLROOT)/include -i8 15 | else 16 | LINKER = ifx -Bdynamic $(CURDIR)/libcint/build/libcint.so -Bstatic 17 | LIBS = -Wl,--start-group ${MKLROOT}/lib/libmkl_intel_lp64.a ${MKLROOT}/lib/libmkl_intel_thread.a ${MKLROOT}/lib/libmkl_core.a -Wl,--end-group -liomp5 18 | FFLAGS = -O3 -qopenmp -I$(MKLROOT)/include/intel64/lp64 -I$(MKLROOT)/include 19 | endif 20 | 21 | CFLAGS = -O -DLINUX 22 | endif 23 | 24 | ifeq ($(OSTYPE),MACOS) 25 | FC = ifx 26 | CC = gcc 27 | LINKER = ifx -qopenmp -I$(MKLROOT)/include/intel64/lp64 -I$(MKLROOT)/include 28 | LIBS = ${MKLROOT}/lib/libmkl_blas95_lp64.a ${MKLROOT}/lib/libmkl_intel_lp64.a ${MKLROOT}/lib/libmkl_intel_thread.a ${MKLROOT}/lib/libmkl_core.a -liomp5 -lpthread -ldl -lm 29 | PREFLAG = -E -P 30 | FFLAGS = -O3 -qopenmp -I$(MKLROOT)/include/intel64/lp64 -I$(MKLROOT)/include #-check all 31 | FFLAGS = -O3 -I${MKLROOT}/include/intel64/lp64 -I${MKLROOT}/include 32 | CCFLAGS = -O3 -DLINUX 33 | endif 34 | 35 | ################################################# 36 | OBJS=\ 37 | stdacommon.o stringmod.o main.o pckao.o \ 38 | header.o intpack.o velo.o libcint.o \ 39 | onetri.o prmat.o readl.o block.o\ 40 | stda.o stda-rw.o stda-rw_dual.o sutda.o sfstda.o srpapack.o intslvm.o io.o\ 41 | linal.o readbasa.o readbasmold.o printvec.o normalize.o 2PA.o\ 42 | apbtrafo.o sosor.o readxtb.o linear_response.o molden.o print_nto.o xstd.o full.o 43 | ################################################# 44 | 45 | %.o: %.f90 46 | @echo "making $@ from $<" 47 | $(FC) $(FFLAGS) -c $< -o $@ 48 | %.o: %.f 49 | @echo "making $@ from $<" 50 | $(FC) $(FFLAGS) -c $< -o $@ 51 | 52 | $(PROG): $(OBJS) 53 | @echo "Loading $(PROG) ... " 54 | @$(LINKER) $(OBJS) $(LIBS) -o $(PROG) 55 | 56 | clean: 57 | rm -f *.o *.mod $(PROG) 58 | -------------------------------------------------------------------------------- /stdacommon.f90: -------------------------------------------------------------------------------- 1 | ! This file is part of stda. 2 | ! 3 | ! Copyright (C) 2013-2019 Stefan Grimme 4 | ! 5 | ! stda is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! stda is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with stda. If not, see . 17 | ! 18 | ! wavefunction and basis common block 19 | module stdacommon 20 | 21 | real*8, allocatable :: co(:,:),exip(:),occ(:),eps(:) 22 | real*8, allocatable :: cxip(:),eta(:,:) 23 | integer, allocatable :: ipat(:),ipty(:),ipao(:),iaoat(:) 24 | character*2, allocatable :: atnam(:) 25 | logical :: spherical 26 | real*8 :: rsh,rsh_ax,rsh_beta,rsh2 27 | end module stdacommon 28 | 29 | ! xtb common block 30 | module kshiftcommon 31 | 32 | real*8 shftmax,shftwidth,shftsteep,shftmax_somo 33 | ! shftsteep: steepness, i.e. power of decay 34 | ! shftmax: maximum shift 35 | ! shftwidth: shiftwidth for damping 36 | 37 | end module kshiftcommon 38 | 39 | ! some logicals in order not to blow-up subroutine calls 40 | module commonlogicals 41 | logical triplet,rpachk,eigvec,screen,dokshift,printexciton,velcorr 42 | logical aniso 43 | logical resp,TPA,aresp,ESA,smp2,bfw,spinflip,rw,pt_off,nto,sf_s2,multipole 44 | logical optrota,velo_OR,rw_dual,XsTD,cint,RSH_flag,RSH_sub,SOS_2PA,Xcore 45 | logical FULL2PA,full,direct_full 46 | end module commonlogicals 47 | 48 | ! some variables for the response functions 49 | module commonresp 50 | integer :: num_freq 51 | integer :: num_trans 52 | integer :: state2opt 53 | integer :: Nnto, Ecore, Ecore2 54 | end module commonresp 55 | 56 | module commonlibcint 57 | integer :: n_env, nbas,n_at 58 | integer, allocatable :: atm(:,:), bas(:,:) 59 | integer, allocatable :: di_all(:), sum_di(:) 60 | double precision, allocatable :: env(:) 61 | integer,allocatable :: bas_start(:),bas_end(:),prim_at(:),counter_at(:) 62 | integer, allocatable :: Q_atom(:) 63 | end module commonlibcint 64 | -------------------------------------------------------------------------------- /onetri.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | ! 20 | SUBROUTINE ONETRI(ITY,S,S1,S2,ARRAY,N,IVAL) 21 | IMPLICIT REAL*8 (A-H,O-Z) 22 | C ******DESIGNED FOR ABELIAN GROUPS ONLY****** 23 | C 24 | C CALLING SEQUENCE: 25 | C ITY =1 SYM AO 26 | C =-1 ANTI SYM AO 27 | C S INPUT PROPERTY MATRIX OVER AO'S 28 | C S1 TRANSFORMED INTEGRALS ON OUTPUT 29 | C S2 SCRATCH ARRAYS LARGE ENOUGH TO HOLD A SQUARE MATRIX 30 | C ARRAY MO MATRIX OVER SO'S 31 | C N LINEAR DIMENSION OF ARRAYS 32 | C BERND HESS, UNIVERSITY OF BONN, JANUARY 1991 33 | DIMENSION S(*),S1(*),S2(*),ARRAY(N,IVAL) 34 | 35 | C 36 | C DETERMINE IF WE HAVE AN ANTISYMMETRIC INTEGRAL 37 | IF (ITY.EQ.-1) GOTO 99 38 | C 39 | C BLOW UP SYMMETRIC MATRIX S 40 | CALL BLOWSY(ITY,S,S1,N) 41 | 42 | C 43 | C TRANSFORMATION OF S 44 | CALL DSYMM('L','L',N,IVAL,1.D0,S1,N,ARRAY,N,0.D0,S2,N) 45 | CALL DGEMM('T','N',IVAL,IVAL,N,1.D0,ARRAY,N,S2,N,0.D0,S1,IVAL) 46 | RETURN 47 | 99 CONTINUE 48 | C 49 | C BLOW UP ANTI-SYMMETRIC MATRIX S 50 | CALL BLOWSY(ITY,S,S1,N) 51 | C 52 | C TRANSFORMATION OF S 53 | CALL DGEMM('N','N',N,IVAL,N,1.D0,S1,N,ARRAY,N,0.D0,S2,N) 54 | CALL DGEMM('T','N',IVAL,IVAL,N,1.D0,ARRAY,N,S2,N,0.D0,S1,IVAL) 55 | END 56 | SUBROUTINE BLOWSY(ITY,A,B,N) 57 | C 58 | C BLOW UP SYMMETRIC OR ANTISYMMETRIC MATRIX TO FULL SIZE 59 | REAL*8 A(*),B(N,N) 60 | C 61 | C DETERMINE IF WE HAVE AN ANTISYMMETRIC INTEGRAL 62 | 63 | IF (ITY.EQ.-1) GOTO 99 64 | IJ=0 65 | DO 1 I=1,N 66 | DO 2 J=1,I-1 67 | IJ=IJ+1 68 | B(J,I)=A(IJ) 69 | 2 B(I,J)=A(IJ) 70 | IJ=IJ+1 71 | B(I,I)=A(IJ) 72 | 1 CONTINUE 73 | RETURN 74 | 99 IJ=0 75 | DO 11 I=1,N 76 | DO 12 J=1,I-1 77 | IJ=IJ+1 78 | B(J,I)=-A(IJ) 79 | 12 B(I,J)=A(IJ) 80 | IJ=IJ+1 81 | B(I,I)=0.D0 82 | 11 CONTINUE 83 | RETURN 84 | END 85 | -------------------------------------------------------------------------------- /tests/run_tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # check parameters 4 | if [ "$#" -ne 1 ]; then 5 | >&2 echo "Illegal number of parameters" 6 | >&2 echo "usage: run_test.sh STD2_EXE" 7 | exit 1 8 | fi 9 | 10 | # EXE 11 | STD2_EXE=${1} 12 | 13 | # directory for the results 14 | EXPECTED_RESULTS_DIR="./expected_results" 15 | 16 | # total number of errors in the whole suite 17 | TOT_NERRORS=0 18 | 19 | # -- test suite for std2 (excitations energies) 20 | declare -A TESTS_STD2_EXCI 21 | 22 | TESTS_STD2_EXCI[EXCI_TEST1]='-f water_sto3g.molden -sty 3 -ax 1.0 -e 20' 23 | TESTS_STD2_EXCI[EXCI_TEST2]='-f water_sto3g.molden -sty 3 -ax 0.5 -e 30' 24 | TESTS_STD2_EXCI[EXCI_TEST3]='-f water_sto3g.molden -sty 3 -ax 1.0 -e 30 -be 1.0 -al 3.0' 25 | 26 | # run test suite 27 | for TEST in "${!TESTS_STD2_EXCI[@]}"; do 28 | # fetch parameters and run test 29 | TEST_PARAMS=${TESTS_STD2_EXCI[${TEST}]} 30 | echo "** Running test ${TEST} using '${TEST_PARAMS}'" 31 | ${STD2_EXE} ${TEST_PARAMS} > /dev/null 32 | 33 | # compare with expected results 34 | python3 compare.py -t tda ${EXPECTED_RESULTS_DIR}/${TEST}.dat tda.dat 35 | 36 | # count errors 37 | TEST_NERR=$? 38 | TOT_NERRORS=$(( ${TOT_NERRORS} + ${TEST_NERR} )) 39 | done 40 | 41 | # -- test suite for std2 (beta) 42 | declare -A TESTS_STD2_BETA 43 | 44 | TESTS_STD2_BETA[BETA_TEST1]='-f water_sto3g.molden -sty 3 -ax 1.0 -e 20 -resp 2' 45 | TESTS_STD2_BETA[BETA_TEST2]='-f water_sto3g.molden -sty 3 -ax 0.5 -e 30 -resp 2' 46 | TESTS_STD2_BETA[BETA_TEST3]='-f water_sto3g.molden -sty 3 -ax 1.0 -e 30 -be 1.0 -al 3.0 -resp 2' 47 | 48 | # run test suite 49 | for TEST in "${!TESTS_STD2_BETA[@]}"; do 50 | # fetch parameters and run test 51 | TEST_PARAMS=${TESTS_STD2_BETA[${TEST}]} 52 | echo "** Running test ${TEST} using '${TEST_PARAMS}'" 53 | ${STD2_EXE} ${TEST_PARAMS} > /dev/null 54 | 55 | # compare with expected results 56 | python3 compare.py -t beta_HRS ${EXPECTED_RESULTS_DIR}/${TEST}.txt beta_HRS 57 | 58 | # count errors 59 | TEST_NERR=$? 60 | TOT_NERRORS=$(( ${TOT_NERRORS} + ${TEST_NERR} )) 61 | done 62 | 63 | # -- test suite for std2 (beta) 64 | declare -A TESTS_STD2_2PA 65 | 66 | TESTS_STD2_2PA[2PA_TEST1]='-f water_sto3g.molden -sty 3 -ax 1.0 -e 20 -2PA 3' 67 | TESTS_STD2_2PA[2PA_TEST2]='-f water_sto3g.molden -sty 3 -ax 0.5 -e 30 -2PA 3' 68 | TESTS_STD2_2PA[2PA_TEST3]='-f water_sto3g.molden -sty 3 -ax 1.0 -e 30 -be 1.0 -al 3.0 -2PA 3' 69 | 70 | # run test suite 71 | for TEST in "${!TESTS_STD2_2PA[@]}"; do 72 | # fetch parameters and run test 73 | TEST_PARAMS=${TESTS_STD2_2PA[${TEST}]} 74 | echo "** Running test ${TEST} using '${TEST_PARAMS}'" 75 | ${STD2_EXE} ${TEST_PARAMS} > /dev/null 76 | 77 | # compare with expected results 78 | python3 compare.py -t 2PA ${EXPECTED_RESULTS_DIR}/${TEST}.txt 2PA-abs 79 | 80 | # count errors 81 | TEST_NERR=$? 82 | TOT_NERRORS=$(( ${TOT_NERRORS} + ${TEST_NERR} )) 83 | done 84 | 85 | # exit 86 | exit ${TOT_NERRORS} 87 | -------------------------------------------------------------------------------- /tests/water_sto3g.molden: -------------------------------------------------------------------------------- 1 | [Molden Format] 2 | [Atoms] Angs 3 | O 1 8 0.0000000000 0.0000000000 0.1196030000 4 | H 2 1 0.0000000000 0.7618130000 -0.4784100000 5 | H 3 1 0.0000000000 -0.7618130000 -0.4784100000 6 | [GTO] 7 | 1 0 8 | s 3 1.00 9 | 0.1307093214d+03 0.1543289673d+00 10 | 0.2380886605d+02 0.5353281423d+00 11 | 0.6443608313d+01 0.4446345422d+00 12 | sp 3 1.00 13 | 0.5033151319d+01 -0.9996722919d-01 0.1559162750d+00 14 | 0.1169596125d+01 0.3995128261d+00 0.6076837186d+00 15 | 0.3803889600d+00 0.7001154689d+00 0.3919573931d+00 16 | 17 | 2 0 18 | s 3 1.00 19 | 0.3425250914d+01 0.1543289673d+00 20 | 0.6239137298d+00 0.5353281423d+00 21 | 0.1688554040d+00 0.4446345422d+00 22 | 23 | 3 0 24 | s 3 1.00 25 | 0.3425250914d+01 0.1543289673d+00 26 | 0.6239137298d+00 0.5353281423d+00 27 | 0.1688554040d+00 0.4446345422d+00 28 | 29 | [MO] 30 | Sym= 1 31 | Ene= -20.2441800000000 32 | Spin= Alpha 33 | Occup= 2.000000 34 | 1 0.9941600000 35 | 2 0.0263200000 36 | 3 0.0000000000 37 | 4 0.0000000000 38 | 5 -0.0042600000 39 | 6 -0.0058400000 40 | 7 -0.0058400000 41 | Sym= 2 42 | Ene= -1.26362000000000 43 | Spin= Alpha 44 | Occup= 2.000000 45 | 1 -0.2331700000 46 | 2 0.8374900000 47 | 3 0.0000000000 48 | 4 0.0000000000 49 | 5 -0.1264900000 50 | 6 0.1577900000 51 | 7 0.1577900000 52 | Sym= 3 53 | Ene= -0.610740000000000 54 | Spin= Alpha 55 | Occup= 2.000000 56 | 1 0.0000000000 57 | 2 0.0000000000 58 | 3 0.0000000000 59 | 4 0.6071900000 60 | 5 0.0000000000 61 | 6 0.4461700000 62 | 7 -0.4461700000 63 | Sym= 4 64 | Ene= -0.453510000000000 65 | Spin= Alpha 66 | Occup= 2.000000 67 | 1 -0.1030700000 68 | 2 0.5354400000 69 | 3 0.0000000000 70 | 4 0.0000000000 71 | 5 0.7718300000 72 | 6 -0.2831800000 73 | 7 -0.2831800000 74 | Sym= 5 75 | Ene= -0.391120000000000 76 | Spin= Alpha 77 | Occup= 2.000000 78 | 1 0.0000000000 79 | 2 0.0000000000 80 | 3 1.0000000000 81 | 4 0.0000000000 82 | 5 0.0000000000 83 | 6 0.0000000000 84 | 7 0.0000000000 85 | Sym= 6 86 | Ene= 0.595890000000000 87 | Spin= Alpha 88 | Occup= 0.0000000E+00 89 | 1 -0.130440000000000 90 | 2 0.863430000000000 91 | 3 0.000000000000000E+000 92 | 4 0.000000000000000E+000 93 | 5 -0.745860000000000 94 | 6 -0.788160000000000 95 | 7 -0.788160000000000 96 | Sym= 7 97 | Ene= 0.726820000000000 98 | Spin= Alpha 99 | Occup= 0.0000000E+00 100 | 1 0.000000000000000E+000 101 | 2 0.000000000000000E+000 102 | 3 0.000000000000000E+000 103 | 4 0.981910000000000 104 | 5 0.000000000000000E+000 105 | 6 -0.829080000000000 106 | 7 0.829080000000000 107 | -------------------------------------------------------------------------------- /pckao.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | SUBROUTINE pckao(NPR,NAO,A,B) 20 | use stdacommon 21 | IMPLICIT REAL*8(A-H,O-Z) 22 | integer*8 ij,kl,k,iaa,iii 23 | 24 | dimension a(*),b(*) 25 | 26 | if(nao.eq.0) then 27 | k=0 28 | do i=1,npr 29 | do j=1,i 30 | k=k+1 31 | b(k)=a(k) 32 | enddo 33 | enddo 34 | return 35 | endif 36 | 37 | ij=nao 38 | ij=ij*(ij+1)/2 39 | b(1:ij)=0.0d0 40 | 41 | kl=0 42 | do i=1,npr 43 | iai=ipao(i) 44 | c1=cxip(i) 45 | do j=1,i-1 46 | kl=kl+1 47 | c2=cxip(j) 48 | iaj=ipao(j) 49 | iaa=max(iaj,iai) 50 | iii=min(iaj,iai) 51 | ij=iii+iaa*(iaa-1)/2 52 | b(ij)=b(ij)+a(kl)*c1*c2*2.0d0 53 | enddo 54 | kl=kl+1 55 | ij=iai 56 | ij=ij+ij*(ij-1)/2 57 | b(ij)=b(ij)+a(kl)*c1*c1 58 | enddo 59 | 60 | ij=0 61 | do i=1,nao 62 | do j=1,i-1 63 | ij=ij+1 64 | b(ij)=b(ij)*0.5 65 | enddo 66 | ij=ij+1 67 | enddo 68 | 69 | return 70 | end 71 | 72 | SUBROUTINE pckao3(NPR,NAO,A1,A2,A3,B1,B2,B3) 73 | use stdacommon 74 | IMPLICIT REAL*8(A-H,O-Z) 75 | integer*8 ij,kl,k 76 | 77 | dimension a1(*),b1(*) 78 | dimension a2(*),b2(*) 79 | dimension a3(*),b3(*) 80 | 81 | if(nao.eq.0) then 82 | k=0 83 | do i=1,npr 84 | do j=1,i 85 | k=k+1 86 | b1(k)=a1(k) 87 | b2(k)=a2(k) 88 | b3(k)=a3(k) 89 | enddo 90 | enddo 91 | return 92 | endif 93 | 94 | ij=nao 95 | ij=ij*(ij+1)/2 96 | b1(1:ij)=0.0d0 97 | b2(1:ij)=0.0d0 98 | b3(1:ij)=0.0d0 99 | 100 | kl=0 101 | do i=1,npr 102 | iai=ipao(i) 103 | c1=cxip(i) 104 | do j=1,i-1 105 | kl=kl+1 106 | c2=cxip(j) 107 | iaj=ipao(j) 108 | iaa=max(iaj,iai) 109 | iii=min(iaj,iai) 110 | ij=iii+iaa*(iaa-1)/2 111 | ccf=c1*c2*2.0d0 112 | b1(ij)=b1(ij)+a1(kl)*ccf 113 | b2(ij)=b2(ij)+a2(kl)*ccf 114 | b3(ij)=b3(ij)+a3(kl)*ccf 115 | enddo 116 | kl=kl+1 117 | ij=iai 118 | ij=ij+ij*(ij-1)/2 119 | b1(ij)=b1(ij)+a1(kl)*c1*c1 120 | b2(ij)=b2(ij)+a2(kl)*c1*c1 121 | b3(ij)=b3(ij)+a3(kl)*c1*c1 122 | enddo 123 | 124 | ij=0 125 | do i=1,nao 126 | do j=1,i-1 127 | ij=ij+1 128 | b1(ij)=b1(ij)*0.50d0 129 | b2(ij)=b2(ij)*0.50d0 130 | b3(ij)=b3(ij)*0.50d0 131 | enddo 132 | ij=ij+1 133 | enddo 134 | 135 | return 136 | end 137 | -------------------------------------------------------------------------------- /sosor.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | subroutine sosor(nroots,xmass,x,y) 20 | implicit none 21 | real*4 x(*) 22 | real*8 y(*),xmass 23 | real*8 xlam(6),r1(6) 24 | integer nroots 25 | 26 | integer i,j 27 | real*8 eau,xau,refval,vorfaktor,reffaktor 28 | real*8 refindex,rau 29 | logical da 30 | 31 | c data ams / 1.00790d0, 4.00260d0, 6.94000d0, 9.01218d0, 32 | c .10.81000d0, 12.01100d0, 14.00670d0, 15.99940d0, 18.99840d0, 33 | c .20.17900d0, 22.98977d0, 24.30500d0, 26.98154d0, 28.08550d0, 34 | c .30.97376d0, 32.06000d0, 35.45300d0, 39.94800d0, 39.09830d0, 35 | c .40.08000d0, 44.95590d0, 47.90000d0, 50.94150d0, 51.99600d0, 36 | c .54.93800d0, 55.84700d0, 58.93320d0, 58.71000d0, 63.54600d0, 37 | c .65.38000d0, 69.73500d0, 72.59000d0, 74.92160d0, 78.96000d0, 38 | c .79.90400d0, 83.80000d0, 85.46780d0, 87.62000d0, 88.90590d0, 39 | c .91.22000d0, 92.90640d0, 95.94000d0, 98.90620d0, 101.0700d0, 40 | c .102.9055d0, 106.4000d0, 107.8680d0, 112.4100d0, 114.8200d0, 41 | c .118.6900d0, 121.7500d0, 127.6000d0, 126.9045d0, 131.3000d0, 42 | c .132.9054d0, 137.3300d0, 15*0.000d0, 178.4900d0, 180.9479d0, 43 | c .183.8500d0, 186.2070d0, 190.2000d0, 192.2200d0, 195.0900d0, 44 | c .196.9665d0, 200.5900d0, 204.3700d0, 207.2000d0, 208.9804d0, 45 | c .18*0.000d0, 0.0000d0, 5*0.000d0/ 46 | 47 | ************************************************************************ 48 | * ORD at 6 nm values 49 | * conversion from R to alpha: 50 | * P. L. Polavarapu and D. K. Chakraborty 51 | * Chem.Phys. 240 (1999) page 1 52 | ************************************************************************ 53 | 54 | c xmass=0 55 | c do i=1,n 56 | c xmass=xmass+ams(idint(xyz(4,i))) 57 | c enddo 58 | 59 | xlam(1)=632.8 60 | xlam(2)=589.3 61 | xlam(3)=579. 62 | xlam(4)=546. 63 | xlam(5)=436. 64 | xlam(6)=365. 65 | 66 | c refractive index of solvent 67 | refindex=1.4d0 68 | reffaktor=(refindex**2+2.0d0)/3.0d0 69 | 70 | do j=1,6 71 | 72 | r1(j)=0.0d0 73 | do i=1,nroots 74 | xau =x(i) 75 | c measurement point 76 | eau =1.d+7/xlam(j)/2.19474625d+5 77 | c R in au (input in 10-40 cgs) taken from TM 78 | rau =y(i)/64604.8 79 | c beta 80 | r1(j)=r1(j)+(2.*137.036/3.)*rau/(xau**2-eau**2) 81 | enddo 82 | vorfaktor=(38652./xmass)*(xlam(2)/xlam(j))**2 83 | r1(j)=r1(j)*vorfaktor*reffaktor 84 | enddo 85 | 86 | refval=0 87 | inquire(file='.ref',exist=da) 88 | if(da)then 89 | open(unit=33,file='.ref') 90 | read(33,*)refval 91 | close(33) 92 | endif 93 | 94 | write(*,*) 95 | write(*,*) 'SOS specific optical rotation ' 96 | write(*,*) 'including Lorentz factor for common solvent (n=1.4)' 97 | write(*,*) 'lambda [eV] alpha[grad*cm^3*g^-1*dm^-1]' 98 | do j=1,6 99 | if(j.eq.2)then 100 | write(*,142) xlam(j),1.d+7/(8065.54093*xlam(j)), 101 | . r1(j),refval 102 | else 103 | write(*,143) xlam(j),1.d+7/(8065.54093*xlam(j)), 104 | . r1(j) 105 | endif 106 | enddo 107 | write(*,*) 108 | 109 | 142 format(f6.1,f6.2,2f12.2,' ##') 110 | 143 format(f6.1,f6.2,2f12.2) 111 | 112 | end 113 | -------------------------------------------------------------------------------- /readl.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | 20 | C ***************************************************************** 21 | 22 | SUBROUTINE READL(NL,A1,X,N) 23 | IMPLICIT REAL*8 (A-H,O-Z) 24 | CHARACTER*1 A1(*) 25 | DIMENSION X(*) 26 | I=0 27 | IS=1 28 | 10 I=I+1 29 | X(I)=XREAD(NL,A1,IS,IB,IE) 30 | IF(IB.GT.0 .AND. IE.GT.0) THEN 31 | IS=IE 32 | GOTO 10 33 | ENDIF 34 | N=I-1 35 | RETURN 36 | END 37 | 38 | C ***************************************************************** 39 | 40 | SUBROUTINE IREADL(NL,A1,IX,N) 41 | IMPLICIT REAL*8 (A-H,O-Z) 42 | CHARACTER*1 A1(*) 43 | DIMENSION IX(*) 44 | I=0 45 | IS=1 46 | 10 I=I+1 47 | IX(I)=IDINT(XREAD(NL,A1,IS,IB,IE)) 48 | IF(IB.GT.0 .AND. IE.GT.0) THEN 49 | IS=IE 50 | GOTO 10 51 | ENDIF 52 | N=I-1 53 | RETURN 54 | END 55 | 56 | C ***************************************************************** 57 | 58 | 59 | FUNCTION XREAD(NL,A,ISTART,IEND,IEND2) 60 | IMPLICIT REAL*8 (A-H,O-Z) 61 | REAL*8 XREAD 62 | 63 | CHARACTER*1 A(NL) 64 | NINE=ICHAR('9') 65 | IZERO=ICHAR('0') 66 | MINUS=ICHAR('-') 67 | IDOT=ICHAR('.') 68 | ND=ICHAR('D') 69 | NE=ICHAR('E') 70 | IBL=ICHAR(' ') 71 | IEND=0 72 | IEND2=0 73 | IDIG=0 74 | C1=0 75 | C2=0 76 | ONE=1.D0 77 | X = 1.D0 78 | DO 10 J=ISTART,NL-1 79 | N=ICHAR(A(J)) 80 | M=ICHAR(A(J+1)) 81 | IF(N.LE.NINE.AND.N.GE.IZERO .OR.N.EQ.IDOT)GOTO 20 82 | IF(N.EQ.MINUS.AND.(M.LE.NINE.AND.M.GE.IZERO 83 | 1 .OR. M.EQ.IDOT)) GOTO 20 84 | 10 CONTINUE 85 | XREAD=0.D0 86 | RETURN 87 | 20 CONTINUE 88 | IEND=J 89 | DO 30 I=J,NL 90 | N=ICHAR(A(I)) 91 | IF(N.LE.NINE.AND.N.GE.IZERO) THEN 92 | IDIG=IDIG+1 93 | IF (IDIG.GT.10) GOTO 60 94 | C1=C1*10+N-IZERO 95 | ELSEIF(N.EQ.MINUS.AND.I.EQ.J) THEN 96 | ONE=-1.D0 97 | ELSEIF(N.EQ.IDOT) THEN 98 | GOTO 40 99 | ELSE 100 | GOTO 60 101 | ENDIF 102 | 30 CONTINUE 103 | 40 CONTINUE 104 | IDIG=0 105 | DO 50 II=I+1,NL 106 | N=ICHAR(A(II)) 107 | IF(N.LE.NINE.AND.N.GE.IZERO) THEN 108 | IDIG=IDIG+1 109 | IF (IDIG.GT.10) GOTO 60 110 | C2=C2*10+N-IZERO 111 | X = X /10 112 | ELSEIF(N.EQ.MINUS.AND.II.EQ.I) THEN 113 | X=-X 114 | ELSE 115 | GOTO 60 116 | ENDIF 117 | 50 CONTINUE 118 | C 119 | C PUT THE PIECES TOGETHER 120 | C 121 | 60 CONTINUE 122 | XREAD= ONE * ( C1 + C2 * X) 123 | DO 55 J=IEND,NL 124 | N=ICHAR(A(J)) 125 | IEND2=J 126 | IF(N.EQ.IBL)RETURN 127 | 55 IF(N.EQ.ND .OR. N.EQ.NE)GOTO 57 128 | RETURN 129 | 130 | 57 C1=0.0D0 131 | ONE=1.0D0 132 | DO 31 I=J+1,NL 133 | N=ICHAR(A(I)) 134 | IEND2=I 135 | IF(N.EQ.IBL)GOTO 70 136 | IF(N.LE.NINE.AND.N.GE.IZERO) C1=C1*10.0D0+N-IZERO 137 | IF(N.EQ.MINUS)ONE=-1.0D0 138 | 31 CONTINUE 139 | 61 CONTINUE 140 | 70 XREAD=XREAD*10**(ONE*C1) 141 | RETURN 142 | END 143 | -------------------------------------------------------------------------------- /tests/compare.py: -------------------------------------------------------------------------------- 1 | """ 2 | Compare the results for different files of std2 and report errors if the info they contain differs 3 | """ 4 | 5 | import argparse 6 | import math 7 | 8 | def get_tda_results(f): 9 | """ 10 | Extract the list of excitations with corresponding fL 11 | """ 12 | results = { 13 | 'excitation energy': [], 14 | 'fL': [], 15 | } 16 | 17 | lines = f.readlines() 18 | datxy_found = -1 19 | for i, line in enumerate(lines): 20 | if 'DATXY' in line: 21 | datxy_found = i 22 | break 23 | 24 | if datxy_found < 0: 25 | raise Exception('DATXY not found') 26 | 27 | for line in lines[datxy_found + 1:]: 28 | chunks = line.split() 29 | 30 | results['excitation energy'].append(float(chunks[1])) 31 | results['fL'].append(float(chunks[2])) 32 | 33 | return results 34 | 35 | def get_beta_HRS_results(f): 36 | """ 37 | Extract the list of beta HRS 38 | """ 39 | 40 | results = { 41 | 'beta HRS': [], 42 | } 43 | 44 | lines = f.readlines() 45 | 46 | for line in lines: 47 | chunks = line.split() 48 | results['beta HRS'].append(float(chunks[1])) 49 | 50 | return results 51 | 52 | def get_2PA_results(f): 53 | """ 54 | Extract the list of 2PA quantities 55 | """ 56 | 57 | results = { 58 | 'excitation energy': [], 59 | 'Delta_2PA_//': [], 60 | 'Delta_2PA__|_': [], 61 | 'Delta_2PA_circ': [], 62 | 'rho': [], 63 | } 64 | lines = f.readlines() 65 | 66 | for line in lines: 67 | chunks = line.split() 68 | results['excitation energy'].append(float(chunks[1])) 69 | results['Delta_2PA_//'].append(float(chunks[2])) 70 | results['Delta_2PA__|_'].append(float(chunks[3])) 71 | results['Delta_2PA_circ'].append(float(chunks[4])) 72 | results['rho'].append(float(chunks[5])) 73 | 74 | return results 75 | 76 | 77 | def check_equal(expected, actual, label, delta=1e-3): 78 | """ 79 | Check if two arrays contain the same data, with a difference < `delta` 80 | """ 81 | 82 | if len(expected) != len(actual): 83 | print('! ERROR: the size of `expected` and `actual` differs') 84 | return abs(len(expected) - len(actual)) 85 | 86 | n_errors = 0 87 | for left, right in zip(expected[label], actual[label]): 88 | if math.fabs(left - right) > delta: 89 | n_errors += 1 90 | 91 | if n_errors > 0: 92 | print('! ERROR: differences are larger than {} for {}'.format(delta, label)) 93 | print(' expected ::', expected[label]) 94 | print(' actual ::', actual[label]) 95 | 96 | return n_errors 97 | 98 | parser = argparse.ArgumentParser() 99 | parser.add_argument('-t', '--type', choices=['tda', 'beta_HRS', '2PA']) 100 | parser.add_argument('expected', type=argparse.FileType('r')) 101 | parser.add_argument('actual', type=argparse.FileType('r')) 102 | 103 | args = parser.parse_args() 104 | 105 | # count errors 106 | n_errors = 0 107 | 108 | if args.type == 'tda': 109 | expected_data = get_tda_results(args.expected) 110 | actual_data = get_tda_results(args.actual) 111 | 112 | n_errors += check_equal(expected_data, actual_data, 'excitation energy') 113 | n_errors += check_equal(expected_data, actual_data, 'fL') 114 | 115 | if args.type == 'beta_HRS': 116 | expected_data = get_beta_HRS_results(args.expected) 117 | actual_data = get_beta_HRS_results(args.actual) 118 | 119 | n_errors += check_equal(expected_data, actual_data, 'beta HRS') 120 | 121 | if args.type == '2PA': 122 | expected_data = get_2PA_results(args.expected) 123 | actual_data = get_2PA_results(args.actual) 124 | 125 | n_errors += check_equal(expected_data, actual_data, 'excitation energy') 126 | n_errors += check_equal(expected_data, actual_data, 'Delta_2PA_//', delta=1e-2) 127 | n_errors += check_equal(expected_data, actual_data, 'Delta_2PA__|_', delta=1e-2) 128 | n_errors += check_equal(expected_data, actual_data, 'Delta_2PA_circ', delta=1e-2) 129 | n_errors += check_equal(expected_data, actual_data, 'rho', delta=1e-2) 130 | 131 | # exit 132 | if n_errors == 0: 133 | print('OK') 134 | 135 | exit(n_errors) 136 | -------------------------------------------------------------------------------- /prmat.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | SUBROUTINE PRMAT(IUOUT,R,N,M,HEAD) 20 | CHARACTER*(*) HEAD 21 | real*8 R(*) 22 | C SUBROUTINE PRINTS MATRIX R,WHICH IS SUPPOSED 23 | C TO HAVE DIMENSION N,M WHEN M IS NONZERO AND 24 | C ((N+1)*N)/2 WHEN M IS ZERO 25 | 26 | WRITE(IUOUT,1001) HEAD 27 | NKPB=8 28 | IF(M)10,10,80 29 | C 30 | 10 CONTINUE 31 | IBL=N/NKPB 32 | IR=N-IBL*NKPB 33 | J1=1 34 | K1S=1 35 | KD=0 36 | IF(IBL.EQ.0) GO TO 50 37 | J2=NKPB 38 | DO 40 I=1,IBL 39 | WRITE(IUOUT,1002)(J,J=J1,J2) 40 | K1=K1S 41 | K2=K1 42 | KK=0 43 | DO 20 J=J1,J2 44 | WRITE(IUOUT,1003)J,(R(K),K=K1,K2) 45 | KK=KK+1 46 | K1=K1+KD+KK 47 | 20 K2=K1+KK 48 | J1=J1+NKPB 49 | IF(J1.GT.N) RETURN 50 | J2=J2+NKPB 51 | K2=K1-1 52 | K1=K2+1 53 | K2=K1+(NKPB-1) 54 | K1S=K2+1 55 | KK=KD+NKPB 56 | DO 30 J=J1,N 57 | WRITE(IUOUT,1003)J,(R(K),K=K1,K2) 58 | KK=KK+1 59 | K1=K1+KK 60 | 30 K2=K2+KK 61 | 40 KD=KD+NKPB 62 | 50 IF(IR.EQ.0) GO TO 70 63 | K1=K1S 64 | J2=J1+IR-1 65 | KK=0 66 | K2=K1 67 | WRITE(IUOUT,1002)(J,J=J1,J2) 68 | WRITE(IUOUT,1003) 69 | DO 60 J=J1,J2 70 | WRITE(IUOUT,1003)J,(R(K),K=K1,K2) 71 | KK=KK+1 72 | K1=K1+KD+KK 73 | 60 K2=K1+KK 74 | 70 RETURN 75 | 80 IBL=M/NKPB 76 | IR=M-IBL*NKPB 77 | I2=0 78 | K2=0 79 | IF(IBL.EQ.0) GO TO 100 80 | DO 90 I=1,IBL 81 | I1=(I-1)*N*NKPB+1 82 | I2=I1+(NKPB-1)*N 83 | K1=K2+1 84 | K2=K1+(NKPB-1) 85 | WRITE(IUOUT,1002)(K,K=K1,K2) 86 | DO 90 J=1,N 87 | WRITE(IUOUT,1003)J,(R(IJ),IJ=I1,I2,N) 88 | I1=I1+1 89 | 90 I2=I1+(NKPB-1)*N 90 | 100 IF(IR.EQ.0) GO TO 120 91 | I1=IBL*N*NKPB+1 92 | I2=I1+(IR-1)*N 93 | K1=K2+1 94 | K2=M 95 | WRITE(IUOUT,1002)(K,K=K1,K2) 96 | WRITE(IUOUT,1003) 97 | DO 110 J=1,N 98 | WRITE(IUOUT,1003)J,(R(IJ),IJ=I1,I2,N) 99 | I1=I1+1 100 | I2=I1+(IR-1)*N 101 | 110 CONTINUE 102 | 120 WRITE(IUOUT,1003) 103 | RETURN 104 | 1001 FORMAT(/,2X,A) 105 | 1002 FORMAT(/,' ',4X,8(3X,I4,3X),/) 106 | 1003 FORMAT(' ',I4,8F10.5) 107 | END 108 | 109 | SUBROUTINE PRMAT4(IUOUT,R,N,M,HEAD) 110 | CHARACTER*(*) HEAD 111 | real*4 R(*) 112 | C SUBROUTINE PRINTS MATRIX R,WHICH IS SUPPOSED 113 | C TO HAVE DIMENSION N,M WHEN M IS NONZERO AND 114 | C ((N+1)*N)/2 WHEN M IS ZERO 115 | 116 | WRITE(IUOUT,1001) HEAD 117 | NKPB=8 118 | IF(M)10,10,80 119 | C 120 | 10 CONTINUE 121 | IBL=N/NKPB 122 | IR=N-IBL*NKPB 123 | J1=1 124 | K1S=1 125 | KD=0 126 | IF(IBL.EQ.0) GO TO 50 127 | J2=NKPB 128 | DO 40 I=1,IBL 129 | WRITE(IUOUT,1002)(J,J=J1,J2) 130 | K1=K1S 131 | K2=K1 132 | KK=0 133 | DO 20 J=J1,J2 134 | WRITE(IUOUT,1003)J,(R(K),K=K1,K2) 135 | KK=KK+1 136 | K1=K1+KD+KK 137 | 20 K2=K1+KK 138 | J1=J1+NKPB 139 | IF(J1.GT.N) RETURN 140 | J2=J2+NKPB 141 | K2=K1-1 142 | K1=K2+1 143 | K2=K1+(NKPB-1) 144 | K1S=K2+1 145 | KK=KD+NKPB 146 | DO 30 J=J1,N 147 | WRITE(IUOUT,1003)J,(R(K),K=K1,K2) 148 | KK=KK+1 149 | K1=K1+KK 150 | 30 K2=K2+KK 151 | 40 KD=KD+NKPB 152 | 50 IF(IR.EQ.0) GO TO 70 153 | K1=K1S 154 | J2=J1+IR-1 155 | KK=0 156 | K2=K1 157 | WRITE(IUOUT,1002)(J,J=J1,J2) 158 | WRITE(IUOUT,1003) 159 | DO 60 J=J1,J2 160 | WRITE(IUOUT,1003)J,(R(K),K=K1,K2) 161 | KK=KK+1 162 | K1=K1+KD+KK 163 | 60 K2=K1+KK 164 | 70 RETURN 165 | 80 IBL=M/NKPB 166 | IR=M-IBL*NKPB 167 | I2=0 168 | K2=0 169 | IF(IBL.EQ.0) GO TO 100 170 | DO 90 I=1,IBL 171 | I1=(I-1)*N*NKPB+1 172 | I2=I1+(NKPB-1)*N 173 | K1=K2+1 174 | K2=K1+(NKPB-1) 175 | WRITE(IUOUT,1002)(K,K=K1,K2) 176 | DO 90 J=1,N 177 | WRITE(IUOUT,1003)J,(R(IJ),IJ=I1,I2,N) 178 | I1=I1+1 179 | 90 I2=I1+(NKPB-1)*N 180 | 100 IF(IR.EQ.0) GO TO 120 181 | I1=IBL*N*NKPB+1 182 | I2=I1+(IR-1)*N 183 | K1=K2+1 184 | K2=M 185 | WRITE(IUOUT,1002)(K,K=K1,K2) 186 | WRITE(IUOUT,1003) 187 | DO 110 J=1,N 188 | WRITE(IUOUT,1003)J,(R(IJ),IJ=I1,I2,N) 189 | I1=I1+1 190 | I2=I1+(IR-1)*N 191 | 110 CONTINUE 192 | 120 WRITE(IUOUT,1003) 193 | RETURN 194 | 1001 FORMAT(/,2X,A) 195 | 1002 FORMAT(/,' ',4X,8(3X,I4,3X),/) 196 | 1003 FORMAT(' ',I4,8F10.5) 197 | END 198 | -------------------------------------------------------------------------------- /molden.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 20 | ! 21 | ! 22 | ! write an output molden file with the normalized AO basis set 23 | ! 24 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 25 | subroutine molden_file(ncent,nprims,nmo,icdim,nbf,imethod,cc, 26 | . ccspin) 27 | use stdacommon 28 | implicit none 29 | integer:: i,j,prim,at,ncent,nprims,info(nprims) 30 | integer:: nmo,nbf,imethod,icdim,ccspin(nmo),counter_BF 31 | integer:: f_info(nbf),flag,flag2 32 | real*8:: cc(icdim),norm(nprims) 33 | 34 | open(unit=11,file='molden.molden') 35 | open(unit=12,file='fnorm') 36 | ! read normalization 37 | Do i=1,nprims 38 | read(12,*)norm(i) 39 | enddo 40 | close(12,status='delete') 41 | ! Geometry 42 | write(11,*) '[Molden Format]' 43 | write(11,*) '[Atoms] Angs' 44 | Do i=1, ncent 45 | write(11,21) atnam(i),i,int(co(i,4)),co(i,1:3)*0.52917721092 46 | enddo 47 | !Basis set (sp are seperated) 48 | 49 | ! Counting the number of prim in each contraction 50 | prim=1 51 | info=1 52 | Do i=2,nprims 53 | if(prim/=i)then 54 | if(ipao(i)==ipao(i-1))then 55 | info(prim)=info(prim)+1 56 | info(i)=0 57 | else 58 | prim=i 59 | endif 60 | endif 61 | enddo 62 | 63 | write(11,*) '[GTO]' 64 | at=0 65 | counter_BF=0 66 | f_info=0 67 | flag=0 68 | flag2=0 69 | Do i=1,nprims 70 | if(at/=ipat(i)) write(11,22) ipat(i),'0' 71 | if(info(i)/=0)then 72 | counter_BF=counter_BF+1 73 | if(ipty(i)==1.and.exip(i)==exip(i+1).and.info(i)==1.and. 74 | . ipty(i+1)==2)then 75 | flag=1 76 | flag2=i 77 | write(11,23)'sp',info(i),'1.000000' 78 | endif 79 | if(ipty(i)==1.and.exip(i)==exip(i+info(i)).and.info(i)>1.and. 80 | . ipty(i+info(i))==2)then 81 | flag=1 82 | flag2=i 83 | write(11,23)'sp',info(i),'1.000000' 84 | endif 85 | if(ipty(i)==1.and.flag==0) write(11,23)'s',info(i),'1.000000' 86 | if(ipty(i)==2.and.flag==0) write(11,23)'p',info(i),'1.000000' 87 | if(ipty(i)==5) write(11,23)'d',info(i),'1.000000' 88 | if(ipty(i)==11) write(11,23)'f',info(i),'1.000000' 89 | 90 | if(ipty(i)==14.or.ipty(i)==15.or.ipty(i)==16.or. 91 | . ipty(i)==17.or.ipty(i)==18.or.ipty(i)==19) then 92 | f_info(counter_BF)=ipty(i) 93 | 94 | endif 95 | 96 | 97 | endif 98 | ! 99 | ! Contractactions are normalized 100 | ! 101 | if(ipty(i)==1.and.flag==1)then 102 | write(11,25)exip(i), 103 | . cxip(i)*dsqrt(5.5683279968317 104 | . /(2.0*exip(i)*dsqrt(2.0*exip(i))))/norm(i), 105 | . cxip(i+info(flag2))*dsqrt(5.5683279968317*0.5 106 | . /((2.0*exip(i+info(flag2)))**2.0 107 | . *dsqrt(2.0*exip(i+info(flag2)))))/norm(i+info(flag2)) 108 | endif 109 | if(ipty(i)==1.and.flag==0) write(11,24)exip(i), 110 | . cxip(i)*dsqrt(5.5683279968317 111 | . /(2.0*exip(i)*dsqrt(2.0*exip(i))))/norm(i) 112 | if(ipty(i)==2.and.flag==0) write(11,24)exip(i), 113 | . cxip(i)*dsqrt(5.5683279968317*0.5 114 | . /((2.0*exip(i))**2.0*dsqrt(2.0*exip(i))))/norm(i) 115 | if(ipty(i)==5) write(11,24)exip(i), 116 | . cxip(i)*dsqrt(5.5683279968317*0.75 117 | . /((2.0*exip(i))**3.0*dsqrt(2.0*exip(i))))/norm(i) 118 | if(ipty(i)==11) write(11,24)exip(i), 119 | . cxip(i)*dsqrt(5.5683279968317*1.875 120 | . /((2.0*exip(i))**4.0*dsqrt(2.0*exip(i))))/norm(i) 121 | at=ipat(i) 122 | if(at/=ipat(i+1)) write(11,*) 123 | if(flag==1.and.ipty(i)==4)then 124 | flag=0 125 | flag2=0 126 | endif 127 | enddo 128 | 129 | ! MOs 130 | 131 | write(11,*) '[MO]' 132 | Do i=1,nmo 133 | write(11,*) 'Sym= X' 134 | write(11,*) 'Ene=',eps(i) 135 | if(imethod==1)then 136 | write(11,*) 'Spin= Alpha' 137 | else 138 | if(ccspin(i)==1) write(11,*) 'Spin= Alpha' 139 | if(ccspin(i)==2) write(11,*) 'Spin= Beta' 140 | endif 141 | write(11,*) 'Occup=',int(occ(i)) 142 | Do j=1,nbf 143 | 144 | ! f molden order 145 | if(f_info(j)==14.or.f_info(j)==15.or.f_info(j)==16.or. 146 | . f_info(j)==17.or.f_info(j)==18.or.f_info(j)==19) then 147 | 148 | if(f_info(j)==14)write(11,*) j, cc((i-1)*nbf+j+2) ! 16 149 | if(f_info(j)==15)write(11,*) j, cc((i-1)*nbf+j-1) ! 14 150 | if(f_info(j)==16)write(11,*) j, cc((i-1)*nbf+j-1) ! 15 151 | if(f_info(j)==17)write(11,*) j, cc((i-1)*nbf+j+1) ! 18 152 | if(f_info(j)==18)write(11,*) j, cc((i-1)*nbf+j+1) ! 19 153 | if(f_info(j)==19)write(11,*) j, cc((i-1)*nbf+j-2) ! 17 154 | 155 | else 156 | write(11,*) j, cc((i-1)*nbf+j) 157 | endif 158 | enddo 159 | enddo 160 | write(11,*) 161 | close(11) 162 | 163 | 164 | 21 format(a,2i7,3f16.8) 165 | 22 format(i7,3x,a) 166 | 23 format(a,3x,i7,3x,a) 167 | 24 format(2f16.8) 168 | 25 format(3f16.8) 169 | 170 | 171 | end 172 | -------------------------------------------------------------------------------- /meson.build: -------------------------------------------------------------------------------- 1 | # This file is part of std2. 2 | # 3 | # Copyright (C) 2019 Sebastian Ehlert 4 | # Copyright (C) 2024 Marc de Wergifosse 5 | 6 | # Modified by P. Beaujean 7 | 8 | project('std2', 'fortran', 9 | version: '1.6.1', 10 | meson_version: '>=0.51', 11 | default_options : ['warning_level=0', 'fortran_std=legacy'], 12 | ) 13 | 14 | if get_option('interface') == '64' and (get_option('la_backend') == 'netlib' or get_option('la_backend') == 'openblas') 15 | error('64 bit integer interface not supported by OpenBLAS/netlib backends, use -Dinterface=32') 16 | endif 17 | 18 | # set compiler options 19 | fc = meson.get_compiler('fortran') 20 | 21 | build_args = [ 22 | '-DPROJECT_NAME="' + meson.project_name() + '"', 23 | '-DPROJECT_VERSION="' + meson.project_version() + '"', 24 | ] 25 | 26 | if fc.has_argument('-march=native') 27 | build_args += ['-march=native', '-fno-math-errno'] 28 | if fc.get_id() == 'intel' 29 | build_args += ['-unroll-aggressive', '-ipo'] 30 | else 31 | build_args += ['-funroll-loops', '-ftree-vectorize'] 32 | endif 33 | message('added -march=native and loop unroling flags') 34 | endif 35 | 36 | # configure project_dep 37 | project_dep = [] 38 | libcint_options = ['with_fortran=true', 'with_cint2_interface=true'] 39 | 40 | la_backend = get_option('la_backend') 41 | if la_backend == 'mkl' 42 | # build a pkg-config compatible string, list all possibilities with `pkg-config --list-all | grep "mkl"` 43 | mkl_kind = 'mkl' 44 | if get_option('static') 45 | mkl_kind += '-static' 46 | build_args += '-static' 47 | else 48 | mkl_kind += '-dynamic' 49 | endif 50 | 51 | if get_option('interface') == '64' 52 | mkl_kind += '-ilp64' 53 | # specific requirements for ilp64 libraries, see https://www.intel.com/content/www/us/en/docs/onemkl/developer-guide-windows/2023-0/using-the-ilp64-interface-vs-lp64-interface.html 54 | build_args += '-DMKL_ILP64' 55 | libcint_options += 'i8=true' 56 | if fc.get_id() == 'intel' or fc.get_id() == 'intel-llvm' 57 | build_args += '-i8' 58 | else 59 | build_args += '-fdefault-integer-8' 60 | endif 61 | else 62 | mkl_kind += '-lp64' 63 | endif 64 | 65 | if get_option('openmp') 66 | mkl_kind += '-iomp' 67 | else 68 | mkl_kind += '-seq' 69 | endif 70 | 71 | message('MKL kind: ' + mkl_kind) 72 | 73 | # backups for system that do not provide pkg-config 74 | mkl_libraries = { 75 | 'mkl-dynamic-ilp64-iomp': ['mkl_core', 'mkl_intel_ilp64', 'mkl_gnu_thread', 'iomp5', 'pthread', 'm', 'dl'], 76 | 'mkl-dynamic-ilp64-seq': ['mkl_core', 'mkl_intel_ilp64', 'mkl_sequential', 'm', 'dl'], 77 | 'mkl-dynamic-lp64-iomp': ['mkl_core', 'mkl_intel_lp64', 'mkl_gnu_thread', 'iomp5', 'pthread', 'm', 'dl'], 78 | 'mkl-dynamic-lp64-seq': ['mkl_core', 'mkl_intel_lp64', 'mkl_sequential', 'm', 'dl'] 79 | # ... some of them are missing at the moment 80 | } 81 | 82 | mkl_dep = dependency(mkl_kind, required: false) 83 | if mkl_dep.found() # pkg-config 84 | project_dep += mkl_dep 85 | else # back up to finding libraries one per one 86 | foreach lib: mkl_libraries[mkl_kind] 87 | project_dep += fc.find_library(lib) 88 | endforeach 89 | endif 90 | elif la_backend == 'openblas' 91 | project_dep += fc.find_library('openblas', required : true) 92 | project_dep += fc.find_library('lapack', required : true) 93 | elif la_backend == 'netlib' 94 | project_dep += fc.find_library('blas', required : true) 95 | project_dep += fc.find_library('lapack', required : true) 96 | elif la_backend == 'custom' 97 | foreach lib: get_option('custom_libraries') 98 | project_dep += fc.find_library(lib) 99 | endforeach 100 | endif 101 | 102 | # add openMP if requested but MKL (and thus intel-openMP) was not used 103 | if la_backend != 'mkl' and get_option('openmp') 104 | dep_openmp = dependency('openmp', required: false) 105 | if dep_openmp.found() 106 | project_dep += dep_openmp 107 | else 108 | if fc.get_id() == 'intel' or fc.get_id() == 'intel-llvm' 109 | build_args += '-qopenmp' 110 | else 111 | build_args += '-fopenmp' 112 | endif 113 | endif 114 | endif 115 | 116 | libcint_dep = fc.find_library('libcint', required: false) 117 | if not libcint_dep.found() 118 | libcint_proj = subproject('libcint', default_options: libcint_options) 119 | libcint_dep = libcint_proj.get_variable('libcint_dep') 120 | endif 121 | project_dep += libcint_dep 122 | 123 | message('Build args are: ' + ', '.join(build_args)) 124 | 125 | # Sources 126 | std2_srcs = [ 127 | '2PA.f90', 128 | 'apbtrafo.f', 129 | 'block.f', 130 | 'full.f', 131 | 'header.f', 132 | 'intpack.f90', 133 | 'intslvm.f', 134 | 'io.f', 135 | 'libcint.f', 136 | 'linal.f', 137 | 'linear_response.f', 138 | 'main.f', 139 | 'molden.f', 140 | 'normalize.f', 141 | 'onetri.f', 142 | 'pckao.f', 143 | 'print_nto.f', 144 | 'printvec.f', 145 | 'prmat.f', 146 | 'readbasa.f', 147 | 'readbasmold.f', 148 | 'readl.f', 149 | 'readxtb.f', 150 | 'sfstda.f', 151 | 'sosor.f', 152 | 'srpapack.f', 153 | 'stda.f', 154 | 'stdacommon.f90', 155 | 'stda-rw.f', 156 | 'stda-rw_dual.f', 157 | 'stringmod.f90', 158 | 'sutda.f', 159 | 'velo.f', 160 | 'xstd.f90', 161 | ] 162 | 163 | g_spec_srcs = [ 164 | 'g_spec/g_spec.f' 165 | ] 166 | 167 | g2molden_srcs = [ 168 | 'g2molden/main.f', 169 | 'g2molden/stringmod.f90' 170 | ] 171 | 172 | # Executables 173 | std2_exe = executable( 174 | meson.project_name(), 175 | std2_srcs, 176 | dependencies: project_dep, 177 | fortran_args : build_args, 178 | link_language : 'fortran', 179 | install: true 180 | ) 181 | 182 | g2molden_exe = executable( 183 | 'g2molden', 184 | g2molden_srcs, 185 | dependencies: project_dep, 186 | fortran_args : build_args, 187 | link_language : 'fortran', 188 | install: true 189 | ) 190 | 191 | g_spec_exe = executable( 192 | 'g_spec', g_spec_srcs, 193 | dependencies: project_dep, 194 | fortran_args : build_args, 195 | link_language : 'fortran', 196 | install: true 197 | ) 198 | 199 | # add test 200 | test('valid input', std2_exe, args: ['-f', '../tests/water_sto3g.molden', '-sty', '3', '-ax', '1', '-e', '20'], suite: 'app') 201 | -------------------------------------------------------------------------------- /velo.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | SUBROUTINE SETETA(J,MNL) 20 | use stdacommon 21 | IMPLICIT REAL*8(A-H,O-Z) 22 | 23 | common /carte/ lmn(0:3,0:3,0:3) 24 | dimension mnl(3) 25 | 26 | ity=lmn(mnl(1),mnl(2),mnl(3)) 27 | eta(j,5)=float(ity) 28 | do k=6,25 29 | eta(j,k)=0.0d0 30 | enddo 31 | eta(j,5+ity)=1.00d0 32 | return 33 | end 34 | 35 | 36 | CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 37 | c 38 | c velocity dipole integrals (antisymmetric i.e. =-) 39 | c =-2*alp2* 40 | c + l2* 41 | c and so on ... 42 | c 43 | c s.grimme, dec. 1995 44 | c 45 | CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 46 | 47 | SUBROUTINE VELO(I,J,D) 48 | use stdacommon 49 | use intpack 50 | IMPLICIT REAL*8(A-H,O-Z) 51 | 52 | common /carte/ lmn(0:3,0:3,0:3) 53 | 54 | dimension v(3),point(3),nml(3),d(*) 55 | 56 | point=0 57 | ity=ipty(j) 58 | if(ity.gt.10.or.ipty(i).gt.10) then 59 | d(1:3)=0 60 | return 61 | endif 62 | 63 | do l=0,2 64 | do m=0,2 65 | do n=0,2 66 | if(ity.eq.lmn(l,m,n)) then 67 | nml(1)=l 68 | nml(2)=m 69 | nml(3)=n 70 | goto 100 71 | endif 72 | enddo 73 | enddo 74 | enddo 75 | 76 | 100 alp=exip(j) 77 | if(ity.gt.10) goto 99 78 | 79 | 80 | C first term dipole 81 | 82 | c point(1)=co(ipat(j),1) 83 | c point(2)=co(ipat(j),2) 84 | c point(3)=co(ipat(j),3) 85 | c call propa(opab1,i,j,v,point,3,dummy) 86 | c do k=1,3 87 | c d(k)=2.0*alp*v(k) 88 | c enddo 89 | 90 | c do 2 k=1,3 91 | c if(nml(k).eq.0) goto 2 92 | c nml(k)=nml(k)-1 93 | c call seteta(j,nml) 94 | c call propa(opad1,i,j,v,point,1,dummy) 95 | c nml(k)=nml(k)+1 96 | c call seteta(j,nml) 97 | c d(k)=d(k)+nml(k)*v(1) 98 | c 2 continue 99 | c write(*,*)'typ j',ity,nml 100 | c write(*,'(''di in velo'',3f20.12)') d(1),d(2),d(3) 101 | 102 | C all terms overlap 103 | 104 | do k=1,3 105 | nml(k)=nml(k)+1 106 | call seteta(j,nml) 107 | !call propa(opad1,i,j,v,point,1,dummy) 108 | call propa(opad1,point,v,1,i,j) 109 | nml(k)=nml(k)-1 110 | call seteta(j,nml) 111 | d(k)=-2.0*alp*v(1) 112 | enddo 113 | 114 | do 3 k=1,3 115 | if(nml(k).eq.0) goto 3 116 | nml(k)=nml(k)-1 117 | call seteta(j,nml) 118 | !call propa(opad1,i,j,v,point,1,dummy) 119 | call propa(opad1,point,v,1,i,j) 120 | nml(k)=nml(k)+1 121 | call seteta(j,nml) 122 | d(k)=d(k)+nml(k)*v(1) 123 | 3 continue 124 | 125 | return 126 | 127 | 99 continue 128 | c write(*,*) 'no f-functions for velocity integrals' 129 | return 130 | end 131 | 132 | CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 133 | C s.grimme, april 1998 134 | C checked against OPAM from chandra 135 | CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 136 | 137 | SUBROUTINE LXYZ(I,J,D) 138 | use stdacommon 139 | use intpack 140 | IMPLICIT REAL*8(A-H,O-Z) 141 | 142 | common /carte/ lmn(0:3,0:3,0:3) 143 | 144 | dimension v(3),point(3),nml(3),d(*) 145 | 146 | ity=ipty(j) 147 | do l=0,2 148 | do m=0,2 149 | do n=0,2 150 | if(ity.eq.lmn(l,m,n)) then 151 | nml(1)=l 152 | nml(2)=m 153 | nml(3)=n 154 | goto 100 155 | endif 156 | enddo 157 | enddo 158 | enddo 159 | 160 | 100 alp=exip(j) 161 | if(ity.gt.10) goto 99 162 | 163 | C all terms overlap 164 | 165 | do k=1,3 166 | 167 | vz1=0 168 | vz3=0 169 | 170 | if(k.eq.3) then 171 | ii=1 172 | jj=2 173 | endif 174 | 175 | if(k.eq.2) then 176 | ii=1 177 | jj=3 178 | endif 179 | 180 | if(k.eq.1) then 181 | ii=2 182 | jj=3 183 | endif 184 | 185 | if(nml(jj).gt.0) then 186 | nml(jj)=nml(jj)-1 187 | call seteta(j,nml) 188 | !call propa(opab1,i,j,v,point,3,dummy) 189 | call propa(opab1,point,v,3,i,j) 190 | nml(jj)=nml(jj)+1 191 | call seteta(j,nml) 192 | vz1=nml(jj)*v(ii) 193 | endif 194 | 195 | nml(jj)=nml(jj)+1 196 | call seteta(j,nml) 197 | !call propa(opab1,i,j,v,point,3,dummy) 198 | call propa(opab1,point,v,3,i,j) 199 | nml(jj)=nml(jj)-1 200 | call seteta(j,nml) 201 | vz2=2.*alp*v(ii) 202 | 203 | if(nml(ii).gt.0) then 204 | nml(ii)=nml(ii)-1 205 | call seteta(j,nml) 206 | !call propa(opab1,i,j,v,point,3,dummy) 207 | call propa(opab1,point,v,3,i,j) 208 | nml(ii)=nml(ii)+1 209 | call seteta(j,nml) 210 | vz3=nml(ii)*v(jj) 211 | endif 212 | 213 | nml(ii)=nml(ii)+1 214 | call seteta(j,nml) 215 | !call propa(opab1,i,j,v,point,3,dummy) 216 | call propa(opab1,point,v,3,i,j) 217 | nml(ii)=nml(ii)-1 218 | call seteta(j,nml) 219 | vz4=2.*alp*v(jj) 220 | 221 | d(k)=vz1-vz2-vz3+vz4 222 | 223 | enddo 224 | 225 | return 226 | 227 | 99 write(*,*) 'no f-functions for lxyz integrals' 228 | stop 229 | end 230 | -------------------------------------------------------------------------------- /readxtb.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | ccccccccccccccccccccccccccccccccc 20 | ! read out xTB input c 21 | ccccccccccccccccccccccccccccccccc 22 | ! ncent : # atoms 23 | ! nmo : # MOs 24 | ! nbf : # AOs 25 | ! nprims : # primitives (in total) 26 | ! co(ncent,1:3) : Cartesian coordinates 27 | ! co(ncent,4) : nuclear charge 28 | ! cxip(nprims) : contraction coefficients of primitives 29 | ! exip(nprims) : exponents of primitives 30 | ! cmo(nbf,nmo) : LCAO-MO coefficients 31 | ! eps(nmo) : orbital eigenvalues 32 | ! occ(nmo) : occupation # of MO 33 | ! ipty(nprims) : angular momentum of primitive function 34 | ! ipao(nbf) : # primitives in contracted AO 35 | ! ipat(ncent) : # of atom, the primitive is located on 36 | 37 | 38 | subroutine readxtb0(imethod,ncent,nmo,nbf,nprims) 39 | implicit double precision (a-h,o-z) 40 | 41 | integer, intent( out ) :: imethod,ncent,nmo,nbf,nprims 42 | ! temporary variables 43 | integer ii,i,j,k,maxlen 44 | logical ex 45 | 46 | write(*,*) 47 | write(*,*)'reading: wfn.xtb' 48 | call header('M O / A O I N P U T ',0) 49 | inquire(file='wfn.xtb',exist=ex) 50 | if(.not.ex)then 51 | write(*,*)'file: wfn.xtb not found' 52 | stop 'input file not found' 53 | endif 54 | 55 | iwfn=29 56 | open(unit=iwfn,file='wfn.xtb',form='unformatted', 57 | . status='old') 58 | rewind(iwfn) 59 | 60 | cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 61 | ! read rhf/uhf flag c 62 | cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 63 | read(iwfn)imethod 64 | ! read dimensions 65 | read(iwfn)ncent,nbf,nmo,nprims 66 | close(29) 67 | 68 | ! determine length of ncent integer (for fitting printout with next routine to prevent ***) 69 | maxlen=0 70 | call lenint(ncent,maxlen) 71 | write(*,'(a)',advance='no')'atom ' 72 | do i=1,maxlen-1 73 | write(*,'(a)',advance='no')' ' 74 | enddo 75 | 76 | write(*,'(''#'',10x,''x'',13x,''y'', 77 | . 13x,''z'',12x,''charge'')') 78 | 79 | return 80 | end 81 | 82 | 83 | subroutine readxtb(imethod,ncent,nmo,nbf,nprims,cc) 84 | use stdacommon 85 | implicit double precision (a-h,o-z) 86 | 87 | integer, intent( in ) :: imethod,ncent,nmo,nbf,nprims 88 | real*8, intent ( out ) :: cc(imethod*nbf*nmo) 89 | ! temporary variables 90 | integer ii,i,j,k,maxlen 91 | real*8 dum 92 | character*79 prntfrmt 93 | ! determine length of ncent integer (for printout to prevent ***) 94 | maxlen=0 95 | call lenint(ncent,maxlen) 96 | prntfrmt=' ' 97 | write(prntfrmt,'(a,i0,a)')'(2x,a2,x,i',maxlen, 98 | . ',2x,3f14.8,3x,f10.2)' 99 | 100 | iwfn=29 101 | open(unit=iwfn,file='wfn.xtb',form='unformatted', 102 | . status='old') 103 | rewind(iwfn) 104 | 105 | cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 106 | ! read rhf/uhf flag c 107 | cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 108 | read(iwfn)ii 109 | ! read dimensions 110 | read(iwfn)ii,i,j,k 111 | ! now read coordinates 112 | do i = 1,ncent 113 | read(iwfn) atnam(i) 114 | enddo 115 | do i = 1,ncent 116 | do j=1,3 117 | read(iwfn) dum 118 | co(i,j)=dum 119 | enddo 120 | read(iwfn) k 121 | co(i,4)=dble(k) 122 | if(co(i,4).lt.1.0d0) atnam(i)='xx' 123 | enddo 124 | ************************* 125 | * print out coordinates * 126 | ************************* 127 | do i=1,ncent 128 | write(*,prntfrmt) atnam(i),i,co(i,1),co(i,2),co(i,3),co(i,4) 129 | enddo 130 | !303 format(2x,a2,i3,2x,3f14.8,3x,f10.2) 131 | 132 | ************************** 133 | ! Now read basis set data 134 | ************************** 135 | ! ipty 136 | do i=1,nprims 137 | read(iwfn) k 138 | ipty(i)=k 139 | enddo 140 | ! ipat 141 | do i=1,nprims 142 | read(iwfn) k 143 | ipat(i) = k 144 | enddo 145 | ! ipao 146 | do i=1,nprims 147 | read(iwfn) k 148 | ipao(i) = k 149 | enddo 150 | 151 | ! first exponents, then contraction coefficients 152 | read(iwfn) exip(1:nprims) 153 | read(iwfn) cxip(1:nprims) 154 | ********************* 155 | ! now the mo data * 156 | ********************* 157 | k=0 158 | if(imethod.eq.2) then 159 | !uks case: nmo = nmo_a + nmo_b 160 | ! alpha first, beta second 161 | ! occs + energies 162 | k=nmo/2 163 | read(iwfn) occ(1:k) 164 | read(iwfn) eps(1:k) 165 | k=k+1 166 | read(iwfn) occ(k:nmo) 167 | read(iwfn) eps(k:nmo) 168 | ! read MO coefficients 169 | i=nmo*nbf/2 170 | read(iwfn) cc(1:i) 171 | i=i+1 172 | k=nmo*nbf 173 | read(iwfn) cc(i:k) 174 | else 175 | !rks case 176 | ! occs + energies 177 | read(iwfn) occ(1:nmo) 178 | read(iwfn) eps(1:nmo) 179 | ! read MO coefficients 180 | read(iwfn) cc 181 | endif 182 | 183 | close(iwfn) 184 | 185 | write(*,95) ncent,nmo,nprims,nbf 186 | 95 format (/,1x,'# atoms =',i5,/, 187 | . 1x,'# mos =',i5,/, 188 | . 1x,'# primitive aos =',i5,/, 189 | . 1x,'# contracted aos =',i5,/) 190 | 191 | if(imethod*nbf.gt.nmo)then 192 | write(*,*) 'spherical AO basis' 193 | else 194 | write(*,*) 'cartesian AO basis' 195 | endif 196 | 197 | call etafill(nprims) 198 | 199 | return 200 | end 201 | -------------------------------------------------------------------------------- /COPYING.LESSER: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /readbasa.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | c reads the speical tm2molden binary file 20 | 21 | subroutine readbas0a(mode,ncent,nmo,nbf,nprims,wfn) 22 | use stdacommon 23 | implicit double precision (a-h,o-z) 24 | 25 | character*(*)wfn 26 | character*80 out 27 | character*128 a128 28 | character*20 a20 29 | dimension xx(10) 30 | logical ex 31 | integer i,j,maxlen 32 | 33 | write(*,*) 34 | write(*,*)'reading: ',wfn 35 | call header('M O / A O I N P U T ',0) 36 | inquire(file=wfn,exist=ex) 37 | if(.not.ex)then 38 | write(*,*)'file:',wfn,' not found' 39 | stop 40 | endif 41 | open(unit=iwfn,file=wfn,form='unformatted') 42 | read(iwfn) nmo,nbf,nprims,ncent 43 | close(iwfn) 44 | 45 | ! determine length of ncent integer (for fitting printout with next routine to prevent ***) 46 | maxlen=0 47 | call lenint(ncent,maxlen) 48 | write(*,'(a)',advance='no')'atom ' 49 | do i=1,maxlen-1 50 | write(*,'(a)',advance='no')' ' 51 | enddo 52 | 53 | write(*,'(''#'',10x,''x'',13x,''y'', 54 | . 13x,''z'',12x,''charge'')') 55 | 56 | end 57 | 58 | subroutine readbasa(mode,imethod,ncent,nmo,nbf,nprims,cc, 59 | .icdim,wfn,iaobas) 60 | use stdacommon 61 | implicit double precision (a-h,o-z) 62 | 63 | dimension cc(icdim) 64 | integer imethod 65 | 66 | character*(*) wfn 67 | character*80 out 68 | character*128 a128 69 | character*20 a20 70 | logical ex,mosgen 71 | dimension xx(10) 72 | character*79 prntfrmt 73 | integer maxlen 74 | 75 | iaobas=0 76 | 77 | ! determine length of ncent integer (for printout to prevent ***) 78 | maxlen=0 79 | call lenint(ncent,maxlen) 80 | prntfrmt=' ' 81 | write(prntfrmt,'(a,i0,a)')'(2x,a2,x,i',maxlen, 82 | . ',2x,3f14.8,3x,f10.2)' 83 | 84 | iwfn=42 85 | open(unit=iwfn,file=wfn,form='unformatted') 86 | read(iwfn) nmo,nbf,nprims,ncent 87 | if(imethod.eq.2) nmo = 2*nmo 88 | do 100 i = 1,ncent 89 | read (iwfn) atnam(i),co(i,1),co(i,2),co(i,3),co(i,4) 90 | if(co(i,4).lt.1.0d0) atnam(i)='xx' 91 | write(*,prntfrmt) atnam(i),i,co(i,1),co(i,2),co(i,3),co(i,4) 92 | 100 continue 93 | read(iwfn) (ipat(i),i=1,nprims) 94 | c ipat - primitive to atom 95 | read(iwfn) (ipty(i),i=1,nprims) 96 | c ipty - angular momemtum type of primitive 97 | read(iwfn) (ipao(i),i=1,nprims) 98 | c ipao - primitive to contracted 99 | read(iwfn) (exip(i),i=1,nprims) 100 | c exip - exponents of primitives 101 | read(iwfn) (cxip(i),i=1,nprims) 102 | 103 | ! for debugging purposes 104 | ! do i=1,nprims 105 | ! write(*,*) i,ipty(i) 106 | ! write(*,*) exip(i),cxip(i) 107 | ! write(*,*)k,jprimao,jprimtyp,cxip(k),cxip(k)**2 108 | ! enddo 109 | 110 | do i=1,nmo 111 | read(iwfn) occ(i),eps(i) 112 | ! write(*,*) occ(i),eps(i) 113 | enddo 114 | do i=1,nmo 115 | read(iwfn) (cc(j+(i-1)*nbf),j=1,nbf) 116 | enddo 117 | ! do i=1,nmo 118 | ! write(*,*) (cc(j+(i-1)*nbf),j=1,nbf) 119 | ! enddo 120 | read(iwfn) tote,gamma 121 | close(iwfn) 122 | 123 | iaobas=idint(gamma) 124 | 125 | write(*,95)ncent,nmo,nprims,nbf 126 | 95 format (/,1x,'# atoms =',i5,/, 127 | . 1x,'# mos =',i5,/, 128 | . 1x,'# primitive aos =',i5,/, 129 | . 1x,'# contracted aos =',i5,/) 130 | 131 | if(iaobas.eq.0)then 132 | write(*,*) 'spherical AO basis' 133 | spherical=.true. 134 | else 135 | write(*,*) 'cartesian AO basis' 136 | spherical=.false. 137 | endif 138 | 139 | call etafill(nprims) 140 | 141 | !203 format(2x,a2,i3,2x,3f14.8,3x,f10.2) 142 | 143 | end 144 | 145 | subroutine readbasb(mode,imethod,ncent,nmo,nbf,nprims,cc,ccspin, 146 | .icdim,wfn,iaobas) 147 | use stdacommon 148 | implicit double precision (a-h,o-z) 149 | 150 | dimension cc(icdim) 151 | integer ccspin(nmo) 152 | integer imethod 153 | 154 | character*(*) wfn 155 | character*80 out 156 | character*128 a128 157 | character*20 a20 158 | logical ex,mosgen 159 | dimension xx(10) 160 | character*100 line 161 | integer iostatus 162 | character*5 spin,sym 163 | character*79 prntfrmt 164 | integer maxlen 165 | 166 | ! determine length of ncent integer (for printout to prevent ***) 167 | maxlen=0 168 | call lenint(ncent,maxlen) 169 | prntfrmt=' ' 170 | write(prntfrmt,'(a,i0,a)')'(2x,a2,x,i',maxlen, 171 | . ',2x,3f14.8,3x,f10.2)' 172 | 173 | 174 | iaobas=0 175 | 176 | iwfn=42 177 | open(unit=iwfn,file=wfn,form='unformatted') 178 | read(iwfn) nmo,nbf,nprims,ncent 179 | if(imethod.eq.2) nmo = 2*nmo 180 | do 100 i = 1,ncent 181 | read (iwfn) atnam(i),co(i,1),co(i,2),co(i,3),co(i,4) 182 | if(co(i,4).lt.1.0d0) atnam(i)='xx' 183 | write(*,prntfrmt) atnam(i),i,co(i,1),co(i,2),co(i,3),co(i,4) 184 | 100 continue 185 | read(iwfn) (ipat(i),i=1,nprims) 186 | c ipat - primitive to atom 187 | read(iwfn) (ipty(i),i=1,nprims) 188 | c ipty - angular momemtum type of primitive 189 | read(iwfn) (ipao(i),i=1,nprims) 190 | c ipao - primitive to contracted 191 | read(iwfn) (exip(i),i=1,nprims) 192 | c exip - exponents of primitives 193 | read(iwfn) (cxip(i),i=1,nprims) 194 | 195 | do i=1,nmo 196 | read(iwfn) occ(i),eps(i) 197 | enddo 198 | do i=1,nmo 199 | read(iwfn) (cc(j+(i-1)*nbf),j=1,nbf) 200 | enddo 201 | read(iwfn) tote,gamma 202 | close(iwfn) 203 | 204 | if(imethod.eq.2) then 205 | 206 | write(*,'(/,A,/)') 'Reading orbitals data from molden.input file ' 207 | 208 | open(unit=iwfn,file='molden.input',status='OLD') 209 | do 210 | read(iwfn,'(A)',IOSTAT=iostatus) line 211 | if(line.eq.'[MO]'.or.iostatus.lt.0) exit 212 | enddo 213 | do i = 1, nmo 214 | read(iwfn,*) line, sym 215 | read(iwfn,*) line, eps(i) 216 | read(iwfn,*) line, spin 217 | if(spin.eq.'Alpha') then 218 | ccspin(i) = 1 219 | else 220 | ccspin(i) = 2 221 | endif 222 | read(iwfn,*) line, occ(i) 223 | do j = 1, nbf 224 | read(iwfn,*) ibf, ccmolden 225 | enddo 226 | enddo 227 | close(iwfn) 228 | 229 | ! call header('Orbitals',0) 230 | ! write(*,'(/,A,/)') ' Occupancy, Energy (eV), Orbital Spin' 231 | ! do i = 1, nmo 232 | ! write(*,'(F8.2,F12.4,I4)') occ(i),eps(i)*27.21139,ccspin(i) 233 | ! enddo 234 | 235 | endif 236 | 237 | iaobas=idint(gamma) 238 | 239 | write(*,95) ncent,nmo,nprims,nbf 240 | 95 format (/,1x,'# atoms =',i5,/, 241 | . 1x,'# mos =',i5,/, 242 | . 1x,'# primitive aos =',i5,/, 243 | . 1x,'# contracted aos =',i5,/) 244 | 245 | if(iaobas.eq.0)then 246 | write(*,*) 'spherical AO basis' 247 | spherical=.true. 248 | else 249 | write(*,*) 'cartesian AO basis' 250 | spherical=.false. 251 | endif 252 | 253 | call etafill(nprims) 254 | 255 | !203 format(2x,a2,i3,2x,3f14.8,3x,f10.2) 256 | 257 | end 258 | -------------------------------------------------------------------------------- /normalize.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | ccccccccccccccccccccccccccccccccccc 20 | ! optional: Normalization of AOs c 21 | ccccccccccccccccccccccccccccccccccc 22 | ! This normalizes the contraction coefficients for each contraction 23 | subroutine normalize(cartbas,nprims,ipao,ipty,exip,cxip) 24 | implicit none 25 | logical, intent ( in ) :: cartbas 26 | integer, intent ( in ) :: ipao(nprims),ipty(nprims) 27 | integer, intent ( in ) :: nprims 28 | real*8, intent( in ) :: exip(nprims) 29 | real*8, intent( inout ) :: cxip(nprims) 30 | integer i,j,k,l,iprimao,iprimtyp,jprimao,jprimtyp 31 | integer ifac,lang,lx,my,nz 32 | real*8 fnorm,summe,dzaehl,dnenn,expon,xlinf 33 | 34 | open(unit=11,file='fnorm') 35 | write(*,'(A)',advance='no') 'normalizing...' 36 | j=1 37 | do i=1,nprims+1 38 | if(i.le.nprims) then 39 | iprimao=ipao(i) 40 | iprimtyp=ipty(i) 41 | endif 42 | if(i.gt.1)then 43 | if(i.eq.nprims+1) iprimao=0 44 | if(iprimao.ne.jprimao) then 45 | call deflmna(jprimtyp,lx,my,nz,lang,xlinf) 46 | ! we override xlinf here, if a Cartesian basis is present (i.e. selv overlap is 1.0) 47 | if(cartbas) xlinf=1.0d0 48 | fnorm=3.14159265358979323846**1.50d0 49 | fnorm=fnorm/dble(2**lang) 50 | ifac=0 51 | call dblfac(lx,ifac) 52 | fnorm=fnorm*dble(ifac) 53 | call dblfac(my,ifac) 54 | fnorm=fnorm*dble(ifac) 55 | call dblfac(nz,ifac) 56 | fnorm=fnorm*dble(ifac) 57 | fnorm=dsqrt(fnorm) 58 | summe=0.0d0 59 | do k=j,i-1 60 | do l=j,i-1 61 | dzaehl=cxip(k)*cxip(l) 62 | dnenn=exip(k)+exip(l) 63 | expon=dble(lang)+1.50d0 64 | dnenn=dnenn**expon 65 | summe=summe+dzaehl/dnenn 66 | enddo 67 | enddo 68 | summe=dsqrt(summe) 69 | fnorm=fnorm*summe 70 | fnorm=xlinf/fnorm 71 | do k=j,i-1 72 | ! write(*,*) k,ipty(k) 73 | ! write(*,*) exip(k),cxip(k),fnorm*cxip(k) 74 | cxip(k)=fnorm*cxip(k) 75 | write(11,*)fnorm 76 | ! write(*,*)k,jprimao,jprimtyp,cxip(k),cxip(k)**2 77 | enddo 78 | j=i 79 | endif 80 | endif 81 | jprimao=iprimao 82 | jprimtyp=iprimtyp 83 | enddo 84 | close(11) 85 | !!!!!!!!!!!!!!!!!!!!!!! 86 | !! check normalization 87 | ! j=1 88 | ! do i=1,nprims+1 89 | ! iprimao=ipao(i) 90 | ! iprimtyp=ipty(i) 91 | ! if(i.gt.1)then 92 | ! if(i.eq.nprims+1) iprimao=0 93 | ! if(iprimao.ne.jprimao) then 94 | ! call deflmna(jprimtyp,lx,my,nz,lang,xlinf) 95 | ! fnorm=3.14159265358979323846**1.50d0 96 | ! fnorm=fnorm/dble(2**lang) 97 | ! ifac=0 98 | ! call dblfac(lx,ifac) 99 | ! fnorm=fnorm*ifac 100 | ! call dblfac(my,ifac) 101 | ! fnorm=fnorm*ifac 102 | ! call dblfac(nz,ifac) 103 | ! fnorm=fnorm*ifac 104 | ! summe=0.0d0 105 | ! do k=j,i-1 106 | ! do l=j,i-1 107 | ! dzaehl=cxip(k)*cxip(l) 108 | ! dnenn=exip(k)+exip(l) 109 | ! expon=dble(lang)+1.50d0 110 | ! dnenn=dnenn**expon 111 | ! summe=summe+dzaehl/dnenn 112 | ! enddo 113 | ! enddo 114 | ! summe=fnorm*summe 115 | ! write(*,*) 'self ovlp:', summe 116 | ! j=i 117 | ! endif 118 | ! endif 119 | ! jprimao=iprimao 120 | ! jprimtyp=iprimtyp 121 | ! enddo 122 | !!! 123 | end subroutine normalize 124 | 125 | 126 | subroutine deflmna(iprtyp,lx,my,nz,lang,xlinf) 127 | implicit none 128 | integer lx,my,nz,lang,iprtyp 129 | real*8 xlinf 130 | xlinf=1.0d0 131 | lx=0 132 | my=0 133 | nz=0 134 | lang=0 135 | c======================================================================= 136 | c cartesian gaussian functions (6d,10f...) 137 | c s,px, py pz, dx**2 dy**2 dz**2 dxy dxz dyz 138 | c 1 2 3 4 5 6 7 8 9 10 139 | c fxxx, fyyy, fzzz, fxxy, fxxz, fyyx, fyyz, fxzz, fyzz, fxyz 140 | c 11 12 13 14 15 16 17 18 19 20 141 | c 142 | c assign for each ipty, the angular momentum (L), and the expinents l,m,n of x,y,z 143 | c linf is the factor to multiply normalized functions that are linearly dependent (e.g. dx**2,dy**2,dz**2) 144 | c======================================================================= 145 | select case(iprtyp) 146 | case(1) 147 | lx=0 148 | my=0 149 | nz=0 150 | lang=0 151 | xlinf=1.0d0 152 | case(2) 153 | lx=1 154 | my=0 155 | nz=0 156 | lang=1 157 | xlinf=1.0d0 158 | case(3) 159 | lx=0 160 | my=1 161 | nz=0 162 | lang=1 163 | xlinf=1.0d0 164 | case(4) 165 | lx=0 166 | my=0 167 | nz=1 168 | lang=1 169 | xlinf=1.0d0 170 | case(5) 171 | lx=2 172 | my=0 173 | nz=0 174 | lang=2 175 | xlinf=dsqrt(3.0d0) 176 | case(6) 177 | lx=0 178 | my=2 179 | nz=0 180 | lang=2 181 | xlinf=dsqrt(3.0d0) 182 | case(7) 183 | lx=0 184 | my=0 185 | nz=2 186 | lang=2 187 | xlinf=dsqrt(3.0d0) 188 | case(8) 189 | lx=1 190 | my=1 191 | nz=0 192 | lang=2 193 | xlinf=dsqrt(3.0d0) 194 | c xlinf=1.0d0 195 | case(9) 196 | lx=1 197 | my=0 198 | nz=1 199 | lang=2 200 | xlinf=dsqrt(3.0d0) 201 | c xlinf=1.0d0 202 | case(10) 203 | lx=0 204 | my=1 205 | nz=1 206 | lang=2 207 | xlinf=dsqrt(3.0d0) 208 | c xlinf=1.0d0 209 | case(11) 210 | lx=3 211 | my=0 212 | nz=0 213 | lang=3 214 | xlinf=dsqrt(15.0d0) 215 | case(12) 216 | lx=0 217 | my=3 218 | nz=0 219 | lang=3 220 | xlinf=dsqrt(15.0d0) 221 | case(13) 222 | lx=0 223 | my=0 224 | nz=3 225 | lang=3 226 | xlinf=dsqrt(15.0d0) 227 | case(14) 228 | lx=2 229 | my=1 230 | nz=0 231 | lang=3 232 | ! xlinf=dsqrt(3.0d0) 233 | xlinf=dsqrt(15.0d0) 234 | case(15) 235 | lx=2 236 | my=0 237 | nz=1 238 | lang=3 239 | ! xlinf=dsqrt(3.0d0) 240 | xlinf=dsqrt(15.0d0) 241 | case(16) 242 | lx=1 243 | my=2 244 | nz=0 245 | lang=3 246 | ! xlinf=dsqrt(3.0d0) 247 | xlinf=dsqrt(15.0d0) 248 | case(17) 249 | lx=0 250 | my=2 251 | nz=1 252 | lang=3 253 | ! xlinf=dsqrt(3.0d0) 254 | xlinf=dsqrt(15.0d0) 255 | case(18) 256 | lx=1 257 | my=0 258 | nz=2 259 | lang=3 260 | ! xlinf=dsqrt(3.0d0) 261 | xlinf=dsqrt(15.0d0) 262 | case(19) 263 | lx=0 264 | my=1 265 | nz=2 266 | lang=3 267 | ! xlinf=dsqrt(3.0d0) 268 | xlinf=dsqrt(15.0d0) 269 | case(20) 270 | lx=1 271 | my=1 272 | nz=1 273 | lang=3 274 | ! xlinf=1.0d0 275 | xlinf=dsqrt(15.0d0) 276 | case default 277 | write(*,*)'unrecognized cartesian function/ang. momentum' 278 | write(0,*)'unrecognized cartesian function/ang. momentum' 279 | stop 'normalization impossible! Exiting...' 280 | end select 281 | ! for checking - is the factor important?? 282 | ! xlinf=1.0d0 283 | return 284 | end 285 | 286 | subroutine dblfac(iin,iout) 287 | implicit none 288 | integer i,iin,iout,jdem,jnum,jfac 289 | cccccccccccccccccccccccccccccccccccccccccccccc 290 | c 291 | c this calculates the double faculty (2n-1)!! 292 | c i.e. expression in brackets is always odd 293 | c 294 | cccccccccccccccccccccccccccccccccccccccccccccc 295 | jdem=1 296 | do i=1,iin 297 | jdem=jdem*i 298 | enddo 299 | jnum=jdem 300 | do i=iin+1,2*iin 301 | jdem=jdem*i 302 | enddo 303 | jfac=2**iin 304 | jnum=jnum*jfac 305 | iout=jdem/jnum 306 | return 307 | end 308 | -------------------------------------------------------------------------------- /intslvm.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 20 | 21 | subroutine intslvm(ncent,nmo,nbf,nprims) 22 | use stdacommon 23 | use intpack 24 | implicit real*8(a-h,o-z) 25 | 26 | real*8, allocatable ::r0(:) 27 | real*8, allocatable ::r1(:) 28 | real*8, allocatable ::r2(:) 29 | real*8, allocatable ::r3(:) 30 | real*8, allocatable ::r4(:) 31 | real*8, allocatable ::r5(:) 32 | real*8, allocatable ::r6(:) 33 | real*8, allocatable ::r7(:) 34 | real*8, allocatable ::r8(:) 35 | real*8, allocatable ::r9(:) 36 | integer*8 memneed,mp,nrecordlen,k,i1,lin8 37 | common/ prptyp / mprp 38 | common /cema / cen(3),xmolw 39 | common /amass / ams(107) 40 | 41 | dimension v(3),point(3) 42 | 43 | call header('A O I N T E G R A L S',0) 44 | 45 | c overlap based neglect prim prefactor threshold 46 | thr=1.d-7 47 | 48 | c center of nuclear charge and molar mass 49 | sumwx=0.d0 50 | sumwy=0.d0 51 | sumwz=0.d0 52 | sumw=0.0d0 53 | xmolw=0.0d0 54 | do 10 i=1,ncent 55 | atmass=co(i,4) 56 | sumw=sumw+atmass 57 | sumwx=sumwx+atmass*co(i,1) 58 | sumwy=sumwy+atmass*co(i,2) 59 | sumwz=sumwz+atmass*co(i,3) 60 | xmolw=xmolw+ams(idint(atmass)) 61 | 10 continue 62 | cen(1)=sumwx/sumw 63 | cen(2)=sumwy/sumw 64 | cen(3)=sumwz/sumw 65 | 66 | if(nbf.eq.0) then 67 | do i=1,nprims 68 | iaoat(i)=ipat(i) 69 | enddo 70 | nao=nprims 71 | else 72 | do i=1,nprims 73 | ii=ipat(i) 74 | iaoat(ipao(i))=ii 75 | enddo 76 | nao=nbf 77 | endif 78 | 79 | mp=nao 80 | mp=mp*(mp+1)/2 81 | 82 | memneed=10*8*mp 83 | call byteout('AO int data',memneed) 84 | allocate(r1(mp),r2(mp),r3(mp), 85 | . r4(mp),r5(mp),r6(mp), 86 | . r7(mp),r8(mp),r9(mp),r0(mp), 87 | . stat=ierr) 88 | if(ierr.ne.0)stop 'allocation failed in intslvm for AOs' 89 | 90 | open(unit=40,file='sint', form='unformatted',status='replace') 91 | open(unit=31,file='xlint',form='unformatted',status='replace') 92 | open(unit=32,file='ylint',form='unformatted',status='replace') 93 | open(unit=33,file='zlint',form='unformatted',status='replace') 94 | open(unit=34,file='xmint',form='unformatted',status='replace') 95 | open(unit=35,file='ymint',form='unformatted',status='replace') 96 | open(unit=36,file='zmint',form='unformatted',status='replace') 97 | open(unit=37,file='xvint',form='unformatted',status='replace') 98 | open(unit=38,file='yvint',form='unformatted',status='replace') 99 | open(unit=39,file='zvint',form='unformatted',status='replace') 100 | 101 | 102 | ccccccccccccccccccccccccccccccccccccccccccccccccccc 103 | c 104 | c overlap and dipole 105 | c 106 | ccccccccccccccccccccccccccccccccccccccccccccccccccc 107 | 108 | point=0.0d0 109 | 110 | r0=0.0d0 111 | r1=0.0d0 112 | r2=0.0d0 113 | r3=0.0d0 114 | r4=0.0d0 115 | r5=0.0d0 116 | r6=0.0d0 117 | r7=0.0d0 118 | r8=0.0d0 119 | r9=0.0d0 120 | 121 | do i=1,nprims 122 | iai=ipao(i) 123 | c1=cxip(i) 124 | do j=1,i-1 125 | iaj=ipao(j) 126 | iaa=max(iaj,iai) 127 | iii=min(iaj,iai) 128 | ij=iii+iaa*(iaa-1)/2 129 | cf=c1*cxip(j)*2.0d0 130 | c prefactor 131 | call propa0(opad1,point,v,1,i,j,s) 132 | if(s.gt.thr)then 133 | mprp=0 134 | c S 135 | call propa1(opad1,point,v,1,i,j,s) 136 | r0(ij)=r0(ij)+v(1)*cf 137 | c R 138 | call propa1(opab1,point,v,3,i,j,s) 139 | r1(ij)=r1(ij)+v(1)*cf 140 | r2(ij)=r2(ij)+v(2)*cf 141 | r3(ij)=r3(ij)+v(3)*cf 142 | C L 143 | mprp=16 144 | call propa1(opam,point,v,3,i,j,s) 145 | ! note that s is changed by propa1 in this very case 146 | r4(ij)=r4(ij)+v(1)*cf 147 | r5(ij)=r5(ij)+v(2)*cf 148 | r6(ij)=r6(ij)+v(3)*cf 149 | C V 150 | mprp=0 151 | call velo(i,j,v) 152 | r7(ij)=r7(ij)-v(1)*cf 153 | r8(ij)=r8(ij)-v(2)*cf 154 | r9(ij)=r9(ij)-v(3)*cf 155 | endif 156 | enddo 157 | mprp=0 158 | call propa0(opad1,point,v,1,i,i,s) 159 | 160 | call propa1(opad1,point,v,1,i,i,s) 161 | ij=iai+iai*(iai-1)/2 162 | cf=c1*c1 163 | r0(ij)=r0(ij)+v(1)*cf 164 | call propa1(opab1,point,v,3,i,i,s) 165 | r1(ij)=r1(ij)+v(1)*cf 166 | r2(ij)=r2(ij)+v(2)*cf 167 | r3(ij)=r3(ij)+v(3)*cf 168 | enddo 169 | 170 | ij=0 171 | do i=1,nao 172 | do j=1,i-1 173 | ij=lin8(i,j) 174 | r0(ij)=r0(ij)*0.50d0 175 | r1(ij)=r1(ij)*0.50d0 176 | r2(ij)=r2(ij)*0.50d0 177 | r3(ij)=r3(ij)*0.50d0 178 | r4(ij)=r4(ij)*0.50d0 179 | r5(ij)=r5(ij)*0.50d0 180 | r6(ij)=r6(ij)*0.50d0 181 | r7(ij)=r7(ij)*0.50d0 182 | r8(ij)=r8(ij)*0.50d0 183 | r9(ij)=r9(ij)*0.50d0 184 | enddo 185 | enddo 186 | 187 | write(40)r0 188 | close(40) 189 | write(31)r1 190 | write(32)r2 191 | write(33)r3 192 | close(31) 193 | close(32) 194 | close(33) 195 | write(34)r4 196 | write(35)r5 197 | write(36)r6 198 | close(34) 199 | close(35) 200 | close(36) 201 | write(37)r7 202 | write(38)r8 203 | write(39)r9 204 | close(37) 205 | close(38) 206 | close(39) 207 | 208 | deallocate(r0,r1,r2,r3,r4,r5,r6,r7,r8,r9) 209 | 210 | write(*,*) 'done.' 211 | end 212 | !******************************************************************************* 213 | subroutine intslvm2(ncent,nmo,nbf,nprims) 214 | use stdacommon 215 | use commonlogicals 216 | use intpack 217 | implicit real*8(a-h,o-z) 218 | real*8, allocatable ::r4(:) 219 | real*8, allocatable ::r5(:) 220 | real*8, allocatable ::r6(:) 221 | integer*8 memneed,mp,nrecordlen,k,i1,lin8 222 | common/ prptyp / mprp 223 | common /cema / cen(3),xmolw 224 | common /amass / ams(107) 225 | 226 | dimension v(6),point(3) 227 | 228 | call header('A O I N T E G R A L S',0) 229 | 230 | c overlap based neglect prim prefactor threshold 231 | thr=1.d-7 232 | 233 | c center of nuclear charge and molar mass 234 | sumwx=0.d0 235 | sumwy=0.d0 236 | sumwz=0.d0 237 | sumw=0.0d0 238 | xmolw=0.0d0 239 | do 10 i=1,ncent 240 | atmass=co(i,4) 241 | sumw=sumw+atmass 242 | sumwx=sumwx+atmass*co(i,1) 243 | sumwy=sumwy+atmass*co(i,2) 244 | sumwz=sumwz+atmass*co(i,3) 245 | xmolw=xmolw+ams(idint(atmass)) 246 | 10 continue 247 | cen(1)=sumwx/sumw 248 | cen(2)=sumwy/sumw 249 | cen(3)=sumwz/sumw 250 | 251 | if(nbf.eq.0) then 252 | do i=1,nprims 253 | iaoat(i)=ipat(i) 254 | enddo 255 | nao=nprims 256 | else 257 | do i=1,nprims 258 | ii=ipat(i) 259 | iaoat(ipao(i))=ii 260 | enddo 261 | nao=nbf 262 | endif 263 | 264 | mp=nao 265 | mp=mp*(mp+1)/2 266 | 267 | memneed=3*8*mp 268 | if(multipole.eqv..true.)then 269 | memneed=memneed+6*8*mp 270 | endif 271 | call byteout('AO int data',memneed) 272 | 273 | allocate(r4(mp),r5(mp),r6(mp),stat=ierr) 274 | if(ierr.ne.0)stop 'allocation failed in intslvm for AOs' 275 | open(unit=34,file='xmint',form='unformatted',status='replace') 276 | open(unit=35,file='ymint',form='unformatted',status='replace') 277 | open(unit=36,file='zmint',form='unformatted',status='replace') 278 | 279 | ccccccccccccccccccccccccccccccccccccccccccccccccccc 280 | c 281 | c overlap and dipole 282 | c 283 | ccccccccccccccccccccccccccccccccccccccccccccccccccc 284 | 285 | point=0.0d0 286 | r4=0.0d0 287 | r5=0.0d0 288 | r6=0.0d0 289 | 290 | do i=1,nprims 291 | iai=ipao(i) 292 | c1=cxip(i) 293 | do j=1,i-1 294 | iaj=ipao(j) 295 | iaa=max(iaj,iai) 296 | iii=min(iaj,iai) 297 | ij=iii+iaa*(iaa-1)/2 298 | cf=c1*cxip(j)*2.0d0 299 | c prefactor 300 | call propa0(opad1,point,v,1,i,j,s) 301 | if(s.gt.thr)then 302 | C L 303 | mprp=16 304 | call propa1(opam,point,v,3,i,j,s) 305 | ! note that s is changed by propa1 in this very case 306 | r4(ij)=r4(ij)+v(1)*cf 307 | r5(ij)=r5(ij)+v(2)*cf 308 | r6(ij)=r6(ij)+v(3)*cf 309 | endif 310 | enddo 311 | mprp=0 312 | enddo 313 | 314 | ij=0 315 | do i=1,nao 316 | do j=1,i-1 317 | ij=lin8(i,j) 318 | r4(ij)=r4(ij)*0.50d0 319 | r5(ij)=r5(ij)*0.50d0 320 | r6(ij)=r6(ij)*0.50d0 321 | enddo 322 | enddo 323 | 324 | write(34)r4 325 | write(35)r5 326 | write(36)r6 327 | close(34) 328 | close(35) 329 | close(36) 330 | deallocate(r4,r5,r6) 331 | write(*,*) 'done.' 332 | end 333 | -------------------------------------------------------------------------------- /srpapack.f: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccc 20 | c sRPA routine c 21 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccc 22 | c amb: A - B (packed form) c 23 | c apb: A + B (packed form) c 24 | c ambsqr: (A - B)**0.5 (packed form c 25 | c omsq: omega**2 - eigenvalue belonging to Z c 26 | c xpy: X + Y, (later xpy = x) c 27 | c xmy: X - Y, (later xmy = y) c 28 | c n: number of configurations in A and B matrices c 29 | c nroots: number of roots c 30 | c ggavec : print z vector c 31 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccc 32 | subroutine srpapack(n,thr,ambsqr,apb,eci,xpy,xmy,nroots,ggavec) 33 | use commonlogicals 34 | implicit none 35 | integer ierror,n,nroots,k,i,j,ij,m,nro,lin 36 | integer lwork,liwork,il,iu,info,nfound 37 | c matrices 38 | real*4 ambsqr(n*(n+1)/2),xpy(n,nroots) 39 | real*4 apb(n*(n+1)/2),xmy(n,nroots) 40 | real*4 eci(n) 41 | real*4 summe,x,y,omsqi,vl,vu 42 | real*8 thr 43 | 44 | integer, allocatable ::iwork(:),isuppz(:) 45 | real*4, allocatable ::u(:,:),v(:,:),w(:,:) 46 | real*4, allocatable ::z(:,:) 47 | real*4, allocatable ::work(:) 48 | real*4, allocatable ::e (:) 49 | 50 | logical ggavec 51 | ! allocate(ambsqr(n*(n+1)/2), 52 | allocate(e(n),u(n,n),v(n,n),w(n,n),stat=ierror) 53 | if(ierror.ne.0) stop 'allocation error (rpasolve)' 54 | 55 | 56 | call sblow(n,ambsqr,U) ! blow up sqrt(A - B) from vector to matrix 57 | call sblow(n,apb ,V) ! blow up A + B from vector to matrix 58 | 59 | ! call prmat4(6,U ,n,n,'(A-B)^0.5') ! for debugging: print ambsqr 60 | ! call prmat4(6,V ,n,n,' A+B ') ! for debugging: print apb 61 | 62 | 63 | c form product: w = (a+b)*(a-b)^0.5 64 | write(*,*) ' calculating (A+B)*(A-B)^0.5 ...' 65 | call ssymm('l','l',n,n,1.e0,V,n,U,n,0.e0,W,n) 66 | 67 | ! call prmat4(6,W,n,n,'(a+b)*(a-b)^0.5') ! for debugging: print w 68 | 69 | c form product: v = (a-b)^0.5 * w 70 | 71 | call ssymm('l','l',n,n,1.e0,U,n,W,n,0.e0,V,n) 72 | 73 | ! call prmat4(6,V,n,n,'M') ! for debugging: print M matrix (V) 74 | 75 | c get rid of matrices which are not needed anymore 76 | deallocate(u,w,stat=ierror) 77 | 78 | c set variables for RPA diagonalization 79 | lwork =26*n 80 | liwork=10*n 81 | vl=0 82 | vu=thr**2.0 ! set nroot threshold to Ethr^2 83 | allocate(z(n,n),work(lwork) 84 | . ,iwork(liwork),isuppz(n),stat=ierror) 85 | if(ierror.ne.0) stop 'allocation error (rpasolve)' 86 | 87 | write(*,*)'calculate eigenvalues of (A-B)^0.5*(A+B)*(A-B)^0.5 ...' 88 | call ssyevr('V','V','U',n,v,n,vl,vu,il,iu,1.e-6, 89 | . nfound,e,z,n,isuppz, 90 | . work,lwork,iwork,liwork,info) 91 | nroots=nfound 92 | if(info.ne.0.or.nroots.lt.1) stop 'RPA diag failed' 93 | deallocate(v,work,iwork,isuppz,stat=ierror) 94 | if(ierror.ne.0) stop 'deallocation after RPA diag failed' 95 | 96 | ! testing print Z 97 | ! call prmat4(6,z,n,n,'Z') 98 | 99 | if((TPA .eqv. .false.) .and. (FULL2PA .eqv. .false.))then 100 | ij=0 101 | do i=1,n 102 | ij=ij+i 103 | ambsqr(ij)=ambsqr(ij)*0.5 104 | apb(ij)=apb(ij)*0.5 105 | enddo 106 | endif 107 | 108 | do nro=1,nroots 109 | 110 | eci(nro)=sqrt(e(nro)) 111 | 112 | c (A-B)^0.5 * Z = X+Y ! results from conversion to Hermitian eigenvalue problem 113 | do m=1,n 114 | xpy(m,nro)=0.0 115 | enddo 116 | 117 | k=0 118 | do i=1,n 119 | do j=1,i 120 | k=k+1 121 | xpy(i,nro)=xpy(i,nro)+ambsqr(k)*z(j,nro)/sqrt(eci(nro)) ! dividing by sqrt(eci) yields correct norm 122 | xpy(j,nro)=xpy(j,nro)+ambsqr(k)*z(i,nro)/sqrt(eci(nro)) 123 | enddo 124 | enddo 125 | 126 | c (A+B)*|X+Y> = e * (X-Y) ! first row of TD-DFT equation 127 | do m=1,n 128 | xmy(m,nro)=0.0 129 | enddo 130 | k=0 131 | do i=1,n 132 | do j=1,i 133 | k=k+1 134 | xmy(i,nro)=xmy(i,nro)+apb(k)*xpy(j,nro) 135 | xmy(j,nro)=xmy(j,nro)+apb(k)*xpy(i,nro) 136 | enddo 137 | enddo 138 | 139 | c write(*,'(''x+y'',10f8.4)')(xpy(i,nro),i=1,n) 140 | c write(*,'(''x-y'',10f8.4)')(xmy(i,nro),i=1,n) 141 | 142 | summe=0.0 143 | 144 | do i=1,n 145 | xmy(i,nro)=xmy(i,nro)/eci(nro) 146 | x=(xmy(i,nro)+xpy(i,nro))*0.5 147 | y=xpy(i,nro)-x 148 | xpy(i,nro)=x !xpy is now x 149 | xmy(i,nro)=y !xmy is now y 150 | ! summe=summe+xpy(i,nro)**2-xmy(i,nro)**2 151 | enddo 152 | 153 | c write(*,'(''x '',10f8.4)')(xpy(i,nro),i=1,n) 154 | c write(*,'(''y '',10f8.4)')(xmy(i,nro),i=1,n) 155 | c write(*,*) 'norm',summe 156 | c write(*,*) 'e ',eci(nro) 157 | c write(*,'(''x+y'',10f8.4)')(xpy(i,nro),i=1,n) 158 | ! norm the vectors 159 | ! summe=1.0/sqrt(summe) 160 | ! do i=1,n 161 | ! xpy(i,nro)=xpy(i,nro)*summe 162 | ! xmy(i,nro)=xmy(i,nro)*summe 163 | ! enddo 164 | 165 | c write(38)xpy 166 | c write(38)xmy 167 | 168 | enddo 169 | 170 | c close(36) 171 | write(*,*)' rpa vectors ok' 172 | 173 | ! call prmat4(6,xpy,n,nro,'X') 174 | ! call prmat4(6,xmy,n,nro,'Y') 175 | 176 | ! internal check for orthonormality 177 | ! nro=nroots 178 | ! z=0.0 179 | ! call sgemm('T','n',n,nro,n,1.d0,xpy,n,xpy,n,0.d0,z,n) 180 | ! call sgemm('T','N',n,nro,n,-1.0d0,xmy,n,xmy,n,1.0d0,z,n) 181 | ! do i=1,min(12,nro) 182 | ! write(6,'(12f10.6)') (z(j,i),j=1,min(12,nro)) 183 | ! enddo 184 | ! write(6,*) 185 | ! do i=max(1,nro-11),nro 186 | ! write(6,'(12f10.6)') (z(j,i),j=max(1,nro-11),nro) 187 | ! enddo 188 | 189 | if (ggavec) then 190 | call printvectda(ggavec,n,nroots,z,e) 191 | endif 192 | 193 | 194 | deallocate(z,stat=ierror) 195 | c deallocate(ambsqr,w5,z,stat=ierror) 196 | return 197 | end 198 | 199 | c---------------------------------------------------------------------- 200 | c subroutine to take the power of a matrix (used here for (A-B)**0.5) 201 | subroutine smatpow(n,a) 202 | use omp_lib 203 | implicit none 204 | integer n,i,ierror,m,j,k,info 205 | real*4 a(n*(n+1)/2) 206 | real*4 summe 207 | 208 | real*4, allocatable ::c(:) 209 | real*4, allocatable ::e(:) 210 | real*4, allocatable ::w(:) 211 | c working variables for sspevd diagonalization routine 212 | integer lwork,liwork,lin 213 | integer, allocatable ::iwork(:) 214 | 215 | lwork =1 + 6*n + n**2 216 | liwork=3 + 5*n 217 | allocate(iwork(liwork),stat=ierror) 218 | if(ierror.ne.0) stop 'allocation error (iwork in matpow)' 219 | 220 | c allocate(c(n*n),w(n*5),e(n),stat=ierror) 221 | allocate(c(n*n),w(lwork),e(n),stat=ierror) 222 | if(ierror.ne.0) stop 'allocation error (matpow)' 223 | 224 | 225 | c call shqrii(a,n,n,w,e,c) ! old routine - not used 226 | c call sspev('V','U',n,a,e,c,n,w,info) ! alternative LAPACK routine (not used) 227 | c used LAPACK routine using divide-and-conquer algorithm (slightly faster than sspev) 228 | call sspevd('V','U',n,a,e,c,n,w,lwork,iwork,liwork,info) 229 | if(e(1).lt.0) stop 'matrix power impossible' 230 | c take square root of diagonal elements 231 | do i=1,n 232 | e(i)=sqrt(e(i)) 233 | enddo 234 | a=0.0e0 235 | c transform back from diagonal to non-diagonal form 236 | m=0 237 | !$omp parallel private(i,j,m,k,summe) 238 | !$omp do 239 | do i=1,n 240 | do j=1,i 241 | summe=0.0 242 | m=lin(i,j) 243 | do k=1,n 244 | summe=summe+c(i+(k-1)*n)*e(k)*c(j+(k-1)*n) 245 | enddo 246 | a(m)=summe 247 | enddo 248 | enddo 249 | !$omp end do 250 | !$omp end parallel 251 | 252 | c deallocate(c,w,e,stat=ierror) 253 | deallocate(c,w,e,iwork,stat=ierror) 254 | 255 | return 256 | end 257 | 258 | subroutine sblow(n,a,b) 259 | c blow up symmetric matrix to full size 260 | implicit none 261 | real*4 a(n*(n+1)/2),b(n,n) 262 | integer ij,i,n,j,lin 263 | ij=0 264 | do i=1,n 265 | do j=1,i-1 266 | ij=ij+1 267 | b(j,i)=a(ij) 268 | b(i,j)=a(ij) 269 | enddo 270 | ij=ij+1 271 | b(i,i)=a(ij) 272 | enddo 273 | return 274 | end 275 | 276 | subroutine sblow_fast(n,a,b) 277 | c blow up symmetric matrix to full size 278 | implicit none 279 | real*4 a(n*(n+1)/2),b(n,n) 280 | integer ij,i,n,j,lin 281 | !$omp parallel private(i,j,ij) 282 | !$omp do 283 | do i=1,n 284 | do j=1,i-1 285 | ij=lin(i,j) 286 | b(j,i)=a(ij) 287 | b(i,j)=a(ij) 288 | enddo 289 | ij=lin(i,i) 290 | b(i,i)=a(ij) 291 | enddo 292 | !$omp end do 293 | !$omp end parallel 294 | return 295 | end 296 | 297 | subroutine sUnblow_fast(n,a,b) 298 | c blow up symmetric matrix to full size 299 | implicit none 300 | real*4 b(n*(n+1)/2),a(n,n) 301 | integer ij,i,n,j,lin 302 | !$omp parallel private(i,j,ij) 303 | !$omp do 304 | do i=1,n 305 | do j=1,i-1 306 | ij=lin(i,j) 307 | b(ij)=a(j,i) 308 | enddo 309 | ij=lin(i,i) 310 | b(ij)=a(i,i) 311 | enddo 312 | !$omp end do 313 | !$omp end parallel 314 | return 315 | end 316 | 317 | subroutine dblow_fast(n,a,b) 318 | c blow up symmetric matrix to full size 319 | implicit none 320 | real*8 a(n*(n+1)/2),b(n,n) 321 | integer ij,i,n,j,lin 322 | !$omp parallel private(i,j,ij) 323 | !$omp do 324 | do i=1,n 325 | do j=1,i-1 326 | ij=lin(i,j) 327 | b(j,i)=a(ij) 328 | b(i,j)=a(ij) 329 | enddo 330 | ij=lin(i,i) 331 | b(i,i)=a(ij) 332 | enddo 333 | !$omp end do 334 | !$omp end parallel 335 | return 336 | end 337 | 338 | subroutine dUnblow_fast(n,a,b) 339 | c blow up symmetric matrix to full size 340 | implicit none 341 | real*8 b(n*(n+1)/2),a(n,n) 342 | integer ij,i,n,j,lin 343 | !$omp parallel private(i,j,ij) 344 | !$omp do 345 | do i=1,n 346 | do j=1,i-1 347 | ij=lin(i,j) 348 | b(ij)=a(j,i) 349 | enddo 350 | ij=lin(i,i) 351 | b(ij)=a(i,i) 352 | enddo 353 | !$omp end do 354 | !$omp end parallel 355 | return 356 | end 357 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![std2logo_git](https://github.com/grimme-lab/std2/blob/master/std2logo_git.png) 2 | # *std2* program for computing excited states and response functions via simplified TD-DFT methods (sTDA, sTD-DFT, SF-sTD-DFT, XsTDA, XsTD-DFT, and SF-Xs-TD-DFT)[![DOI](https://zenodo.org/badge/221426808.svg)](https://doi.org/10.5281/zenodo.4022460) 3 | This project provides the `std2` program. 4 | 5 | The `std2` program is the rebranded and updated version of the `stda` program. Originally, `stda` was implemented only for the simplified time-dependent density functional theory using the Tamm-Dancoff approximation (sTDA) method. With the implementation of more simplified quantum chemistry (sQC) methods in `stda`, the name was not fitting the application of the program anymore. 6 | 7 | ## Installation 8 | 9 | Two options exist: `make` or `meson`. 10 | 11 | ### Using `make` (and the intel compiler) 12 | 13 | For that option, you need: 14 | 15 | + [`cmake`](https://cmake.org/), 16 | + the latest intel oneAPI Fortran compiler, `ifx` (**not** `ifort`), with `MKL`. 17 | 18 | Then, you need to download the library to compute one- and two-electron integrals : `libcint`: 19 | 20 | ```bash 21 | # create a `libcint` directory, then download sources in it 22 | mkdir libcint 23 | cd libcint 24 | wget https://github.com/pierre-24/libcint-meson/releases/download/v0.3.0/libcint_v6.1.2.tar.gz -O libcint.tar.gz 25 | tar -xzf libcint.tar.gz 26 | ``` 27 | 28 | The next step depends on your target. 29 | The default (32 bits integers, `LP64`) use a bit less memory but limits the size of the system you can treat. 30 | If you target large system, use the 64 bit integers (`ILP64`) instead. 31 | 32 | #### 32 bit integers (default, `LP64`) 33 | 34 | First, build `libcint`: 35 | 36 | ```bash 37 | # use intel 38 | export CC=icx 39 | 40 | # In the libcint directory, create a build directory and build `libcint` in it (using cmake) 41 | mkdir build 42 | cd build 43 | cmake .. 44 | cmake --build . 45 | ``` 46 | 47 | Then, compile `std2` itself: 48 | 49 | ```bash 50 | # go back 51 | cd ../.. 52 | 53 | # make std2 54 | make 55 | ``` 56 | 57 | #### 64 bit integers (`ILP64`) for larger calculations 58 | 59 | First, build `libcint` with the option for 64 bits integers: 60 | 61 | ```bash 62 | export CC=icx 63 | 64 | # In the libcint directory, create a build directory and build `libcint` in it (using cmake) 65 | mkdir build 66 | cd build 67 | cmake .. -DI8=true 68 | cmake --build . 69 | ``` 70 | 71 | Then, compile `std2` itself: 72 | 73 | ```bash 74 | # go back 75 | cd ../.. 76 | 77 | # make std2 (using ILP64) 78 | make USEILP64=1 79 | ``` 80 | Troubleshootings: 81 | 82 | In some cases, the path to libraries is a bit different and the Makefile should be adapted as 83 | 84 | ``` 85 | LIBS = -Wl,--start-group ${MKLROOT}/lib/intel64/libmkl_intel_ilp64.a ${MKLROOT}/lib/intel64/libmkl_intel_thread.a ${MKLROOT}/lib/intel64/libmkl_core.a -Wl,--end-group -liomp5 86 | ``` 87 | 88 | #### Run 89 | 90 | You will find a executable named `std2` in this folder. 91 | To make `std2` accessible, do: 92 | 93 | ```bash 94 | export STD2HOME=/path/to/std2/folder 95 | export LD_LIBRARY_PATH=$STD2HOME/libcint/build:$LD_LIBRARY_PATH 96 | export PATH=$PATH:$STD2HOME 97 | ``` 98 | 99 | in your `.bashrc` or submission scripts. 100 | 101 | ### Using `meson` (and any compiler) 102 | 103 | **Note that for the moment, it is not possible to use Meson to compile the 64 bit version with `ifx` (see [there](https://github.com/mesonbuild/meson/issues/13052))** 104 | 105 | If you are not found of `make`, you can use [`meson`](https://mesonbuild.com/) and [`ninja`](https://ninja-build.org/) instead. 106 | Other advantages include: automatic `libcint` import, more flexibility on the linear algebra backend and `gfortran` instead of intel. 107 | 108 | First of all, if you want to use other compilers than `gfortran`, use: 109 | 110 | ```bash 111 | # for latest version of intel compilers 112 | export FC=ifx CC=icx 113 | 114 | # for older versions of intel compilers 115 | export FC=ifort CC=icc 116 | ``` 117 | 118 | Then, pick one of the `meson setup` line below: 119 | 120 | ```bash 121 | # netlib BLAS and LAPACK, 32 bits integers 122 | meson setup _build -Dla_backend=netlib 123 | 124 | # openblas and netlib LAPACK, 32 bits integers 125 | meson setup _build -Dla_backend=openblas 126 | 127 | # MKL, 32 bits integers 128 | meson setup _build -Dla_backend=mkl 129 | 130 | # MKL, 64 bits integers (ILP64) 131 | meson setup _build -Dla_backend=mkl -Dinterface=64 132 | ``` 133 | 134 | You can also: 135 | 136 | + generate a statically linked executable by adding `-Dstatic=true` (only with MKL), or 137 | + disable OpenMP (not recommended) by adding `-Dopenmp=false`. 138 | 139 | And finally, compile everything with 140 | 141 | ```bash 142 | meson compile -C _build 143 | ``` 144 | 145 | #### Run 146 | 147 | You will an executable named `std2` in the `_build` directory. 148 | To make `std2` accessible, export 149 | 150 | ```bash 151 | export STD2HOME=/path/to/std2/folder 152 | export PATH=$PATH:$STD2HOME/_build/ 153 | ``` 154 | 155 | in your `.bashrc` or submission scripts. 156 | 157 | ## Usage 158 | 159 | For parallel usage set the threads for OMP and the MKL linear algebra backend by 160 | 161 | ```bash 162 | export OMP_NUM_THREADS= 163 | ``` 164 | 165 | For larger systems please adjust the stack size accordingly, otherwise 166 | stack overflows *will* occur. Use something along the lines of this: 167 | 168 | ```bash 169 | ulimit -s unlimited 170 | export OMP_STACKSIZE=4G 171 | ``` 172 | 173 | See the manual on the [release page](https://github.com/grimme-lab/stda/releases/latest). 174 | 175 | ## Citations 176 | 177 | - S. Grimme, A simplified Tamm–Dancoff density functional approach for the electronic excitation spectra of very large molecules, *J. Chem. Phys.*, **2013**, 138, 244104. 178 | DOI: [10.1063/1.4811331](https://doi.org/10.1063/1.4811331) 179 | 180 | - C. Bannwarth, S. Grimme, A simplified time-dependent density functional theory approach for electronic ultraviolet and circular dichroism spectra of very large molecules, *Comput. Theor. Chem.*, **2014**, 1040 – 1041, 45 – 53. 181 | DOI: [10.1016/j.comptc.2014.02.023](https://doi.org/10.1016/j.comptc.2014.02.023) 182 | 183 | - S. Grimme and C. Bannwarth, Ultra-fast computation of electronic spectra for large systems by tight-binding based simplified Tamm-Dancoff approximation (sTDA-xTB) *J. Chem. Phys.*, **2016**, 145, 054103. 184 | DOI: [10.1063/1.4959605](https://dx.doi.org/10.1063/1.4959605) 185 | 186 | - M. de Wergifosse, S. Grimme, Nonlinear-response properties in a simplified time-dependent density functional theory (sTD-DFT) framework: Evaluation of the first hyperpolarizability, *J. Chem. Phys.*, **2018**, 149 (2), 024108. 187 | DOI: [10.1063/1.5037665](https://doi.org/10.1063/1.5037665) 188 | 189 | - M. de Wergifosse, S. Grimme, Nonlinear-response properties in a simplified time-dependent density functional theory (sTD-DFT) framework: Evaluation of excited-state absorption spectra, *J. Chem. Phys.*, **2019**, 150, 094112. 190 | DOI: [10.1063/1.5080199](https://doi.org/10.1063/1.5080199) 191 | 192 | - M. de Wergifosse, C. Bannwarth, S. Grimme, A simplified spin-flip time-dependent density functional theory (SF-sTD-DFT) approach for the electronic excitation spectra of very large diradicals, *J. Phys. Chem. A*, **2019**, 123 (27), 815–5825. 193 | DOI: [10.1021/acs.jpca.9b03176](https://doi.org/10.1021/acs.jpca.9b03176) 194 | 195 | - M. de Wergifosse, J. Seibert, B. Champagne, and S. Grimme, Are fully conjugated expanded indenofluorenes analogues and diindeno[n]thiophene derivatives diradicals? A simplified (spin-flip) time-dependent density functional theory [(SF-)sTD-DFT] study, *J. Phys. Chem. A*, **2019**, 123 (45), 9828-9839. 196 | DOI: [DOI: 10.1021/acs.jpca.9b08474](https://doi.org/10.1021/acs.jpca.9b08474) 197 | 198 | - M. de Wergifosse, J. Seibert, S. Grimme, Simplified time-dependent density functional theory (sTD-DFT) for molecular optical rotation, *J. Chem. Phys.*, **2020**, 153, 084116. 199 | DOI: [10.1063/5.0020543](https://doi.org/10.1063/5.0020543) 200 | 201 | - M. de Wergifosse, S. Grimme, A unified strategy for the chemically intuitive interpretation of molecular optical response properties, *J. Chem. Theory Comput.*, **2020**, 16 (12), 7709–7720. 202 | DOI: [10.1021/acs.jctc.0c00990](https://doi.org/10.1021/acs.jctc.0c00990) 203 | 204 | - M. de Wergifosse, S. Grimme, Perspective on simplified quantum chemistry methods for excited states and response properties, *J. Phys. Chem. A*, **2021**, *J. Phys. Chem. A*, **2021**, 125 (18) 3841–3851. 205 | DOI: [10.1021/acs.jpca.1c02362](https://doi.org/10.1021/acs.jpca.1c02362) 206 | 207 | - P. Beaujean, B. Champagne, S. Grimme, and M. de Wergifosse, All-atom quantum mechanical calculation of the second-harmonic generation of fluorescent proteins, *J. Phys. Chem. Lett.*, **2021**, 12 (39), 9684-9690. 208 | DOI: [10.1021/acs.jpclett.1c02911](https://doi.org/10.1021/acs.jpclett.1c02911) 209 | 210 | - M. de Wergifosse, P. Beaujean, S. Grimme, Ultrafast evaluation of two-photon absorption with simplified time-dependent density functional theory, *J. Phys. Chem. A*, **2022**, 126 (41) 7534–7547. 211 | DOI: [10.1021/acs.jpca.2c02395](https://doi.org/10.1021/acs.jpca.2c02395) 212 | 213 | - S. Löffelsender, P. Beaujean, M. de Wergifosse. Simplified quantum chemistry methods to evaluate non-linear optical properties of large systems, *WIREs Comput Mol Sci.* **2024**, 14 (1) e1695. 214 | DOI: [10.1002/wcms.1695](https://doi.org/10.1002/wcms.1695) 215 | 216 | - M. de Wergifosse, S. Grimme, The eXact integral simplified time-dependent density functional theory (XsTD-DFT), *J. Chem. Phys.*, **2024**, 160, 204110. 217 | DOI: [10.1063/5.0206380](https://doi.org/10.1063/5.0206380) 218 | 219 | - M. de Wergifosse, Computing excited states of very large systems with range-separated hybrid functionals and the eXact integral simplified time-dependent density functional theory (XsTD-DFT), *J. Phys. Chem. Lett.*, **2024**, 15, (51) 12628–12635. 220 | DOI: [10.1021/acs.jpclett.4c03193](https://doi.org/10.1021/acs.jpclett.4c03193) 221 | 222 | - M. G. Maraldi, M. de Wergifosse, Evaluating the performance of the eXact integral simplified time-dependent density functional theory (XsTD-DFT) to compute one- and two-photon absorption, *J. Phys. Chem. A*, **2025**, 129, (35) 8178–8203. 223 | DOI: [10.1021/acs.jpca.5c03189](https://doi.org/10.1021/acs.jpca.5c03189) 224 | 225 | ## License 226 | 227 | `std2` is free software: you can redistribute it and/or modify it under 228 | the terms of the GNU Lesser General Public License as published by 229 | the Free Software Foundation, either version 3 of the License, or 230 | (at your option) any later version. 231 | 232 | `std2` is distributed in the hope that it will be useful, 233 | but without any warranty; without even the implied warranty of 234 | merchantability or fitness for a particular purpose. See the 235 | GNU Lesser General Public License for more details. 236 | 237 | ## Bugs 238 | 239 | A bug is a *demonstratable problem* caused by the code in this repository. 240 | Good bug reports are extremely valuable for us - thank you! 241 | 242 | Before opening a bug report: 243 | 244 | 1. Check if the issue has already been reported. 245 | 2. Check if it still is an issue or has already been fixed? 246 | Try to reproduce it with the latest version from the `main` branch. 247 | 3. Isolate the problem and create a reduced test case. 248 | 249 | A good bug report should not leave others needing to chase you up for more 250 | information. So please try to be as detailed as possible in your report, 251 | answer at least these questions: 252 | 253 | 1. Which version of `std2` are you using? The current version is always 254 | a subject to change, so be more specific. 255 | If possible, also provide the *commit*. 256 | 2. What is your environment (your laptop, the cluster of the university)? 257 | 3. What steps will reproduce the issue? 258 | We have to reproduce the issue, so we need all the input files. 259 | 4. What would be the expected outcome? 260 | 5. What did you see instead? 261 | 262 | All these details will help people to fix any potential bugs. 263 | -------------------------------------------------------------------------------- /g2molden/stringmod.f90: -------------------------------------------------------------------------------- 1 | module precision 2 | 3 | ! Real kinds 4 | 5 | integer, parameter :: kr4 = selected_real_kind(6,37) ! single precision real 6 | integer, parameter :: kr8 = selected_real_kind(15,307) ! double precision real 7 | 8 | ! Integer kinds 9 | 10 | integer, parameter :: ki4 = selected_int_kind(9) ! single precision integer 11 | integer, parameter :: ki8 = selected_int_kind(18) ! double precision integer 12 | 13 | !Complex kinds 14 | 15 | integer, parameter :: kc4 = kr4 ! single precision complex 16 | integer, parameter :: kc8 = kr8 ! double precision complex 17 | 18 | end module precision 19 | module strings 20 | 21 | use precision 22 | 23 | private :: value_dr,value_sr,value_di,value_si 24 | private :: write_dr,write_sr,write_di,write_si 25 | private :: writeq_dr,writeq_sr,writeq_di,writeq_si 26 | 27 | interface value ! Generic operator for converting a number string to a 28 | ! number. Calling syntax is 'call value(numstring,number,ios)' 29 | ! where 'numstring' is a number string and 'number' is a 30 | ! real number or an integer (single or double precision). 31 | module procedure value_dr 32 | module procedure value_sr 33 | module procedure value_di 34 | module procedure value_si 35 | end interface 36 | 37 | interface writenum ! Generic interface for writing a number to a string. The 38 | ! number is left justified in the string. The calling syntax 39 | ! is 'call writenum(number,string,format)' where 'number' is 40 | ! a real number or an integer, 'string' is a character string 41 | ! containing the result, and 'format' is the format desired, 42 | ! e.g., 'e15.6' or 'i5'. 43 | module procedure write_dr 44 | module procedure write_sr 45 | module procedure write_di 46 | module procedure write_si 47 | end interface 48 | 49 | interface writeq ! Generic interface equating a name to a numerical value. The 50 | ! calling syntax is 'call writeq(unit,name,value,format)' where 51 | ! unit is the integer output unit number, 'name' is the variable 52 | ! name, 'value' is the real or integer value of the variable, 53 | ! and 'format' is the format of the value. The result written to 54 | ! the output unit has the form = . 55 | module procedure writeq_dr 56 | module procedure writeq_sr 57 | module procedure writeq_di 58 | module procedure writeq_si 59 | end interface 60 | 61 | 62 | !********************************************************************** 63 | 64 | contains 65 | 66 | !********************************************************************** 67 | 68 | subroutine parse(str,delims,args,nargs) 69 | 70 | ! Parses the string 'str' into arguments args(1), ..., args(nargs) based on 71 | ! the delimiters contained in the string 'delims'. Preceding a delimiter in 72 | ! 'str' by a backslash (\) makes this particular instance not a delimiter. 73 | ! The integer output variable nargs contains the number of arguments found. 74 | 75 | character(len=*) :: str,delims 76 | character(len=len_trim(str)) :: strsav 77 | character(len=*),dimension(:) :: args 78 | 79 | strsav=str 80 | call compact(str) 81 | na=size(args) 82 | do i=1,na 83 | args(i)=' ' 84 | end do 85 | nargs=0 86 | lenstr=len_trim(str) 87 | if(lenstr==0) return 88 | k=0 89 | 90 | do 91 | if(len_trim(str) == 0) exit 92 | nargs=nargs+1 93 | call split(str,delims,args(nargs)) 94 | call removebksl(args(nargs)) 95 | end do 96 | str=strsav 97 | 98 | end subroutine parse 99 | 100 | !********************************************************************** 101 | 102 | subroutine compact(str) 103 | 104 | ! Converts multiple spaces and tabs to single spaces; deletes control characters; 105 | ! removes initial spaces. 106 | 107 | character(len=*):: str 108 | character(len=1):: ch 109 | character(len=len_trim(str)):: outstr 110 | 111 | str=adjustl(str) 112 | lenstr=len_trim(str) 113 | outstr=' ' 114 | isp=0 115 | k=0 116 | 117 | do i=1,lenstr 118 | ch=str(i:i) 119 | ich=iachar(ch) 120 | 121 | select case(ich) 122 | 123 | case(9,32) ! space or tab character 124 | if(isp==0) then 125 | k=k+1 126 | outstr(k:k)=' ' 127 | end if 128 | isp=1 129 | 130 | case(33:) ! not a space, quote, or control character 131 | k=k+1 132 | outstr(k:k)=ch 133 | isp=0 134 | 135 | end select 136 | 137 | end do 138 | 139 | str=adjustl(outstr) 140 | 141 | end subroutine compact 142 | 143 | !********************************************************************** 144 | 145 | subroutine removesp(str) 146 | 147 | ! Removes spaces, tabs, and control characters in string str 148 | 149 | character(len=*):: str 150 | character(len=1):: ch 151 | character(len=len_trim(str))::outstr 152 | 153 | str=adjustl(str) 154 | lenstr=len_trim(str) 155 | outstr=' ' 156 | k=0 157 | 158 | do i=1,lenstr 159 | ch=str(i:i) 160 | ich=iachar(ch) 161 | select case(ich) 162 | case(0:32) ! space, tab, or control character 163 | cycle 164 | case(33:) 165 | k=k+1 166 | outstr(k:k)=ch 167 | end select 168 | end do 169 | 170 | str=adjustl(outstr) 171 | 172 | end subroutine removesp 173 | 174 | !********************************************************************** 175 | 176 | subroutine value_dr(str,rnum,ios) 177 | 178 | ! Converts number string to a double precision real number 179 | 180 | character(len=*)::str 181 | real(kr8)::rnum 182 | integer :: ios 183 | 184 | ilen=len_trim(str) 185 | ipos=scan(str,'Ee') 186 | if(.not.is_digit(str(ilen:ilen)) .and. ipos/=0) then 187 | ios=3 188 | return 189 | end if 190 | read(str,*,iostat=ios) rnum 191 | 192 | end subroutine value_dr 193 | 194 | !********************************************************************** 195 | 196 | subroutine value_sr(str,rnum,ios) 197 | 198 | ! Converts number string to a single precision real number 199 | 200 | character(len=*)::str 201 | real(kr4) :: rnum 202 | real(kr8) :: rnumd 203 | 204 | call value_dr(str,rnumd,ios) 205 | if( abs(rnumd) > huge(rnum) ) then 206 | ios=15 207 | return 208 | end if 209 | if( abs(rnumd) < tiny(rnum) ) rnum=0.0_kr4 210 | rnum=rnumd 211 | 212 | end subroutine value_sr 213 | 214 | !********************************************************************** 215 | 216 | subroutine value_di(str,inum,ios) 217 | 218 | ! Converts number string to a double precision integer value 219 | 220 | character(len=*)::str 221 | integer(ki8) :: inum 222 | real(kr8) :: rnum 223 | 224 | call value_dr(str,rnum,ios) 225 | if(abs(rnum)>huge(inum)) then 226 | ios=15 227 | return 228 | end if 229 | inum=nint(rnum,ki8) 230 | 231 | end subroutine value_di 232 | 233 | !********************************************************************** 234 | 235 | subroutine value_si(str,inum,ios) 236 | 237 | ! Converts number string to a single precision integer value 238 | 239 | character(len=*)::str 240 | integer(ki4) :: inum 241 | real(kr8) :: rnum 242 | 243 | call value_dr(str,rnum,ios) 244 | if(abs(rnum)>huge(inum)) then 245 | ios=15 246 | return 247 | end if 248 | inum=nint(rnum,ki4) 249 | 250 | end subroutine value_si 251 | 252 | !********************************************************************** 253 | 254 | subroutine shiftstr(str,n) 255 | 256 | ! Shifts characters in in the string 'str' n positions (positive values 257 | ! denote a right shift and negative values denote a left shift). Characters 258 | ! that are shifted off the end are lost. Positions opened up by the shift 259 | ! are replaced by spaces. 260 | 261 | character(len=*):: str 262 | 263 | lenstr=len(str) 264 | nabs=iabs(n) 265 | if(nabs>=lenstr) then 266 | str=repeat(' ',lenstr) 267 | return 268 | end if 269 | if(n<0) str=str(nabs+1:)//repeat(' ',nabs) ! shift left 270 | if(n>0) str=repeat(' ',nabs)//str(:lenstr-nabs) ! shift right 271 | return 272 | 273 | end subroutine shiftstr 274 | 275 | !********************************************************************** 276 | 277 | subroutine insertstr(str,strins,loc) 278 | 279 | ! Inserts the string 'strins' into the string 'str' at position 'loc'. 280 | ! Characters in 'str' starting at position 'loc' are shifted right to 281 | ! make room for the inserted string. Trailing spaces of 'strins' are 282 | ! removed prior to insertion 283 | 284 | character(len=*):: str,strins 285 | character(len=len(str))::tempstr 286 | 287 | lenstrins=len_trim(strins) 288 | tempstr=str(loc:) 289 | call shiftstr(tempstr,lenstrins) 290 | tempstr(1:lenstrins)=strins(1:lenstrins) 291 | str(loc:)=tempstr 292 | return 293 | 294 | end subroutine insertstr 295 | 296 | !********************************************************************** 297 | 298 | subroutine delsubstr(str,substr) 299 | 300 | ! Deletes first occurrence of substring 'substr' from string 'str' and 301 | ! shifts characters left to fill hole. Trailing spaces or blanks are 302 | ! not considered part of 'substr'. 303 | 304 | character(len=*):: str,substr 305 | 306 | lensubstr=len_trim(substr) 307 | ipos=index(str,substr) 308 | if(ipos==0) return 309 | if(ipos == 1) then 310 | str=str(lensubstr+1:) 311 | else 312 | str=str(:ipos-1)//str(ipos+lensubstr:) 313 | end if 314 | return 315 | 316 | end subroutine delsubstr 317 | 318 | !********************************************************************** 319 | 320 | subroutine delall(str,substr) 321 | 322 | ! Deletes all occurrences of substring 'substr' from string 'str' and 323 | ! shifts characters left to fill holes. 324 | 325 | character(len=*):: str,substr 326 | 327 | lensubstr=len_trim(substr) 328 | do 329 | ipos=index(str,substr) 330 | if(ipos == 0) exit 331 | if(ipos == 1) then 332 | str=str(lensubstr+1:) 333 | else 334 | str=str(:ipos-1)//str(ipos+lensubstr:) 335 | end if 336 | end do 337 | return 338 | 339 | end subroutine delall 340 | 341 | !********************************************************************** 342 | 343 | function uppercase(str) result(ucstr) 344 | 345 | ! convert string to upper case 346 | 347 | character (len=*):: str 348 | character (len=len_trim(str)):: ucstr 349 | 350 | ilen=len_trim(str) 351 | ioffset=iachar('A')-iachar('a') 352 | iquote=0 353 | ucstr=str 354 | do i=1,ilen 355 | iav=iachar(str(i:i)) 356 | if(iquote==0 .and. (iav==34 .or.iav==39)) then 357 | iquote=1 358 | iqc=iav 359 | cycle 360 | end if 361 | if(iquote==1 .and. iav==iqc) then 362 | iquote=0 363 | cycle 364 | end if 365 | if (iquote==1) cycle 366 | if(iav >= iachar('a') .and. iav <= iachar('z')) then 367 | ucstr(i:i)=achar(iav+ioffset) 368 | else 369 | ucstr(i:i)=str(i:i) 370 | end if 371 | end do 372 | return 373 | 374 | end function uppercase 375 | 376 | !********************************************************************** 377 | 378 | function lowercase(str) result(lcstr) 379 | 380 | ! convert string to lower case 381 | 382 | character (len=*):: str 383 | character (len=len_trim(str)):: lcstr 384 | 385 | ilen=len_trim(str) 386 | ioffset=iachar('A')-iachar('a') 387 | iquote=0 388 | lcstr=str 389 | do i=1,ilen 390 | iav=iachar(str(i:i)) 391 | if(iquote==0 .and. (iav==34 .or.iav==39)) then 392 | iquote=1 393 | iqc=iav 394 | cycle 395 | end if 396 | if(iquote==1 .and. iav==iqc) then 397 | iquote=0 398 | cycle 399 | end if 400 | if (iquote==1) cycle 401 | if(iav >= iachar('A') .and. iav <= iachar('Z')) then 402 | lcstr(i:i)=achar(iav-ioffset) 403 | else 404 | lcstr(i:i)=str(i:i) 405 | end if 406 | end do 407 | return 408 | 409 | end function lowercase 410 | 411 | !********************************************************************** 412 | 413 | subroutine readline(nunitr,line,ios) 414 | 415 | ! Reads line from unit=nunitr, ignoring blank lines 416 | ! and deleting comments beginning with an exclamation point(!) 417 | 418 | character (len=*):: line 419 | 420 | do 421 | read(nunitr,'(a)', iostat=ios) line ! read input line 422 | if(ios /= 0) return 423 | line=adjustl(line) 424 | ipos=index(line,'!') 425 | if(ipos == 1) cycle 426 | if(ipos /= 0) line=line(:ipos-1) 427 | if(len_trim(line) /= 0) exit 428 | end do 429 | return 430 | 431 | end subroutine readline 432 | 433 | !********************************************************************** 434 | 435 | subroutine match(str,ipos,imatch) 436 | 437 | ! Sets imatch to the position in string of the delimiter matching the delimiter 438 | ! in position ipos. Allowable delimiters are (), [], {}, <>. 439 | 440 | character(len=*) :: str 441 | character :: delim1,delim2,ch 442 | 443 | lenstr=len_trim(str) 444 | delim1=str(ipos:ipos) 445 | select case(delim1) 446 | case('(') 447 | idelim2=iachar(delim1)+1 448 | istart=ipos+1 449 | iend=lenstr 450 | inc=1 451 | case(')') 452 | idelim2=iachar(delim1)-1 453 | istart=ipos-1 454 | iend=1 455 | inc=-1 456 | case('[','{','<') 457 | idelim2=iachar(delim1)+2 458 | istart=ipos+1 459 | iend=lenstr 460 | inc=1 461 | case(']','}','>') 462 | idelim2=iachar(delim1)-2 463 | istart=ipos-1 464 | iend=1 465 | inc=-1 466 | case default 467 | write(*,*) delim1,' is not a valid delimiter' 468 | return 469 | end select 470 | if(istart < 1 .or. istart > lenstr) then 471 | write(*,*) delim1,' has no matching delimiter' 472 | return 473 | end if 474 | delim2=achar(idelim2) ! matching delimiter 475 | 476 | isum=1 477 | do i=istart,iend,inc 478 | ch=str(i:i) 479 | if(ch /= delim1 .and. ch /= delim2) cycle 480 | if(ch == delim1) isum=isum+1 481 | if(ch == delim2) isum=isum-1 482 | if(isum == 0) exit 483 | end do 484 | if(isum /= 0) then 485 | write(*,*) delim1,' has no matching delimiter' 486 | return 487 | end if 488 | imatch=i 489 | 490 | return 491 | 492 | end subroutine match 493 | 494 | !********************************************************************** 495 | 496 | subroutine write_dr(rnum,str,fmt) 497 | 498 | ! Writes double precision real number rnum to string str using format fmt 499 | 500 | real(kr8) :: rnum 501 | character(len=*) :: str,fmt 502 | character(len=80) :: formt 503 | 504 | formt='('//trim(fmt)//')' 505 | write(str,formt) rnum 506 | str=adjustl(str) 507 | 508 | end subroutine write_dr 509 | 510 | !*********************************************************************** 511 | 512 | subroutine write_sr(rnum,str,fmt) 513 | 514 | ! Writes single precision real number rnum to string str using format fmt 515 | 516 | real(kr4) :: rnum 517 | character(len=*) :: str,fmt 518 | character(len=80) :: formt 519 | 520 | formt='('//trim(fmt)//')' 521 | write(str,formt) rnum 522 | str=adjustl(str) 523 | 524 | end subroutine write_sr 525 | 526 | !*********************************************************************** 527 | 528 | subroutine write_di(inum,str,fmt) 529 | 530 | ! Writes double precision integer inum to string str using format fmt 531 | 532 | integer(ki8) :: inum 533 | character(len=*) :: str,fmt 534 | character(len=80) :: formt 535 | 536 | formt='('//trim(fmt)//')' 537 | write(str,formt) inum 538 | str=adjustl(str) 539 | 540 | end subroutine write_di 541 | 542 | !*********************************************************************** 543 | 544 | subroutine write_si(inum,str,fmt) 545 | 546 | ! Writes single precision integer inum to string str using format fmt 547 | 548 | integer(ki4) :: inum 549 | character(len=*) :: str,fmt 550 | character(len=80) :: formt 551 | 552 | formt='('//trim(fmt)//')' 553 | write(str,formt) inum 554 | str=adjustl(str) 555 | 556 | end subroutine write_si 557 | 558 | !*********************************************************************** 559 | 560 | subroutine trimzero(str) 561 | 562 | ! Deletes nonsignificant trailing zeroes from number string str. If number 563 | ! string ends in a decimal point, one trailing zero is added. 564 | 565 | character(len=*) :: str 566 | character :: ch 567 | character(len=10) :: exp 568 | 569 | ipos=scan(str,'eE') 570 | if(ipos>0) then 571 | exp=str(ipos:) 572 | str=str(1:ipos-1) 573 | endif 574 | lstr=len_trim(str) 575 | do i=lstr,1,-1 576 | ch=str(i:i) 577 | if(ch=='0') cycle 578 | if(ch=='.') then 579 | str=str(1:i)//'0' 580 | if(ipos>0) str=trim(str)//trim(exp) 581 | exit 582 | endif 583 | str=str(1:i) 584 | exit 585 | end do 586 | if(ipos>0) str=trim(str)//trim(exp) 587 | 588 | end subroutine trimzero 589 | 590 | !********************************************************************** 591 | 592 | subroutine writeq_dr(unit,namestr,value,fmt) 593 | 594 | ! Writes a string of the form = value to unit 595 | 596 | real(kr8) :: value 597 | integer :: unit 598 | character(len=*) :: namestr,fmt 599 | character(len=32) :: tempstr 600 | 601 | call writenum(value,tempstr,fmt) 602 | call trimzero(tempstr) 603 | write(unit,*) trim(namestr)//' = '//trim(tempstr) 604 | 605 | end subroutine writeq_dr 606 | 607 | !********************************************************************** 608 | 609 | subroutine writeq_sr(unit,namestr,value,fmt) 610 | 611 | ! Writes a string of the form = value to unit 612 | 613 | real(kr4) :: value 614 | integer :: unit 615 | character(len=*) :: namestr,fmt 616 | character(len=32) :: tempstr 617 | 618 | call writenum(value,tempstr,fmt) 619 | call trimzero(tempstr) 620 | write(unit,*) trim(namestr)//' = '//trim(tempstr) 621 | 622 | end subroutine writeq_sr 623 | 624 | !********************************************************************** 625 | 626 | subroutine writeq_di(unit,namestr,ivalue,fmt) 627 | 628 | ! Writes a string of the form = ivalue to unit 629 | 630 | integer(ki8) :: ivalue 631 | integer :: unit 632 | character(len=*) :: namestr,fmt 633 | character(len=32) :: tempstr 634 | call writenum(ivalue,tempstr,fmt) 635 | call trimzero(tempstr) 636 | write(unit,*) trim(namestr)//' = '//trim(tempstr) 637 | 638 | end subroutine writeq_di 639 | 640 | !********************************************************************** 641 | 642 | subroutine writeq_si(unit,namestr,ivalue,fmt) 643 | 644 | ! Writes a string of the form = ivalue to unit 645 | 646 | integer(ki4) :: ivalue 647 | integer :: unit 648 | character(len=*) :: namestr,fmt 649 | character(len=32) :: tempstr 650 | call writenum(ivalue,tempstr,fmt) 651 | call trimzero(tempstr) 652 | write(unit,*) trim(namestr)//' = '//trim(tempstr) 653 | 654 | end subroutine writeq_si 655 | 656 | !********************************************************************** 657 | 658 | function is_letter(ch) result(res) 659 | 660 | ! Returns .true. if ch is a letter and .false. otherwise 661 | 662 | character :: ch 663 | logical :: res 664 | 665 | select case(ch) 666 | case('A':'Z','a':'z') 667 | res=.true. 668 | case default 669 | res=.false. 670 | end select 671 | return 672 | 673 | end function is_letter 674 | 675 | !********************************************************************** 676 | 677 | function is_digit(ch) result(res) 678 | 679 | ! Returns .true. if ch is a digit (0,1,...,9) and .false. otherwise 680 | 681 | character :: ch 682 | logical :: res 683 | 684 | select case(ch) 685 | case('0':'9') 686 | res=.true. 687 | case default 688 | res=.false. 689 | end select 690 | return 691 | 692 | end function is_digit 693 | 694 | !********************************************************************** 695 | 696 | subroutine split(str,delims,before,sep) 697 | 698 | ! Routine finds the first instance of a character from 'delims' in the 699 | ! the string 'str'. The characters before the found delimiter are 700 | ! output in 'before'. The characters after the found delimiter are 701 | ! output in 'str'. The optional output character 'sep' contains the 702 | ! found delimiter. A delimiter in 'str' is treated like an ordinary 703 | ! character if it is preceded by a backslash (\). If the backslash 704 | ! character is desired in 'str', then precede it with another backslash. 705 | 706 | character(len=*) :: str,delims,before 707 | character,optional :: sep 708 | logical :: pres 709 | character :: ch,cha 710 | 711 | pres=present(sep) 712 | str=adjustl(str) 713 | call compact(str) 714 | lenstr=len_trim(str) 715 | if(lenstr == 0) return ! string str is empty 716 | k=0 717 | ibsl=0 ! backslash initially inactive 718 | before=' ' 719 | do i=1,lenstr 720 | ch=str(i:i) 721 | if(ibsl == 1) then ! backslash active 722 | k=k+1 723 | before(k:k)=ch 724 | ibsl=0 725 | cycle 726 | end if 727 | if(ch == '\') then ! backslash with backslash inactive 728 | k=k+1 729 | before(k:k)=ch 730 | ibsl=1 731 | cycle 732 | end if 733 | ipos=index(delims,ch) 734 | if(ipos == 0) then ! character is not a delimiter 735 | k=k+1 736 | before(k:k)=ch 737 | cycle 738 | end if 739 | if(ch /= ' ') then ! character is a delimiter that is not a space 740 | str=str(i+1:) 741 | if(pres) sep=ch 742 | exit 743 | end if 744 | cha=str(i+1:i+1) ! character is a space delimiter 745 | iposa=index(delims,cha) 746 | if(iposa > 0) then ! next character is a delimiter 747 | str=str(i+2:) 748 | if(pres) sep=cha 749 | exit 750 | else 751 | str=str(i+1:) 752 | if(pres) sep=ch 753 | exit 754 | end if 755 | end do 756 | if(i >= lenstr) str='' 757 | str=adjustl(str) ! remove initial spaces 758 | return 759 | 760 | end subroutine split 761 | 762 | !********************************************************************** 763 | 764 | subroutine removebksl(str) 765 | 766 | ! Removes backslash (\) characters. Double backslashes (\\) are replaced 767 | ! by a single backslash. 768 | 769 | character(len=*):: str 770 | character(len=1):: ch 771 | character(len=len_trim(str))::outstr 772 | 773 | str=adjustl(str) 774 | lenstr=len_trim(str) 775 | outstr=' ' 776 | k=0 777 | ibsl=0 ! backslash initially inactive 778 | 779 | do i=1,lenstr 780 | ch=str(i:i) 781 | if(ibsl == 1) then ! backslash active 782 | k=k+1 783 | outstr(k:k)=ch 784 | ibsl=0 785 | cycle 786 | end if 787 | if(ch == '\') then ! backslash with backslash inactive 788 | ibsl=1 789 | cycle 790 | end if 791 | k=k+1 792 | outstr(k:k)=ch ! non-backslash with backslash inactive 793 | end do 794 | 795 | str=adjustl(outstr) 796 | 797 | end subroutine removebksl 798 | 799 | !********************************************************************** 800 | 801 | end module strings 802 | 803 | 804 | -------------------------------------------------------------------------------- /2PA.f90: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2025 Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | SUBROUTINE lresp_2PA_full(nci,apb,amb,iconf,maxconf,xl,yl,zl,moci,no,nv,eci,Xci,Yci,nroot,& 20 | &ncent,dax,nao,clow) 21 | use commonresp 22 | use omp_lib 23 | IMPLICIT NONE 24 | 25 | integer ::i,j,k,ii,jj,kk,ij,jk,ab,io,iv,idum1,idum2,nci 26 | integer ::io1,io2,iv1,iv2,iwrk,jwrk,nroot,ncent,nao 27 | integer ::maxconf,moci,no,nv,ino,nno,inv,nnv 28 | integer ::iconf(maxconf,2) 29 | integer, allocatable :: A_list(:,:) 30 | integer ::counter_A 31 | integer, allocatable :: B_list(:,:) 32 | integer ::counter_B 33 | integer*8 ::lin8 34 | real*8 :: dax,clow(nao*moci) 35 | 36 | real*8 ::xl(moci*(moci+1)/2) 37 | real*8 ::yl(moci*(moci+1)/2) 38 | real*8 ::zl(moci*(moci+1)/2) 39 | 40 | real*4 ::mu_x(nci) 41 | real*4 ::mu_y(nci) 42 | real*4 ::mu_z(nci) 43 | real*4 ::XpY_int(nci,3) 44 | real*4 ::XpYci(nci) 45 | 46 | real*8 ::mu(moci*(moci+1)/2,3) 47 | real*4 ::omega 48 | real*4 ::Xci(nci,nroot), Yci(nci,nroot),eci(nci) 49 | real*4 ::apb(nci*(nci+1)/2) 50 | real*4 ::amb(nci*(nci+1)/2) 51 | real*4, allocatable ::inv_amb(:) 52 | real*4, allocatable ::inv_resp(:) 53 | real*8, allocatable ::XpY(:,:) 54 | real*8, allocatable ::XmY(:,:) 55 | real*8, allocatable ::X(:,:) 56 | real*8, allocatable ::Y(:,:) 57 | character*1 ::uplo 58 | integer ::info 59 | integer, allocatable ::ipiv(:) 60 | real*4, allocatable ::work (:) 61 | 62 | integer ::ix,iy,iz 63 | real*8 ::sigma(3,3),A,B,sigma_f,sigma_g,sigma_h 64 | 65 | real*8 ::alpha_xx,alpha_xy,alpha_xz 66 | real*8 ::alpha_yy,alpha_yz 67 | real*8 ::alpha_zz 68 | 69 | 70 | real*4 ::start_time,end_time,sdot 71 | 72 | real*4,allocatable :: f_ijka(:,:),f_abic(:,:),F_ij(:,:),F_ab(:,:) 73 | 74 | open(unit=60,file='2PA-abs',status='replace') 75 | 76 | mu=0.0 77 | mu(:,1)=xl(:) 78 | mu(:,2)=yl(:) 79 | mu(:,3)=zl(:) 80 | 81 | write(*,*) 82 | write(*,*)'======================================================================' 83 | write(*,*)' Welcome in nonlinear response sTD-DFT program' 84 | write(*,*)'======================================================================' 85 | write(*,*) 86 | 87 | allocate(inv_amb(nci*(nci+1)/2)) 88 | inv_amb=amb 89 | uplo='U' 90 | allocate(ipiv(1:nci),work(1:nci)) 91 | call ssptrf(uplo,nci,inv_amb,ipiv,info) 92 | call ssptri(uplo,nci,inv_amb,ipiv,work,info) 93 | deallocate(ipiv,work) 94 | 95 | allocate( XpY(nci,3)) 96 | allocate( XmY(nci,3)) 97 | allocate( X(nci,3),Y(nci,3)) 98 | 99 | ! the dipole moment matrix mu_ai 100 | mu_x=0.0 101 | mu_y=0.0 102 | mu_z=0.0 103 | !$omp parallel private(j,io,iv,idum1,idum2,ij) 104 | !$omp do 105 | Do j=1, nci 106 | io=iconf(j,1) 107 | iv=iconf(j,2) 108 | idum1=max(io,iv) 109 | idum2=min(io,iv) 110 | ij=idum2+idum1*(idum1-1)/2 111 | mu_x(j)=-xl(ij) 112 | mu_y(j)=-yl(ij) 113 | mu_z(j)=-zl(ij) 114 | enddo 115 | !$omp end do 116 | !$omp end parallel 117 | 118 | ! Generating Hartree XC kernel 119 | 120 | ino=minval(iconf(1:nci,1)) 121 | nno=maxval(iconf(1:nci,1)) 122 | inv=minval(iconf(1:nci,2)) ! start with no+1 123 | nnv=maxval(iconf(1:nci,2)) 124 | allocate(f_ijka(ino*(ino+1)/2:nno*(nno+1)/2,nci),f_abic(inv*(inv+1)/2:nnv*(nnv+1)/2,nci)) 125 | call HXC(nci,ncent,no,nv,maxconf,iconf,dax,nao,moci,clow,f_ijka,f_abic,ino,nno,inv,nnv) 126 | 127 | allocate(F_ij(ino*(ino+1)/2:nno*(nno+1)/2,4),F_ab(inv*(inv+1)/2:nnv*(nnv+1)/2,4)) 128 | 129 | Do ii=1, num_trans 130 | 131 | XpY(:,:)=0.0 132 | XmY(:,:)=0.0 133 | X(:,:)=0.0 134 | Y(:,:)=0.0 135 | omega=-eci(ii)/2.0 136 | call cpu_time(start_time) 137 | allocate(inv_resp(nci*(nci+1)/2)) 138 | inv_resp=apb-omega**2.0*inv_amb 139 | 140 | 141 | uplo='U' 142 | XpY_int(:,1)=mu_x(:) 143 | XpY_int(:,2)=mu_y(:) 144 | XpY_int(:,3)=mu_z(:) 145 | allocate(ipiv(1:nci)) 146 | call ssptrf(uplo,nci,inv_resp,ipiv,info) 147 | call ssptrs(uplo,nci,3,inv_resp,ipiv,XpY_int,nci,info) 148 | deallocate(ipiv) 149 | 150 | XpY(:,1)=dble(XpY_int(:,1)) 151 | XpY(:,2)=dble(XpY_int(:,2)) 152 | XpY(:,3)=dble(XpY_int(:,3)) 153 | 154 | write(*,*) 155 | write(*,*)ii 156 | write(*,*) 157 | 158 | ! extract X and Y from XpY 159 | ! (X-Y)=omega*(A-B)^-1 (X+Y) 160 | ! X=((X+Y)+(X-Y))/2 161 | ! Y=(X+Y)-X 162 | !$omp parallel private(i,j,ij,ix) reduction (+:XmY) 163 | !$omp do 164 | Do i=1,nci 165 | Do j=1,nci 166 | ij=lin8(i,j) 167 | Do ix=1,3 168 | XmY(i,ix)=XmY(i,ix)+ dble(omega)*dble(inv_amb(ij))*XpY(j,ix) 169 | enddo 170 | enddo 171 | enddo 172 | !$omp end do 173 | !$omp end parallel 174 | !$omp parallel private(ix,j) reduction(+:X,Y) 175 | !$omp do 176 | Do ix=1,3 177 | Do j=1,nci 178 | X(j,ix)=(XpY(j,ix)+XmY(j,ix))/2.0 179 | Y(j,ix)=XpY(j,ix)-X(j,ix) 180 | enddo 181 | enddo 182 | !$omp end do 183 | !$omp end parallel 184 | 185 | deallocate(inv_resp) 186 | 187 | call cpu_time(end_time) 188 | print '("alpha Time = ",f12.2," minutes.")',(end_time-start_time)/60.0 189 | 190 | XpYci(:)=Xci(:,ii)+Yci(:,ii) 191 | !$omp parallel private(i,j,ix) 192 | !$omp do 193 | Do i=ino,nno 194 | Do j=ino,i 195 | Do ix=1,3 196 | F_ij(lin8(i,j),ix)=sdot(nci,f_ijka(lin8(i,j),:),1,XpY_int(:,ix),1) 197 | enddo 198 | F_ij(lin8(i,j),4)=sdot(nci,f_ijka(lin8(i,j),:),1,XpYci(:),1) 199 | enddo 200 | enddo 201 | !$omp end do 202 | !$omp end parallel 203 | !$omp parallel private(i,j,ix) 204 | !$omp do 205 | Do i=inv,nnv 206 | Do j=inv,i 207 | Do ix=1,3 208 | F_ab(lin8(i,j),ix)=sdot(nci,f_abic(lin8(i,j),:),1,XpY_int(:,ix),1) 209 | enddo 210 | F_ab(lin8(i,j),4)=sdot(nci,f_abic(lin8(i,j),:),1,XpYci(:),1) 211 | enddo 212 | enddo 213 | !$omp end do 214 | !$omp end parallel 215 | write(*,*)'F_ij and F_ab computed' 216 | 217 | if(ii==1)then 218 | ! 219 | ! Genarating a list of indexes used in A and B formula to save a great bunch of time 220 | ! 221 | call cpu_time(start_time) 222 | counter_A=0 223 | !$omp parallel private(j,i,kk) reduction(+:counter_A) 224 | !$omp do 225 | Do i=1,nci 226 | Do j=1,no 227 | Do kk=1,nci 228 | if(iconf(kk,1)==j .and. iconf(kk,2)==iconf(i,2))then 229 | counter_A=counter_A+1 230 | endif 231 | enddo 232 | enddo 233 | enddo 234 | !$omp end do 235 | !$omp end parallel 236 | allocate(A_list(1:counter_A,1:3)) 237 | A_list=-9999 238 | call List_A(maxconf,no,nci,iconf,A_list,counter_A) 239 | !Do i=1,counter_A 240 | !write(*,*)i,A_list(i,1:3) 241 | !enddo 242 | 243 | counter_B=0 244 | !$omp parallel private(j,i,kk) reduction(+:counter_B) 245 | !$omp do 246 | Do i=1,nci 247 | Do j=1,nv 248 | Do kk=1,nci 249 | if(iconf(kk,1)==iconf(i,1) .and. iconf(kk,2)==j+no)then 250 | counter_B=counter_B+1 251 | endif 252 | enddo 253 | enddo 254 | enddo 255 | !$omp end do 256 | !$omp end parallel 257 | allocate(B_list(1:counter_B,1:3)) 258 | B_list=-9999 259 | call List_B(maxconf,no,nv,nci,iconf,B_list,counter_B) 260 | !Do i=1,counter_B 261 | !write(*,*)i,B_list(i,1:3) 262 | !enddo 263 | call cpu_time(end_time) 264 | print '("A & B indexes list Time = ",f12.2," minutes.")',(end_time-start_time)/60.0 265 | endif 266 | 267 | ! sigma sigma = -A + B 268 | call cpu_time(start_time) 269 | ! 270 | ! Fast version 271 | ! 272 | sigma(:,:)=0.0 273 | Do ix=1,3 274 | Do iy=1,ix 275 | call TPA_resp_fast_full(ix,iy,X,Y,Xci,Yci,nroot,A_list,B_list,counter_A,counter_B,mu,& 276 | &maxconf,no,nv,nci,moci,ii,iconf,A,B,ino,nno,inv,nnv,F_ij,F_ab) 277 | sigma(ix,iy)=(-A+B)/2.0d0 278 | if(ix/=iy)then 279 | sigma(iy,ix)=sigma(ix,iy) 280 | endif 281 | enddo 282 | enddo 283 | 284 | sigma_f=0.0 285 | sigma_g=0.0 286 | sigma_h=0.0 287 | Do ix=1,3 288 | Do iy=1,3 289 | sigma_f=sigma_f+sigma(ix,ix)*sigma(iy,iy) 290 | sigma_g=sigma_g+sigma(ix,iy)*sigma(ix,iy) 291 | sigma_h=sigma_h+sigma(ix,iy)*sigma(iy,ix) 292 | enddo 293 | enddo 294 | sigma_f=sigma_f/30.0 295 | sigma_g=sigma_g/30.0 296 | sigma_h=sigma_h/30.0 297 | 298 | 299 | 300 | call cpu_time(end_time) 301 | print '("2PA Time = ",f12.2," minutes.")',(end_time-start_time)/60.0 302 | write(*,*) 303 | write(*,3333)'Delta (',eci(ii)*27.21139,')' 304 | write(*,*) 305 | write(*,1111)'x','y','z' 306 | write(*,2222)'x',sigma(1,1),sigma(1,2),sigma(1,3) 307 | write(*,2222)'y',sigma(2,1),sigma(2,2),sigma(2,3) 308 | write(*,2222)'z',sigma(3,1),sigma(3,2),sigma(3,3) 309 | write(*,*) 310 | write(*,5555)'F =',sigma_f,' G =',sigma_G,' H =',sigma_H 311 | write(*,4444)'Delta_2PA_// =',2.0*sigma_f+2.0*sigma_g+2.0*sigma_h 312 | write(*,4444)'Delta_2PA__|_ =',-1.0*sigma_f+4.0*sigma_g-1.0*sigma_h 313 | write(*,4444)'Delta_2PA_circ =',-2.0*sigma_f+3.0*sigma_g+3.0*sigma_h 314 | write(*,4444)'rho = //*(_|_)**-1 =',(2.0*sigma_f+2.0*sigma_g+2.0*sigma_h)/& 315 | &(-1.0*sigma_f+4.0*sigma_g-1.0*sigma_h) 316 | write(60,6666)ii,eci(ii)*27.21139,2.0*sigma_f+2.0*sigma_g+2.0*sigma_h,& 317 | &-1.0*sigma_f+4.0*sigma_g-1.0*sigma_h,-2.0*sigma_f& 318 | &+3.0*sigma_g+3.0*sigma_h,(2.0*sigma_f+2.0*sigma_g& 319 | &+2.0*sigma_h)/(-1.0*sigma_f+4.0*sigma_g-1.0*sigma_h) 320 | enddo 321 | close(60) 322 | deallocate(XpY) 323 | deallocate(XmY) 324 | deallocate(X,Y) 325 | deallocate(inv_amb) 326 | write(*,*) 327 | write(*,*)'======================================================================' 328 | write(*,*)' end of nonlinear response sTD-DFT program' 329 | write(*,*)'======================================================================' 330 | write(*,*) 331 | 111 format(A15,F20.6) 332 | 1111 format(A22,2A20) 333 | 2222 format(A2,3F20.6) 334 | 3334 format(A16,F7.3,A1,F7.3,A1) 335 | 3333 format(A16,F7.3,A1) 336 | 4444 format(A20,F20.3) 337 | 5555 format(A3,F20.3,A4,F20.3,A4,F20.3) 338 | 6666 format(I3,F7.3,4F20.3) 339 | end subroutine lresp_2PA_full 340 | 341 | 342 | 343 | 344 | 345 | subroutine HXC(nci,ncent,no,nv,mxcnf,iconf,dax,nao,moci,clow,f_ijka,f_abic,ino,nno,inv,nnv) ! (AA|BB) only 346 | use commonlogicals 347 | use stdacommon 348 | use commonlibcint 349 | use omp_lib 350 | implicit none 351 | integer, intent(in) :: nci,ncent,no,nv,mxcnf,iconf(mxcnf,2) 352 | real*8, intent(in) :: dax 353 | real*4, intent(out) :: f_ijka(ino*(ino+1)/2:nno*(nno+1)/2,nci),f_abic(inv*(inv+1)/2:nnv*(nnv+1)/2,nci) 354 | integer i,j,ij,io,iv,ko,kv,ierr,lin,iiv,jjv,iwrk,jwrk,iwrk2,k,l,a,b,m,n,o,p,aa,bb,ia,jb 355 | real*4 ek,ej,sdot,ax 356 | 357 | real*8 :: wtime 358 | real*4 :: start_time,end_time,start 359 | integer :: ino,nno,inv,nnv 360 | 361 | integer :: nao,moci 362 | real*8 :: clow(nao*moci) 363 | 364 | real*4,allocatable :: Q_ia(:,:,:),P_ia(:,:,:),Q_ij(:,:),Q_ab(:,:),AABB_integral(:,:) 365 | 366 | real*4 :: value1,value2,value3,rabx 367 | Write(*,*)'Compute f_HXC once' 368 | write(*,*)'using on_site AO integrals' 369 | 370 | ! Read AO integrals data 371 | 372 | allocate(AABB_integral(nao,nao)) 373 | call two_elec_int(ncent,nao,nao,AABB_integral,1,nbas,1,nbas) 374 | 375 | 376 | write(*,*)'AO integrals computed' 377 | 378 | call cpu_time(start_time) 379 | 380 | ! reduce the mo range to match the configuration space 381 | write(*,*)'Q transition charges computed for occ.',ino,'to',nno 382 | write(*,*)'and for unocc.',inv,'to',nnv 383 | 384 | 385 | allocate(Q_ia(ino:nno,inv:nnv,nao)) 386 | 387 | !$omp parallel private(i,j) 388 | !$omp do 389 | Do i=ino, nno 390 | Do j=inv,nnv 391 | Do k=1,nao 392 | Q_ia(i,j,k)=clow(k+(i-1)*nao)*clow(k+(j-1)*nao) 393 | enddo 394 | enddo 395 | enddo 396 | !$omp end do 397 | !$omp end parallel 398 | 399 | allocate(P_ia(ino:nno,inv:nnv,nao)) 400 | 401 | !$omp parallel private(i,j) 402 | !$omp do 403 | Do i=ino, nno 404 | Do j=inv,nnv 405 | 406 | call sgemv('T',nao,nao,1.0,AABB_integral,nao,Q_ia(i,j,:),1,0.0,P_ia(i,j,:),1) 407 | 408 | enddo 409 | enddo 410 | !$omp end do 411 | !$omp end parallel 412 | 413 | allocate(Q_ij(ino*(ino+1)/2:nno*(nno+1)/2,nao),Q_ab(inv*(inv+1)/2:nnv*(nnv+1)/2,nao)) 414 | 415 | !$omp parallel private(i,k) 416 | !$omp do 417 | Do i=ino, nno 418 | Do k=ino, i 419 | Do j=1, nao 420 | Q_ij(lin(i,k),j)=clow(j+(i-1)*nao)*clow(j+(k-1)*nao) 421 | enddo 422 | enddo 423 | enddo 424 | !$omp end do 425 | !$omp end parallel 426 | 427 | !$omp parallel private(j,l) 428 | !$omp do 429 | Do j=inv,nnv 430 | Do l=inv, j 431 | Do i=1,nao 432 | Q_ab(lin(j,l),i)=clow(i+(j-1)*nao)*clow(i+(l-1)*nao) 433 | enddo 434 | enddo 435 | enddo 436 | !$omp end do 437 | !$omp end parallel 438 | 439 | 440 | deallocate(AABB_integral) 441 | 442 | 443 | write(*,*)"Intemediates computed" 444 | call cpu_time(end_time) 445 | print '("time = ",f12.2," minutes.")',(end_time-start_time)/60.0 446 | 447 | 448 | ax=real(dax) 449 | ! calculate f_ijka and f_abic 450 | f_ijka=0.0e0 451 | f_abic=0.0e0 452 | !$omp parallel private(i,j,k,ko,kv,ek,ej) 453 | !$omp do 454 | Do i=ino,nno 455 | Do j=ino,i 456 | Do k=1,nci 457 | ko=iconf(k,1) 458 | kv=iconf(k,2) 459 | ej=sdot(nao,Q_ij(lin(i,j),:),1,P_ia(ko,kv,:),1) 460 | ek=-ax*sdot(nao,Q_ij(lin(i,ko),:),1,P_ia(j,kv,:),1) 461 | f_ijka(lin(i,j),k)=ej+ek 462 | enddo 463 | enddo 464 | enddo 465 | !$omp end do 466 | !$omp end parallel 467 | 468 | !$omp parallel private(i,j,k,ko,kv,ek,ej) 469 | !$omp do 470 | Do i=inv,nnv 471 | Do j=inv,i 472 | Do k=1,nci 473 | ko=iconf(k,1) 474 | kv=iconf(k,2) 475 | ej=sdot(nao,Q_ab(lin(i,j),:),1,P_ia(ko,kv,:),1) 476 | ek=-ax*sdot(nao,Q_ab(lin(j,kv),:),1,P_ia(ko,i,:),1) 477 | f_abic(lin(i,j),k)=ej+ek 478 | enddo 479 | enddo 480 | enddo 481 | !$omp end do 482 | !$omp end parallel 483 | 484 | deallocate(P_ia,Q_ia,Q_ij,Q_ab) 485 | write(*,*)'f_HXC computed' 486 | 487 | return 488 | 489 | end subroutine HXC 490 | 491 | SUBROUTINE TPA_resp_fast_full(ix,iy,X,Y,Xci,Yci,nroot,A_list,B_list,counter_A,counter_B,mu,maxconf,no,nv,nci,moci,ii,& 492 | &iconf,A,B,ino,nno,inv,nnv,F_ij,F_ab) 493 | use commonresp 494 | use omp_lib 495 | implicit none 496 | 497 | integer ::xx,yy,nroot 498 | integer ::ix,iy,no,nv,nci,ii,maxconf,moci 499 | integer ::iconf(maxconf,2) 500 | real*8 ::mu(moci*(moci+1)/2,3) 501 | real*8 ::X(nci,3) 502 | real*8 ::Y(nci,3) 503 | real*4 ::Xci(nci,nroot), Yci(nci,nroot) 504 | real*8 ::A,B 505 | real*8 ::A1,A2,A3,A4,A5,A6 506 | real*8 ::B1,B2,B3,B4,B5,B6 507 | integer ::counter_A,counter_B 508 | integer :: A_list(1:counter_A,1:3) 509 | integer :: B_list(1:counter_B,1:3) 510 | 511 | integer :: ino,nno,inv,nnv 512 | real*4 :: F_ij(ino*(ino+1)/2:nno*(nno+1)/2,4),F_ab(inv*(inv+1)/2:nnv*(nnv+1)/2,4) 513 | 514 | A=0.0d0 515 | B=0.0d0 516 | A1=0.0d0 517 | A2=0.0d0 518 | A3=0.0d0 519 | A4=0.0d0 520 | A5=0.0d0 521 | A6=0.0d0 522 | B1=0.0d0 523 | B2=0.0d0 524 | B3=0.0d0 525 | B4=0.0d0 526 | B5=0.0d0 527 | B6=0.0d0 528 | 529 | ! A1 ix iy n 530 | xx=ix 531 | yy=iy 532 | call A_2PA_1_fast_full(xx,yy,X,Y,Xci,Yci,nroot,A_list,counter_A,mu,nci,moci,ii,A1,F_ij,ino,nno,iconf,maxconf) 533 | ! A2 iy ix n 534 | xx=iy 535 | yy=ix 536 | call A_2PA_1_fast_full(xx,yy,X,Y,Xci,Yci,nroot,A_list,counter_A,mu,nci,moci,ii,A2,F_ij,ino,nno,iconf,maxconf) 537 | ! A3 n ix iy 538 | xx=ix 539 | yy=iy 540 | call A_2PA_2_fast_full(xx,yy,X,Y,Xci,Yci,nroot,A_list,counter_A,mu,nci,moci,ii,A3,F_ij,ino,nno,iconf,maxconf) 541 | ! A4 n iy ix 542 | xx=iy 543 | yy=ix 544 | call A_2PA_2_fast_full(xx,yy,X,Y,Xci,Yci,nroot,A_list,counter_A,mu,nci,moci,ii,A4,F_ij,ino,nno,iconf,maxconf) 545 | ! A5 ix n iy 546 | xx=ix 547 | yy=iy 548 | call A_2PA_3_fast_full(xx,yy,X,Y,Xci,Yci,nroot,A_list,counter_A,mu,nci,moci,ii,A5,F_ij,ino,nno,iconf,maxconf) 549 | ! A6 iy n ix 550 | xx=iy 551 | yy=ix 552 | call A_2PA_3_fast_full(xx,yy,X,Y,Xci,Yci,nroot,A_list,counter_A,mu,nci,moci,ii,A6,F_ij,ino,nno,iconf,maxconf) 553 | A=A1+A2+A3+A4+A5+A6 554 | 555 | ! B1 ix iy n 556 | xx=ix 557 | yy=iy 558 | call B_2PA_1_fast_full(xx,yy,X,Y,Xci,Yci,nroot,B_list,counter_B,mu,nci,moci,ii,B1,F_ab,inv,nnv,iconf,maxconf) 559 | ! B2 iy ix n 560 | xx=iy 561 | yy=ix 562 | call B_2PA_1_fast_full(xx,yy,X,Y,Xci,Yci,nroot,B_list,counter_B,mu,nci,moci,ii,B2,F_ab,inv,nnv,iconf,maxconf) 563 | ! B3 n ix iy 564 | xx=ix 565 | yy=iy 566 | call B_2PA_2_fast_full(xx,yy,X,Y,Xci,Yci,nroot,B_list,counter_B,mu,nci,moci,ii,B3,F_ab,inv,nnv,iconf,maxconf) 567 | ! B4 n iy ix 568 | xx=iy 569 | yy=ix 570 | call B_2PA_2_fast_full(xx,yy,X,Y,Xci,Yci,nroot,B_list,counter_B,mu,nci,moci,ii,B4,F_ab,inv,nnv,iconf,maxconf) 571 | ! B5 ix n iy 572 | xx=ix 573 | yy=iy 574 | call B_2PA_3_fast_full(xx,yy,X,Y,Xci,Yci,nroot,B_list,counter_B,mu,nci,moci,ii,B5,F_ab,inv,nnv,iconf,maxconf) 575 | ! B6 iy n ix 576 | xx=iy 577 | yy=ix 578 | call B_2PA_3_fast_full(xx,yy,X,Y,Xci,Yci,nroot,B_list,counter_B,mu,nci,moci,ii,B6,F_ab,inv,nnv,iconf,maxconf) 579 | B=B1+B2+B3+B4+B5+B6 580 | 581 | end subroutine TPA_resp_fast_full 582 | 583 | Subroutine A_2PA_1_fast_full(ix,iy,X,Y,Xci,Yci,nroot,A_list,counter_A,mu,nci,moci,ifreq,A,F_ij,ino,nno,iconf,maxconf) 584 | use commonresp 585 | use omp_lib 586 | implicit none 587 | 588 | integer ::ix,iy,nci,ifreq,moci,ino,nno,maxconf 589 | integer ::nroot 590 | real*8 ::A 591 | real*8 ::mu(moci*(moci+1)/2,3) 592 | real*8 ::X(nci,3) 593 | real*8 ::Y(nci,3) 594 | real*4 ::Xci(nci,nroot), Yci(nci,nroot) 595 | real*4 :: F_ij(ino*(ino+1)/2:nno*(nno+1)/2,4) 596 | integer ::i,ii 597 | integer*8 :: lin8 598 | integer ::iconf(maxconf,2) 599 | integer ::counter_A 600 | integer ::A_list(1:counter_A,1:3) 601 | 602 | ii=ifreq 603 | A=0.0 604 | !$omp parallel private(i) reduction(+:A) 605 | !$omp do 606 | Do i=1,counter_A 607 | A=A+X(A_list(i,1),ix)*(-mu(A_list(i,2),iy)& 608 | &+dble(F_ij(lin8(iconf(A_list(i,1),1),iconf(A_list(i,3),1)),iy))& 609 | &)*dble(Yci(A_list(i,3),ii)) 610 | enddo 611 | !$omp end do 612 | !$omp end parallel 613 | end subroutine A_2PA_1_fast_full 614 | 615 | Subroutine A_2PA_2_fast_full(ix,iy,X,Y,Xci,Yci,nroot,A_list,counter_A,mu,nci,moci,ifreq,A,F_ij,ino,nno,iconf,maxconf) 616 | use commonresp 617 | use omp_lib 618 | implicit none 619 | 620 | integer ::ix,iy,nci,ifreq,moci,ino,nno,maxconf 621 | integer ::nroot 622 | real*8 ::A 623 | real*8 ::mu(moci*(moci+1)/2,3) 624 | real*8 ::X(nci,3) 625 | real*8 ::Y(nci,3) 626 | real*4 ::Xci(nci,nroot), Yci(nci,nroot) 627 | real*4 :: F_ij(ino*(ino+1)/2:nno*(nno+1)/2,4) 628 | integer ::i,ii 629 | integer*8 :: lin8 630 | integer ::iconf(maxconf,2) 631 | integer ::counter_A 632 | integer ::A_list(1:counter_A,1:3) 633 | 634 | ii=ifreq 635 | A=0.0 636 | !$omp parallel private(i) reduction(+:A) 637 | !$omp do 638 | Do i=1,counter_A 639 | A=A+dble(Xci(A_list(i,1),ii))*(-mu(A_list(i,2),ix)& 640 | &+dble(F_ij(lin8(iconf(A_list(i,1),1),iconf(A_list(i,3),1)),ix))& 641 | &)*Y(A_list(i,3),iy) 642 | enddo 643 | !$omp end do 644 | !$omp end parallel 645 | end subroutine A_2PA_2_fast_full 646 | 647 | Subroutine A_2PA_3_fast_full(ix,iy,X,Y,Xci,Yci,nroot,A_list,counter_A,mu,nci,moci,ifreq,A,F_ij,ino,nno,iconf,maxconf) 648 | use commonresp 649 | use omp_lib 650 | implicit none 651 | 652 | integer ::ix,iy,nci,ifreq,moci,ino,nno,maxconf 653 | integer ::nroot 654 | real*8 ::A 655 | real*8 ::mu(moci*(moci+1)/2,3) 656 | real*8 ::X(nci,3) 657 | real*8 ::Y(nci,3) 658 | real*4 ::Xci(nci,nroot), Yci(nci,nroot) 659 | real*4 :: F_ij(ino*(ino+1)/2:nno*(nno+1)/2,4) 660 | integer ::i,ii 661 | integer*8 :: lin8 662 | integer ::iconf(maxconf,2) 663 | integer ::counter_A 664 | integer ::A_list(1:counter_A,1:3) 665 | 666 | ii=ifreq 667 | A=0.0 668 | !$omp parallel private(i) reduction(+:A) 669 | !$omp do 670 | Do i=1,counter_A 671 | A=A+X(A_list(i,1),ix)*(& 672 | &dble(F_ij(lin8(iconf(A_list(i,1),1),iconf(A_list(i,3),1)),4))& 673 | &)*dble(Y(A_list(i,3),iy)) 674 | enddo 675 | !$omp end do 676 | !$omp end parallel 677 | end subroutine A_2PA_3_fast_full 678 | 679 | Subroutine B_2PA_1_fast_full(ix,iy,X,Y,Xci,Yci,nroot,B_list,counter_B,mu,nci,moci,ifreq,B,F_ab,inv,nnv,iconf,maxconf) 680 | use commonresp 681 | use omp_lib 682 | implicit none 683 | 684 | integer ::ix,iy,nci,ifreq,moci,inv,nnv,maxconf 685 | integer ::nroot 686 | real*8 ::B 687 | real*8 ::mu(moci*(moci+1)/2,3) 688 | real*8 ::X(nci,3) 689 | real*8 ::Y(nci,3) 690 | real*4 ::Xci(nci,nroot), Yci(nci,nroot) 691 | real*4 :: F_ab(inv*(inv+1)/2:nnv*(nnv+1)/2,4) 692 | integer ::i,ii 693 | integer*8 :: lin8 694 | integer ::iconf(maxconf,2) 695 | integer ::counter_B 696 | integer ::B_list(1:counter_B,1:3) 697 | 698 | ii=ifreq 699 | B=0.0 700 | !$omp parallel private(i) reduction(+:B) 701 | !$omp do 702 | Do i=1,counter_B 703 | B=B+X(B_list(i,1),ix)*(-mu(B_list(i,2),iy)& 704 | &+dble(F_ab(lin8(iconf(B_list(i,1),2),iconf(B_list(i,3),2)),iy))& 705 | &)*dble(Yci(B_list(i,3),ii)) 706 | enddo 707 | !$omp end do 708 | !$omp end parallel 709 | end subroutine B_2PA_1_fast_full 710 | 711 | Subroutine B_2PA_2_fast_full(ix,iy,X,Y,Xci,Yci,nroot,B_list,counter_B,mu,nci,moci,ifreq,B,F_ab,inv,nnv,iconf,maxconf) 712 | use commonresp 713 | use omp_lib 714 | implicit none 715 | 716 | integer ::ix,iy,nci,ifreq,moci,inv,nnv,maxconf 717 | integer ::nroot 718 | real*8 ::B 719 | real*8 ::mu(moci*(moci+1)/2,3) 720 | real*8 ::X(nci,3) 721 | real*8 ::Y(nci,3) 722 | real*4 ::Xci(nci,nroot), Yci(nci,nroot) 723 | real*4 :: F_ab(inv*(inv+1)/2:nnv*(nnv+1)/2,4) 724 | integer ::i,ii 725 | integer*8 :: lin8 726 | integer ::iconf(maxconf,2) 727 | integer ::counter_B 728 | integer ::B_list(1:counter_B,1:3) 729 | 730 | ii=ifreq 731 | B=0.0 732 | !$omp parallel private(i) reduction(+:B) 733 | !$omp do 734 | Do i=1,counter_B 735 | B=B+dble(Xci(B_list(i,1),ii))*(-mu(B_list(i,2),ix)& 736 | &+dble(F_ab(lin8(iconf(B_list(i,1),2),iconf(B_list(i,3),2)),ix))& 737 | &)*Y(B_list(i,3),iy) 738 | enddo 739 | !$omp end do 740 | !$omp end parallel 741 | end subroutine B_2PA_2_fast_full 742 | 743 | Subroutine B_2PA_3_fast_full(ix,iy,X,Y,Xci,Yci,nroot,B_list,counter_B,mu,nci,moci,ifreq,B,F_ab,inv,nnv,iconf,maxconf) 744 | use commonresp 745 | use omp_lib 746 | implicit none 747 | 748 | integer ::ix,iy,nci,ifreq,moci,inv,nnv,maxconf 749 | integer ::nroot 750 | real*8 ::B 751 | real*8 ::mu(moci*(moci+1)/2,3) 752 | real*8 ::X(nci,3) 753 | real*8 ::Y(nci,3) 754 | real*4 ::Xci(nci,nroot), Yci(nci,nroot) 755 | real*4 :: F_ab(inv*(inv+1)/2:nnv*(nnv+1)/2,4) 756 | integer ::i,ii 757 | integer*8 :: lin8 758 | integer ::iconf(maxconf,2) 759 | integer ::counter_B 760 | integer ::B_list(1:counter_B,1:3) 761 | 762 | ii=ifreq 763 | B=0.0 764 | !$omp parallel private(i) reduction(+:B) 765 | !$omp do 766 | Do i=1,counter_B 767 | B=B+X(B_list(i,1),ix)*(& 768 | &+dble(F_ab(lin8(iconf(B_list(i,1),2),iconf(B_list(i,3),2)),4))& 769 | &)*dble(Y(B_list(i,3),iy)) 770 | enddo 771 | !$omp end do 772 | !$omp end parallel 773 | end subroutine B_2PA_3_fast_full 774 | -------------------------------------------------------------------------------- /stringmod.f90: -------------------------------------------------------------------------------- 1 | ! This file is part of std2. 2 | ! 3 | ! Copyright (C) 2013-2025 Stefan Grimme and Marc de Wergifosse 4 | ! 5 | ! std2 is free software: you can redistribute it and/or modify it under 6 | ! the terms of the GNU Lesser General Public License as published by 7 | ! the Free Software Foundation, either version 3 of the License, or 8 | ! (at your option) any later version. 9 | ! 10 | ! std2 is distributed in the hope that it will be useful, 11 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ! GNU Lesser General Public License for more details. 14 | ! 15 | ! You should have received a copy of the GNU Lesser General Public License 16 | ! along with std2. If not, see . 17 | ! 18 | !! ------------------------------------------------------------------------ 19 | module precision 20 | 21 | ! Real kinds 22 | 23 | integer, parameter :: kr4 = selected_real_kind(6,37) ! single precision real 24 | integer, parameter :: kr8 = selected_real_kind(15,307) ! double precision real 25 | 26 | ! Integer kinds 27 | 28 | integer, parameter :: ki4 = selected_int_kind(9) ! single precision integer 29 | integer, parameter :: ki8 = selected_int_kind(18) ! double precision integer 30 | 31 | !Complex kinds 32 | 33 | integer, parameter :: kc4 = kr4 ! single precision complex 34 | integer, parameter :: kc8 = kr8 ! double precision complex 35 | 36 | end module precision 37 | 38 | 39 | module strings 40 | 41 | use precision 42 | 43 | private :: value_dr,value_sr,value_di,value_si 44 | private :: write_dr,write_sr,write_di,write_si 45 | private :: writeq_dr,writeq_sr,writeq_di,writeq_si 46 | 47 | interface value ! Generic operator for converting a number string to a 48 | ! number. Calling syntax is 'call value(numstring,number,ios)' 49 | ! where 'numstring' is a number string and 'number' is a 50 | ! real number or an integer (single or double precision). 51 | module procedure value_dr 52 | module procedure value_sr 53 | module procedure value_di 54 | module procedure value_si 55 | end interface 56 | 57 | interface writenum ! Generic interface for writing a number to a string. The 58 | ! number is left justified in the string. The calling syntax 59 | ! is 'call writenum(number,string,format)' where 'number' is 60 | ! a real number or an integer, 'string' is a character string 61 | ! containing the result, and 'format' is the format desired, 62 | ! e.g., 'e15.6' or 'i5'. 63 | module procedure write_dr 64 | module procedure write_sr 65 | module procedure write_di 66 | module procedure write_si 67 | end interface 68 | 69 | interface writeq ! Generic interface equating a name to a numerical value. The 70 | ! calling syntax is 'call writeq(unit,name,value,format)' where 71 | ! unit is the integer output unit number, 'name' is the variable 72 | ! name, 'value' is the real or integer value of the variable, 73 | ! and 'format' is the format of the value. The result written to 74 | ! the output unit has the form = . 75 | module procedure writeq_dr 76 | module procedure writeq_sr 77 | module procedure writeq_di 78 | module procedure writeq_si 79 | end interface 80 | 81 | 82 | !********************************************************************** 83 | 84 | contains 85 | 86 | !********************************************************************** 87 | 88 | subroutine parse(str,delims,args,nargs) 89 | 90 | ! Parses the string 'str' into arguments args(1), ..., args(nargs) based on 91 | ! the delimiters contained in the string 'delims'. Preceding a delimiter in 92 | ! 'str' by a backslash (\) makes this particular instance not a delimiter. 93 | ! The integer output variable nargs contains the number of arguments found. 94 | 95 | character(len=*) :: str,delims 96 | character(len=len_trim(str)) :: strsav 97 | character(len=*),dimension(:) :: args 98 | 99 | strsav=str 100 | call compact(str) 101 | na=size(args) 102 | do i=1,na 103 | args(i)=' ' 104 | end do 105 | nargs=0 106 | lenstr=len_trim(str) 107 | if(lenstr==0) return 108 | k=0 109 | 110 | do 111 | if(len_trim(str) == 0) exit 112 | nargs=nargs+1 113 | call split(str,delims,args(nargs)) 114 | call removebksl(args(nargs)) 115 | end do 116 | str=strsav 117 | 118 | end subroutine parse 119 | 120 | !********************************************************************** 121 | 122 | subroutine compact(str) 123 | 124 | ! Converts multiple spaces and tabs to single spaces; deletes control characters; 125 | ! removes initial spaces. 126 | 127 | character(len=*):: str 128 | character(len=1):: ch 129 | character(len=len_trim(str)):: outstr 130 | 131 | str=adjustl(str) 132 | lenstr=len_trim(str) 133 | outstr=' ' 134 | isp=0 135 | k=0 136 | 137 | do i=1,lenstr 138 | ch=str(i:i) 139 | ich=iachar(ch) 140 | 141 | select case(ich) 142 | 143 | case(9,32) ! space or tab character 144 | if(isp==0) then 145 | k=k+1 146 | outstr(k:k)=' ' 147 | end if 148 | isp=1 149 | 150 | case(33:) ! not a space, quote, or control character 151 | k=k+1 152 | outstr(k:k)=ch 153 | isp=0 154 | 155 | end select 156 | 157 | end do 158 | 159 | str=adjustl(outstr) 160 | 161 | end subroutine compact 162 | 163 | !********************************************************************** 164 | 165 | subroutine removesp(str) 166 | 167 | ! Removes spaces, tabs, and control characters in string str 168 | 169 | character(len=*):: str 170 | character(len=1):: ch 171 | character(len=len_trim(str))::outstr 172 | 173 | str=adjustl(str) 174 | lenstr=len_trim(str) 175 | outstr=' ' 176 | k=0 177 | 178 | do i=1,lenstr 179 | ch=str(i:i) 180 | ich=iachar(ch) 181 | select case(ich) 182 | case(0:32) ! space, tab, or control character 183 | cycle 184 | case(33:) 185 | k=k+1 186 | outstr(k:k)=ch 187 | end select 188 | end do 189 | 190 | str=adjustl(outstr) 191 | 192 | end subroutine removesp 193 | 194 | !********************************************************************** 195 | 196 | subroutine value_dr(str,rnum,ios) 197 | 198 | ! Converts number string to a double precision real number 199 | 200 | character(len=*)::str 201 | real(kr8)::rnum 202 | integer :: ios 203 | 204 | ilen=len_trim(str) 205 | ipos=scan(str,'Ee') 206 | if(.not.is_digit(str(ilen:ilen)) .and. ipos/=0) then 207 | ios=3 208 | return 209 | end if 210 | read(str,*,iostat=ios) rnum 211 | 212 | end subroutine value_dr 213 | 214 | !********************************************************************** 215 | 216 | subroutine value_sr(str,rnum,ios) 217 | 218 | ! Converts number string to a single precision real number 219 | 220 | character(len=*)::str 221 | real(kr4) :: rnum 222 | real(kr8) :: rnumd 223 | 224 | call value_dr(str,rnumd,ios) 225 | if( abs(rnumd) > huge(rnum) ) then 226 | ios=15 227 | return 228 | end if 229 | if( abs(rnumd) < tiny(rnum) ) rnum=0.0_kr4 230 | rnum=rnumd 231 | 232 | end subroutine value_sr 233 | 234 | !********************************************************************** 235 | 236 | subroutine value_di(str,inum,ios) 237 | 238 | ! Converts number string to a double precision integer value 239 | 240 | character(len=*)::str 241 | integer(ki8) :: inum 242 | real(kr8) :: rnum 243 | 244 | call value_dr(str,rnum,ios) 245 | if(abs(rnum)>huge(inum)) then 246 | ios=15 247 | return 248 | end if 249 | inum=nint(rnum,ki8) 250 | 251 | end subroutine value_di 252 | 253 | !********************************************************************** 254 | 255 | subroutine value_si(str,inum,ios) 256 | 257 | ! Converts number string to a single precision integer value 258 | 259 | character(len=*)::str 260 | integer(ki4) :: inum 261 | real(kr8) :: rnum 262 | 263 | call value_dr(str,rnum,ios) 264 | if(abs(rnum)>huge(inum)) then 265 | ios=15 266 | return 267 | end if 268 | inum=nint(rnum,ki4) 269 | 270 | end subroutine value_si 271 | 272 | !********************************************************************** 273 | 274 | subroutine shiftstr(str,n) 275 | 276 | ! Shifts characters in in the string 'str' n positions (positive values 277 | ! denote a right shift and negative values denote a left shift). Characters 278 | ! that are shifted off the end are lost. Positions opened up by the shift 279 | ! are replaced by spaces. 280 | 281 | character(len=*):: str 282 | 283 | lenstr=len(str) 284 | nabs=iabs(n) 285 | if(nabs>=lenstr) then 286 | str=repeat(' ',lenstr) 287 | return 288 | end if 289 | if(n<0) str=str(nabs+1:)//repeat(' ',nabs) ! shift left 290 | if(n>0) str=repeat(' ',nabs)//str(:lenstr-nabs) ! shift right 291 | return 292 | 293 | end subroutine shiftstr 294 | 295 | !********************************************************************** 296 | 297 | subroutine insertstr(str,strins,loc) 298 | 299 | ! Inserts the string 'strins' into the string 'str' at position 'loc'. 300 | ! Characters in 'str' starting at position 'loc' are shifted right to 301 | ! make room for the inserted string. Trailing spaces of 'strins' are 302 | ! removed prior to insertion 303 | 304 | character(len=*):: str,strins 305 | character(len=len(str))::tempstr 306 | 307 | lenstrins=len_trim(strins) 308 | tempstr=str(loc:) 309 | call shiftstr(tempstr,lenstrins) 310 | tempstr(1:lenstrins)=strins(1:lenstrins) 311 | str(loc:)=tempstr 312 | return 313 | 314 | end subroutine insertstr 315 | 316 | !********************************************************************** 317 | 318 | subroutine delsubstr(str,substr) 319 | 320 | ! Deletes first occurrence of substring 'substr' from string 'str' and 321 | ! shifts characters left to fill hole. Trailing spaces or blanks are 322 | ! not considered part of 'substr'. 323 | 324 | character(len=*):: str,substr 325 | 326 | lensubstr=len_trim(substr) 327 | ipos=index(str,substr) 328 | if(ipos==0) return 329 | if(ipos == 1) then 330 | str=str(lensubstr+1:) 331 | else 332 | str=str(:ipos-1)//str(ipos+lensubstr:) 333 | end if 334 | return 335 | 336 | end subroutine delsubstr 337 | 338 | !********************************************************************** 339 | 340 | subroutine delall(str,substr) 341 | 342 | ! Deletes all occurrences of substring 'substr' from string 'str' and 343 | ! shifts characters left to fill holes. 344 | 345 | character(len=*):: str,substr 346 | 347 | lensubstr=len_trim(substr) 348 | do 349 | ipos=index(str,substr) 350 | if(ipos == 0) exit 351 | if(ipos == 1) then 352 | str=str(lensubstr+1:) 353 | else 354 | str=str(:ipos-1)//str(ipos+lensubstr:) 355 | end if 356 | end do 357 | return 358 | 359 | end subroutine delall 360 | 361 | !********************************************************************** 362 | 363 | function uppercase(str) result(ucstr) 364 | 365 | ! convert string to upper case 366 | 367 | character (len=*):: str 368 | character (len=len_trim(str)):: ucstr 369 | 370 | ilen=len_trim(str) 371 | ioffset=iachar('A')-iachar('a') 372 | iquote=0 373 | ucstr=str 374 | do i=1,ilen 375 | iav=iachar(str(i:i)) 376 | if(iquote==0 .and. (iav==34 .or.iav==39)) then 377 | iquote=1 378 | iqc=iav 379 | cycle 380 | end if 381 | if(iquote==1 .and. iav==iqc) then 382 | iquote=0 383 | cycle 384 | end if 385 | if (iquote==1) cycle 386 | if(iav >= iachar('a') .and. iav <= iachar('z')) then 387 | ucstr(i:i)=achar(iav+ioffset) 388 | else 389 | ucstr(i:i)=str(i:i) 390 | end if 391 | end do 392 | return 393 | 394 | end function uppercase 395 | 396 | !********************************************************************** 397 | 398 | function lowercase(str) result(lcstr) 399 | 400 | ! convert string to lower case 401 | 402 | character (len=*):: str 403 | character (len=len_trim(str)):: lcstr 404 | 405 | ilen=len_trim(str) 406 | ioffset=iachar('A')-iachar('a') 407 | iquote=0 408 | lcstr=str 409 | do i=1,ilen 410 | iav=iachar(str(i:i)) 411 | if(iquote==0 .and. (iav==34 .or.iav==39)) then 412 | iquote=1 413 | iqc=iav 414 | cycle 415 | end if 416 | if(iquote==1 .and. iav==iqc) then 417 | iquote=0 418 | cycle 419 | end if 420 | if (iquote==1) cycle 421 | if(iav >= iachar('A') .and. iav <= iachar('Z')) then 422 | lcstr(i:i)=achar(iav-ioffset) 423 | else 424 | lcstr(i:i)=str(i:i) 425 | end if 426 | end do 427 | return 428 | 429 | end function lowercase 430 | 431 | !********************************************************************** 432 | 433 | subroutine readline(nunitr,line,ios) 434 | 435 | ! Reads line from unit=nunitr, ignoring blank lines 436 | ! and deleting comments beginning with an exclamation point(!) 437 | 438 | character (len=*):: line 439 | 440 | do 441 | read(nunitr,'(a)', iostat=ios) line ! read input line 442 | if(ios /= 0) return 443 | line=adjustl(line) 444 | ipos=index(line,'!') 445 | if(ipos == 1) cycle 446 | if(ipos /= 0) line=line(:ipos-1) 447 | if(len_trim(line) /= 0) exit 448 | end do 449 | return 450 | 451 | end subroutine readline 452 | 453 | !********************************************************************** 454 | 455 | subroutine match(str,ipos,imatch) 456 | 457 | ! Sets imatch to the position in string of the delimiter matching the delimiter 458 | ! in position ipos. Allowable delimiters are (), [], {}, <>. 459 | 460 | character(len=*) :: str 461 | character :: delim1,delim2,ch 462 | 463 | lenstr=len_trim(str) 464 | delim1=str(ipos:ipos) 465 | select case(delim1) 466 | case('(') 467 | idelim2=iachar(delim1)+1 468 | istart=ipos+1 469 | iend=lenstr 470 | inc=1 471 | case(')') 472 | idelim2=iachar(delim1)-1 473 | istart=ipos-1 474 | iend=1 475 | inc=-1 476 | case('[','{','<') 477 | idelim2=iachar(delim1)+2 478 | istart=ipos+1 479 | iend=lenstr 480 | inc=1 481 | case(']','}','>') 482 | idelim2=iachar(delim1)-2 483 | istart=ipos-1 484 | iend=1 485 | inc=-1 486 | case default 487 | write(*,*) delim1,' is not a valid delimiter' 488 | return 489 | end select 490 | if(istart < 1 .or. istart > lenstr) then 491 | write(*,*) delim1,' has no matching delimiter' 492 | return 493 | end if 494 | delim2=achar(idelim2) ! matching delimiter 495 | 496 | isum=1 497 | do i=istart,iend,inc 498 | ch=str(i:i) 499 | if(ch /= delim1 .and. ch /= delim2) cycle 500 | if(ch == delim1) isum=isum+1 501 | if(ch == delim2) isum=isum-1 502 | if(isum == 0) exit 503 | end do 504 | if(isum /= 0) then 505 | write(*,*) delim1,' has no matching delimiter' 506 | return 507 | end if 508 | imatch=i 509 | 510 | return 511 | 512 | end subroutine match 513 | 514 | !********************************************************************** 515 | 516 | subroutine write_dr(rnum,str,fmt) 517 | 518 | ! Writes double precision real number rnum to string str using format fmt 519 | 520 | real(kr8) :: rnum 521 | character(len=*) :: str,fmt 522 | character(len=80) :: formt 523 | 524 | formt='('//trim(fmt)//')' 525 | write(str,formt) rnum 526 | str=adjustl(str) 527 | 528 | end subroutine write_dr 529 | 530 | !*********************************************************************** 531 | 532 | subroutine write_sr(rnum,str,fmt) 533 | 534 | ! Writes single precision real number rnum to string str using format fmt 535 | 536 | real(kr4) :: rnum 537 | character(len=*) :: str,fmt 538 | character(len=80) :: formt 539 | 540 | formt='('//trim(fmt)//')' 541 | write(str,formt) rnum 542 | str=adjustl(str) 543 | 544 | end subroutine write_sr 545 | 546 | !*********************************************************************** 547 | 548 | subroutine write_di(inum,str,fmt) 549 | 550 | ! Writes double precision integer inum to string str using format fmt 551 | 552 | integer(ki8) :: inum 553 | character(len=*) :: str,fmt 554 | character(len=80) :: formt 555 | 556 | formt='('//trim(fmt)//')' 557 | write(str,formt) inum 558 | str=adjustl(str) 559 | 560 | end subroutine write_di 561 | 562 | !*********************************************************************** 563 | 564 | subroutine write_si(inum,str,fmt) 565 | 566 | ! Writes single precision integer inum to string str using format fmt 567 | 568 | integer(ki4) :: inum 569 | character(len=*) :: str,fmt 570 | character(len=80) :: formt 571 | 572 | formt='('//trim(fmt)//')' 573 | write(str,formt) inum 574 | str=adjustl(str) 575 | 576 | end subroutine write_si 577 | 578 | !*********************************************************************** 579 | 580 | subroutine trimzero(str) 581 | 582 | ! Deletes nonsignificant trailing zeroes from number string str. If number 583 | ! string ends in a decimal point, one trailing zero is added. 584 | 585 | character(len=*) :: str 586 | character :: ch 587 | character(len=10) :: exp 588 | 589 | ipos=scan(str,'eE') 590 | if(ipos>0) then 591 | exp=str(ipos:) 592 | str=str(1:ipos-1) 593 | endif 594 | lstr=len_trim(str) 595 | do i=lstr,1,-1 596 | ch=str(i:i) 597 | if(ch=='0') cycle 598 | if(ch=='.') then 599 | str=str(1:i)//'0' 600 | if(ipos>0) str=trim(str)//trim(exp) 601 | exit 602 | endif 603 | str=str(1:i) 604 | exit 605 | end do 606 | if(ipos>0) str=trim(str)//trim(exp) 607 | 608 | end subroutine trimzero 609 | 610 | !********************************************************************** 611 | 612 | subroutine writeq_dr(unit,namestr,value,fmt) 613 | 614 | ! Writes a string of the form = value to unit 615 | 616 | real(kr8) :: value 617 | integer :: unit 618 | character(len=*) :: namestr,fmt 619 | character(len=32) :: tempstr 620 | 621 | call writenum(value,tempstr,fmt) 622 | call trimzero(tempstr) 623 | write(unit,*) trim(namestr)//' = '//trim(tempstr) 624 | 625 | end subroutine writeq_dr 626 | 627 | !********************************************************************** 628 | 629 | subroutine writeq_sr(unit,namestr,value,fmt) 630 | 631 | ! Writes a string of the form = value to unit 632 | 633 | real(kr4) :: value 634 | integer :: unit 635 | character(len=*) :: namestr,fmt 636 | character(len=32) :: tempstr 637 | 638 | call writenum(value,tempstr,fmt) 639 | call trimzero(tempstr) 640 | write(unit,*) trim(namestr)//' = '//trim(tempstr) 641 | 642 | end subroutine writeq_sr 643 | 644 | !********************************************************************** 645 | 646 | subroutine writeq_di(unit,namestr,ivalue,fmt) 647 | 648 | ! Writes a string of the form = ivalue to unit 649 | 650 | integer(ki8) :: ivalue 651 | integer :: unit 652 | character(len=*) :: namestr,fmt 653 | character(len=32) :: tempstr 654 | call writenum(ivalue,tempstr,fmt) 655 | call trimzero(tempstr) 656 | write(unit,*) trim(namestr)//' = '//trim(tempstr) 657 | 658 | end subroutine writeq_di 659 | 660 | !********************************************************************** 661 | 662 | subroutine writeq_si(unit,namestr,ivalue,fmt) 663 | 664 | ! Writes a string of the form = ivalue to unit 665 | 666 | integer(ki4) :: ivalue 667 | integer :: unit 668 | character(len=*) :: namestr,fmt 669 | character(len=32) :: tempstr 670 | call writenum(ivalue,tempstr,fmt) 671 | call trimzero(tempstr) 672 | write(unit,*) trim(namestr)//' = '//trim(tempstr) 673 | 674 | end subroutine writeq_si 675 | 676 | !********************************************************************** 677 | 678 | function is_letter(ch) result(res) 679 | 680 | ! Returns .true. if ch is a letter and .false. otherwise 681 | 682 | character :: ch 683 | logical :: res 684 | 685 | select case(ch) 686 | case('A':'Z','a':'z') 687 | res=.true. 688 | case default 689 | res=.false. 690 | end select 691 | return 692 | 693 | end function is_letter 694 | 695 | !********************************************************************** 696 | 697 | function is_digit(ch) result(res) 698 | 699 | ! Returns .true. if ch is a digit (0,1,...,9) and .false. otherwise 700 | 701 | character :: ch 702 | logical :: res 703 | 704 | select case(ch) 705 | case('0':'9') 706 | res=.true. 707 | case default 708 | res=.false. 709 | end select 710 | return 711 | 712 | end function is_digit 713 | 714 | !********************************************************************** 715 | 716 | subroutine split(str,delims,before,sep) 717 | 718 | ! Routine finds the first instance of a character from 'delims' in the 719 | ! the string 'str'. The characters before the found delimiter are 720 | ! output in 'before'. The characters after the found delimiter are 721 | ! output in 'str'. The optional output character 'sep' contains the 722 | ! found delimiter. A delimiter in 'str' is treated like an ordinary 723 | ! character if it is preceded by a backslash (\). If the backslash 724 | ! character is desired in 'str', then precede it with another backslash. 725 | 726 | character(len=*) :: str,delims,before 727 | character,optional :: sep 728 | logical :: pres 729 | character :: ch,cha 730 | 731 | pres=present(sep) 732 | str=adjustl(str) 733 | call compact(str) 734 | lenstr=len_trim(str) 735 | if(lenstr == 0) return ! string str is empty 736 | k=0 737 | ibsl=0 ! backslash initially inactive 738 | before=' ' 739 | do i=1,lenstr 740 | ch=str(i:i) 741 | if(ibsl == 1) then ! backslash active 742 | k=k+1 743 | before(k:k)=ch 744 | ibsl=0 745 | cycle 746 | end if 747 | if(ch == '\') then ! backslash with backslash inactive 748 | k=k+1 749 | before(k:k)=ch 750 | ibsl=1 751 | cycle 752 | end if 753 | ipos=index(delims,ch) 754 | if(ipos == 0) then ! character is not a delimiter 755 | k=k+1 756 | before(k:k)=ch 757 | cycle 758 | end if 759 | if(ch /= ' ') then ! character is a delimiter that is not a space 760 | str=str(i+1:) 761 | if(pres) sep=ch 762 | exit 763 | end if 764 | cha=str(i+1:i+1) ! character is a space delimiter 765 | iposa=index(delims,cha) 766 | if(iposa > 0) then ! next character is a delimiter 767 | str=str(i+2:) 768 | if(pres) sep=cha 769 | exit 770 | else 771 | str=str(i+1:) 772 | if(pres) sep=ch 773 | exit 774 | end if 775 | end do 776 | if(i >= lenstr) str='' 777 | str=adjustl(str) ! remove initial spaces 778 | return 779 | 780 | end subroutine split 781 | 782 | !********************************************************************** 783 | 784 | subroutine removebksl(str) 785 | 786 | ! Removes backslash (\) characters. Double backslashes (\\) are replaced 787 | ! by a single backslash. 788 | 789 | character(len=*):: str 790 | character(len=1):: ch 791 | character(len=len_trim(str))::outstr 792 | 793 | str=adjustl(str) 794 | lenstr=len_trim(str) 795 | outstr=' ' 796 | k=0 797 | ibsl=0 ! backslash initially inactive 798 | 799 | do i=1,lenstr 800 | ch=str(i:i) 801 | if(ibsl == 1) then ! backslash active 802 | k=k+1 803 | outstr(k:k)=ch 804 | ibsl=0 805 | cycle 806 | end if 807 | if(ch == '\') then ! backslash with backslash inactive 808 | ibsl=1 809 | cycle 810 | end if 811 | k=k+1 812 | outstr(k:k)=ch ! non-backslash with backslash inactive 813 | end do 814 | 815 | str=adjustl(outstr) 816 | 817 | end subroutine removebksl 818 | 819 | !********************************************************************** 820 | 821 | end module strings 822 | --------------------------------------------------------------------------------