diff --git a/GoDuck b/GoDuck new file mode 100755 index 0000000..98f014b --- /dev/null +++ b/GoDuck @@ -0,0 +1,18 @@ +#! /bin/bash + +set -e + +if [ $# -ne 2 ] +then + echo "You need two arguments [Molecule] [Basis] !!" +fi + +if [ $# = 2 ] +then + cp examples/molecule."$1" input/molecule + cp examples/basis."$1"."$2" input/basis + cp examples/basis."$1"."$2" input/weight + ./bin/IntPak + ./bin/MCQC +fi + diff --git a/GoSph b/GoSph new file mode 100755 index 0000000..0c86c9e --- /dev/null +++ b/GoSph @@ -0,0 +1,17 @@ +#! /bin/bash + +if [ $# -ne 1 ] +then + echo "You need one argument [BasisSetSize] !!" +fi + +if [ $# = 1 ] +then +cp examples/molecule.Sph input/molecule +cp examples/basis.Sph.Ylm"$1" input/basis +cp int/Sph_ERI_"$1".dat int/ERI.dat +cp int/Sph_Kin_"$1".dat int/Kin.dat +cp int/Sph_Nuc_"$1".dat int/Nuc.dat +cp int/Sph_Ov_"$1".dat int/Ov.dat +./bin/MCQC +fi diff --git a/PyDuck b/PyDuck new file mode 100755 index 0000000..25016c9 --- /dev/null +++ b/PyDuck @@ -0,0 +1,321 @@ +#!/usr/bin/env python2 +import sys +from termcolor import colored +import shlex +from subprocess import Popen, PIPE +import itertools +import re +import numpy as np +import os +from shutil import copy2 +import matplotlib.pyplot as plt +import json +from math import * +from collections import OrderedDict +import csv +import argparse +def GetDuckDir(): + return os.path.dirname(os.path.realpath(__file__)) + +def nNucl(molbaselines): + return float(molbaselines[1].split()[0]) + +def isMononucle(molbaselines): + return nNucl(molbaselines)==1 + +def openfileindir(path,readwrite): + mydir=os.path.dirname(path) + if not os.path.exists(mydir) and mydir!="": + os.makedirs(mydir) + return open(path,readwrite) +def outfile(Outdic,item,index=None): + itemdata=Outdic[item] + if itemdata["Enabled"]: + fmt=itemdata["Format"] + if index is not None: + filename=fmt.format(index) + else: + filename=fmt + if "Parent" in Outdic: + path=os.path.join(Outdic["Parent"],filename) + else: + path=filename + return openfileindir(path,'w') + else: + return + +def runDuck(mol,basis,x,molbaselines,molbase,basisbase): + #gennerate molecule file + currdir=os.getcwd() + os.chdir(GetDuckDir()) + molname='.'.join([mol,str(x)]) + lstw=list() + for i,line in enumerate(molbaselines): + if i<3: + lstw.append(line) + else: + if isMononucle(molbaselines): + if i==3: + lstw.append(' '.join([str(x)]+line.split()[1:])) + else: + v=[float(abs(x))/float(2),float(-abs(x)/float(2))] + val=v[i-3] + lstw.append(' '.join([line.split()[0],'0.','0.',str(val)])) + junkfiles=list() + with open(molbase+molname,'w') as n: + junkfiles.append(n.name) + n.write(os.linesep.join(lstw)) + #Copy basis + basisfile=basisbase+'.'.join([mol,basis]) + newbasisfile=basisbase+'.'.join([molname,basis]) + copy2(basisfile,newbasisfile) + junkfiles.append(newbasisfile) + #start child process Goduck + cmd=" ".join(["./GoDuck",molname, basis]) + Duck=Popen(shlex.split(cmd),stdout=PIPE) + (DuckOut, DuckErr) = Duck.communicate() + excode=Duck.wait() + for junk in junkfiles: + os.remove(junk) + os.chdir(currdir) + return (excode,DuckOut,DuckErr) + +def addvalue(dic,key,x,y): + if key not in dic: + dic[key]=list() + dic[key].append(y) + print(key) + print(x,y) + +def main(mol): + #get basepath for files + molbase='examples/molecule.' + basisbase=molbase.replace('molecule','basis') + with open('PyOptions.json','r') as jfile: + options=json.loads(jfile.read()) + basis=str(options['Basis']) + #Get mehtod to analyse + methodsdic=options['Methods'] + #Get datas to analyse in this method + scandic=options['Scan'] + scan=np.arange(scandic['Start'],scandic['Stop']+scandic['Step'],scandic['Step']) + print(scan) + mymethods=dict() + alllabels=list() + for method,methoddatas in methodsdic.iteritems(): + if methoddatas['Enabled']: + mymethods[method]=methoddatas + for label,labeldatas in methoddatas['Labels'].iteritems(): + if type(labeldatas) is dict: + enabled=labeldatas['Enabled'] + else: + enabled=labeldatas + if enabled and label not in alllabels: + alllabels.append(label) + graphdic=dict() + errorconvstring="Convergence failed" + with open(os.path.join(GetDuckDir(),molbase+mol),'r') as b: + molbaselines=b.read().splitlines() + if isMononucle(molbaselines): + print('monoatomic system: variation of the nuclear charge') + else: + print('polyatomic system: variation is on the distance') + for x in scan: + (DuckExit,DuckOut,DuckErr)=runDuck(mol,basis,x,molbaselines,molbase,basisbase) + #print DuckOut on file or not + if "Outputs" in options: + outdat=options["Outputs"] + if 'DuckOutput' in outdat: + outopt=outdat["DuckOutput"] + if outopt['Enabled']: + if outopt['Multiple']: + duckoutf=outfile(outopt,"DuckOutput",x) + else: + if x==scan[0]: + duckoutf=outfile(outdat,"DuckOutput") + duckoutf.write('Z' if isMononucle(molbaselines) else 'Distance'+' '+str(x)+os.linesep+os.linesep) + duckoutf.write(DuckOut) + if outopt['Multiple']: + duckoutf.close() + print("GoDuk exit code " + str(DuckExit)) + if DuckExit !=0: + #if GoDuck is not happy + print(DuckErr) + sys.exit(-1) + #get all data for the method + for method,methoddatas in mymethods.iteritems(): + isnan=False + if '{0}' in method: + if "index" in methoddatas: + methodheaders=[method.format(str(x)) for x in methoddatas['Index']] + else: + try: + print(method) + reglist=re.findall('(\d+)'.join([re.escape(s) for s in method.split('{0}')]),DuckOut) + print(reglist) + final=max([(int(i[0]) if type(i) is tuple else int(i)) for i in reglist]) + print(final) + methodheaders=[method.format(str(final))] + except: + isnan=True + methodheaders=[None] + method=method.replace('{0}','') + else: + methodheaders=list([method]) + for methodheader in methodheaders: + if len(methodheaders)!=1: + method=methodheader + lbldic=methoddatas['Labels'] + print(methodheader) + if methodheader is None: + methodtxt='' + else: + it=itertools.dropwhile(lambda line: methodheader + ' calculation' not in line , DuckOut.splitlines()) + it=itertools.takewhile(lambda line: 'Total CPU time for ' not in line, it) + methodtxt=os.linesep.join(it) + if errorconvstring in methodtxt: + print(colored(' '.join([method, errorconvstring, '!!!!!']),'red')) + isnan=True + if methodtxt=='': + print(colored('No data' +os.linesep+ 'RHF scf not converged or method not enabled','red')) + isnan=True + #find the expected values + for label,labeldatas in lbldic.iteritems(): + if type(labeldatas) is dict: + indexed=('Index' in labeldatas) + enabled=labeldatas['Enabled'] + graph=labeldatas['Graph'] if 'Graph' in labeldatas else 1 + else: + enabled=labeldatas + graph=1 + indexed=False + if enabled: + if graph not in graphdic: + graphdic[graph]=OrderedDict() + y=graphdic[graph] + if not indexed: + v=np.nan + print(method) + print(label) + if not isnan: + try: + m=re.search('\s+'.join([re.escape(w) for w in label.split()]) + "\s+(?:"+re.escape("(eV):")+"\s+)?(?:=\s+)?(-?\d+.?\d*)",methodtxt) + v=m.group(1) + except: + v=np.nan + addvalue(y,(method,label),x,v) + else: + startindex=-1 + columnindex=-1 + linedtxt=methodtxt.split(os.linesep) + for n,line in enumerate(linedtxt): + if all(x in line for x in ['|',' '+label+' ','#']): + startindex=n+2 + columnindex=[s.strip() for s in line.split('|')].index(label) + break + with open(os.path.join(GetDuckDir(),'input','molecule'),'r') as molfile: + molfile.readline() + line=molfile.readline() + nel=int(line.split()[1]) + print(nel) + HOMO=int(nel/2) + HO=HOMO + LUMO=HOMO+1 + BV=LUMO + for i in labeldatas['Index']: + v=np.nan + if type(i) is str or type(i) is unicode: + ival=eval(i) + if type(ival) is not int: + print('Index '+ str(i) + 'must be integer') + sys.exit(-2) + else: + ival=i + v=np.nan + if not isnan: + try: + if startindex!=-1 and columnindex!=-1: + line=linedtxt[startindex+ival-1] + v=float(line.split('|')[columnindex].split()[0]) + print(method) + print(label) + print(i) + else: + v=np.nan + except: + v=np.nan + key=(method,label,i) + addvalue(y,key,x,v) + tpl=(x,scan.tolist().index(x)+1,len(y[key])) + print(tpl) + if tpl[1]-tpl[2]: + sys.exit() + #define graph grid + maxgraph=max(graphdic.keys()) + maxrow=int(round(sqrt(maxgraph))) + maxcol=int(ceil(float(maxgraph)/float(maxrow))) + #define label ls + for graph,y in graphdic.iteritems(): + datas=list() + datas.append(["#x"]+scan.tolist()) + if len(y.keys())!=0: + plt.subplot(maxrow,maxcol,graph) + plt.xlabel('Z' if isMononucle(molbaselines) else 'Distance '+mol) + ylbls=list([basis]) + for i in range(0,2): + lst=list(set([key[i] for key in y.keys()])) + if len(lst)==1: + ylbls.append(lst[0]) + plt.ylabel(' '.join(ylbls)) + print('Legend') + print(list(y.keys())) + for key,values in y.iteritems(): + legend=list() + for el in key[0:2]: + if el not in ylbls: + legend.append(el) + if len(key)>2: + legend.append(str(key[2])) + #plot curves + lbl=' '.join(legend) + plt.plot(scan,y[key],'-o',label=lbl) + #print("min",x[y.index(min(y))]/2) + #generate legends + plt.legend() + dataout=False + if "Outputs" in options: + outputs=options['Outputs'] + if "DataOutput" in outputs: + DataOutput=outputs['DataOutput'] + dataout=DataOutput['Enabled'] + if dataout: + fmtlegendf='{0}({1})' + datas.append([fmtlegendf.format("y",lbl)]+y[key]) + if dataout: + csvdatas=zip(*datas) + with outfile(outputs,"DataOutput",graph) as csvf: + writer = csv.writer(csvf, delimiter=' ') + writer.writerow(['#']+ylbls) + writer.writerows(csvdatas) + #show graph + if "Outputs" in options: + outputs=options['Outputs'] + if "FigureOutput" in outputs: + figout=outputs["FigureOutput"] + if figout["Enabled"]: + plt.savefig(figout['Path']) + plt.show() +if __name__ == '__main__': + parser=argparse.ArgumentParser() + parser.add_argument("mol",nargs='?', help="molecule to compute",type=str) + parser.add_argument("-c,--copy", help="Copy sample option file",action="store_true",dest="copy") + args = parser.parse_args() + if len(sys.argv)==1: + parser.print_help() + else: + if args.copy: + copy2(os.path.join(GetDuckDir(),"PyOptions.template.json"),"PyOptions.json") + if args.mol is not None: + os.system("vim PyOptions.json") + if args.mol is not None: + main(args.mol) diff --git a/PyOptions.json b/PyOptions.json new file mode 100644 index 0000000..77b67a9 --- /dev/null +++ b/PyOptions.json @@ -0,0 +1,145 @@ +{ + "Scan": { + "Start":0.8, + "Stop":1.2, + "Step":0.01 + }, + "Basis":"6-31G", + "Outputs": { + "DataOutput": { + "Enabled":true, + "Format":"Duck{0}.dat" + }, + "DuckOutput": { + "Enabled":true, + "Multiple":false, + "Format":"DuckOut.out" + }, + "FigureOutput":{ + "Enabled":false, + "Path":"Figure.png" + } + }, + "Methods": { + "RHF":{ + "Enabled": true, + "Labels": { + "One-electron energy":false, + "Kinetic energy":false, + "Potential energy":false, + "Two-electron energy":false, + "Coulomb energy":false, + "Exchange energy":false, + "Electronic energy":false, + "Nuclear repulsion":false, + "Hartree-Fock energy":true, + "HF HOMO energy":false, + "HF LUMO energy":false, + "HF HOMO-LUMO gap":false + } + }, + "One-shot G0W0": { + "Enabled": true, + "Labels": { + "G0W0 HOMO energy":true, + "G0W0 LUMO energy":true, + "G0W0 HOMO-LUMO gap":false, + "G0W0 total energy":false, + "RPA correlation energy" :false, + "Z": { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":1 + }, + "Sigma_c (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":2 + }, + "e_QP (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO+1","LUMO+2"], + "Graph":3 + }, + "e_HF (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":4 + } + } + }, + "Self-consistent evG{0}W{0}": { + "Enabled":false, + "Labels": { + "evGW HOMO energy":false, + "evGW LUMO energy":false, + "evGW HOMO-LUMO gap":false, + "evGW total energy":false, + "RPA correlation energy" :false, + "Z": { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":1 + }, + "Sigma_c (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":2 + }, + "e_QP (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":3 + }, + "e_HF (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":4 + } + } + }, + "Self-consistent qsG{0}W{0}": { + "Enabled": false, + "Labels": { + "qsGW HOMO energy":false, + "qsGW LUMO energy":false, + "qsGW HOMO-LUMO gap":false, + "qsGW total energy":false, + "qsGW exchange energy":false, + "qsGW correlation energy":false, + "RPA correlation energy":{ + "Enabled":false, + "Graph":2 + }, + "Z": { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":4 + }, + "e_QP-e_HF (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":5 + }, + "e_QP (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":6 + } + } + }, + "MP2": { + "Enabled": false, + "Labels": { + "MP2 correlation energy": { + "Enabled":true, + "Graph":4 + }, + "Direct part":false, + "Exchange part":false, + "MP2 total energy":true, + "MP2 energy":false + } + } + } +} diff --git a/PyOptions.template.json b/PyOptions.template.json new file mode 100644 index 0000000..77b67a9 --- /dev/null +++ b/PyOptions.template.json @@ -0,0 +1,145 @@ +{ + "Scan": { + "Start":0.8, + "Stop":1.2, + "Step":0.01 + }, + "Basis":"6-31G", + "Outputs": { + "DataOutput": { + "Enabled":true, + "Format":"Duck{0}.dat" + }, + "DuckOutput": { + "Enabled":true, + "Multiple":false, + "Format":"DuckOut.out" + }, + "FigureOutput":{ + "Enabled":false, + "Path":"Figure.png" + } + }, + "Methods": { + "RHF":{ + "Enabled": true, + "Labels": { + "One-electron energy":false, + "Kinetic energy":false, + "Potential energy":false, + "Two-electron energy":false, + "Coulomb energy":false, + "Exchange energy":false, + "Electronic energy":false, + "Nuclear repulsion":false, + "Hartree-Fock energy":true, + "HF HOMO energy":false, + "HF LUMO energy":false, + "HF HOMO-LUMO gap":false + } + }, + "One-shot G0W0": { + "Enabled": true, + "Labels": { + "G0W0 HOMO energy":true, + "G0W0 LUMO energy":true, + "G0W0 HOMO-LUMO gap":false, + "G0W0 total energy":false, + "RPA correlation energy" :false, + "Z": { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":1 + }, + "Sigma_c (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":2 + }, + "e_QP (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO+1","LUMO+2"], + "Graph":3 + }, + "e_HF (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":4 + } + } + }, + "Self-consistent evG{0}W{0}": { + "Enabled":false, + "Labels": { + "evGW HOMO energy":false, + "evGW LUMO energy":false, + "evGW HOMO-LUMO gap":false, + "evGW total energy":false, + "RPA correlation energy" :false, + "Z": { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":1 + }, + "Sigma_c (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":2 + }, + "e_QP (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":3 + }, + "e_HF (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":4 + } + } + }, + "Self-consistent qsG{0}W{0}": { + "Enabled": false, + "Labels": { + "qsGW HOMO energy":false, + "qsGW LUMO energy":false, + "qsGW HOMO-LUMO gap":false, + "qsGW total energy":false, + "qsGW exchange energy":false, + "qsGW correlation energy":false, + "RPA correlation energy":{ + "Enabled":false, + "Graph":2 + }, + "Z": { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":4 + }, + "e_QP-e_HF (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":5 + }, + "e_QP (eV)" : { + "Enabled":true, + "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], + "Graph":6 + } + } + }, + "MP2": { + "Enabled": false, + "Labels": { + "MP2 correlation energy": { + "Enabled":true, + "Graph":4 + }, + "Direct part":false, + "Exchange part":false, + "MP2 total energy":true, + "MP2 energy":false + } + } + } +} diff --git a/include/parameters.h b/include/parameters.h new file mode 100644 index 0000000..cf69187 --- /dev/null +++ b/include/parameters.h @@ -0,0 +1,12 @@ + integer,parameter :: nspin = 2 + integer,parameter :: maxShell = 50 + integer,parameter :: n1eInt = 3 + integer,parameter :: n2eInt = 4 + integer,parameter :: n3eInt = 3 + integer,parameter :: n4eInt = 3 + integer,parameter :: maxK = 20 + + double precision,parameter :: pi = acos(-1d0) + double precision,parameter :: HaToeV = 27.21138602d0 + double precision,parameter :: pmtoau = 0.0188973d0 + diff --git a/include/quadrature.h b/include/quadrature.h new file mode 100644 index 0000000..f4e8a13 --- /dev/null +++ b/include/quadrature.h @@ -0,0 +1,17 @@ + +! Gauss-Legendre quadrature roots and weights + + integer,parameter :: nQuad = 21 + double precision, save :: rQuad(1:nQuad) = & + (/ 0.00312391468981d0 , 0.0163865807168d0 , 0.0399503329248d0 , 0.0733183177083d0 , 0.115780018262d0 , & + 0.166430597901d0 , 0.224190582056d0 , 0.287828939896d0 , 0.355989341599d0 , 0.42721907292d0 , & + 0.5d0 , 0.57278092708d0 , 0.644010658401d0 , 0.712171060104d0 , 0.775809417944d0 , & + 0.833569402099d0 , 0.884219981738d0 , 0.926681682292d0 , 0.960049667075d0 , 0.983613419283d0 , & + 0.99687608531d0 /) + double precision, save :: wQuad(1:nQuad) = & + (/ 0.0080086141288872d0, 0.018476894885426d0, 0.028567212713429d0, 0.03805005681419d0 , 0.046722211728017d0, & + 0.054398649583574d0 , 0.060915708026864d0, 0.066134469316669d0, 0.069943697395537d0, 0.072262201994985d0, & + 0.07304056682485d0 , 0.072262201994985d0, 0.069943697395537d0, 0.066134469316669d0, 0.060915708026864d0, & + 0.054398649583574d0 , 0.046722211728017d0, 0.03805005681419d0 , 0.028567212713429d0, 0.018476894885426d0, & + 0.0080086141288872d0 /) + diff --git a/input/auxbasis b/input/auxbasis new file mode 100644 index 0000000..4317623 --- /dev/null +++ b/input/auxbasis @@ -0,0 +1,3 @@ +1 0 +2 0 +3 0 diff --git a/input/basis b/input/basis new file mode 100644 index 0000000..a18b478 --- /dev/null +++ b/input/basis @@ -0,0 +1,14 @@ +1 2 +S 3 1.00 + 18.7311370 0.03349460 + 2.8253937 0.23472695 + 0.6401217 0.81375733 +S 1 1.00 + 0.1612778 1.0000000 +2 2 +S 3 1.00 + 18.7311370 0.03349460 + 2.8253937 0.23472695 + 0.6401217 0.81375733 +S 1 1.00 + 0.1612778 1.0000000 diff --git a/input/geminal b/input/geminal new file mode 100644 index 0000000..d3827e7 --- /dev/null +++ b/input/geminal @@ -0,0 +1 @@ +1.0 diff --git a/input/methods b/input/methods new file mode 100644 index 0000000..183d9ac --- /dev/null +++ b/input/methods @@ -0,0 +1,13 @@ +# HF MOM + T F +# MP2 MP3 + F F +# CIS TDHF ADC + F F F +# GF2 GF3 + F F +# G0W0 evGW qsGW + T F F +# MCMP2 + F + diff --git a/input/molecule b/input/molecule new file mode 100644 index 0000000..1578c45 --- /dev/null +++ b/input/molecule @@ -0,0 +1,5 @@ +# nAt nEl nCore nRyd + 2 2 0 0 +# Znuc x y z +1. 0. 0. 0.4 +1. 0. 0. -0.4 \ No newline at end of file diff --git a/input/options b/input/options new file mode 100644 index 0000000..5549cb1 --- /dev/null +++ b/input/options @@ -0,0 +1,12 @@ +# RHF: maxSCF thresh DIIS n_diis guess_type ortho_type + 32 0.0000001 T 5 1 1 +# MPn: + +# CIS/TDHF: singlet triplet + T F +# GF: maxSCF thresh DIIS n_diis renormalization + 64 0.00001 T 5 3 +# GW: maxSCF thresh DIIS n_diis COHSEX SOSEX BSE TDA G0W GW0 linearize + 64 0.00001 T 15 F F F F F F F +# MCMP2: nMC nEq nWalk dt nPrint iSeed doDrift + 1000000 100000 10 0.3 10000 1234 T diff --git a/input/weight b/input/weight new file mode 100644 index 0000000..a18b478 --- /dev/null +++ b/input/weight @@ -0,0 +1,14 @@ +1 2 +S 3 1.00 + 18.7311370 0.03349460 + 2.8253937 0.23472695 + 0.6401217 0.81375733 +S 1 1.00 + 0.1612778 1.0000000 +2 2 +S 3 1.00 + 18.7311370 0.03349460 + 2.8253937 0.23472695 + 0.6401217 0.81375733 +S 1 1.00 + 0.1612778 1.0000000 diff --git a/src/.DS_Store b/src/.DS_Store new file mode 100644 index 0000000..db094b7 Binary files /dev/null and b/src/.DS_Store differ diff --git a/src/IntPak/CalcBoysF.f90 b/src/IntPak/CalcBoysF.f90 new file mode 100644 index 0000000..a9fc9ed --- /dev/null +++ b/src/IntPak/CalcBoysF.f90 @@ -0,0 +1,47 @@ +!module c_functions +! use iso_c_binding +! interface +! function gsl_sf_gamma_inc_P(a,t) bind(C, name="gsl_sf_gamma_inc_P") +! use iso_c_binding, only: c_double +! real(kind=c_double), value :: a,t +! real(kind=c_double) :: gsl_sf_gamma_inc_P +! end function gsl_sf_gamma_inc_P +! end interface +!end module + +subroutine CalcBoysF(maxm,t,Fm) +! use c_functions +! Comute the generalized Boys function Fm(t) using Slatec library + + implicit none + +! Input variables + + double precision,intent(in) :: t + integer,intent(in) :: maxm + +! Local variables + + integer :: m + double precision :: dm + double precision :: dgami + + +! Output variables + + double precision,intent(inout):: Fm(0:maxm) + + if(t == 0d0) then + do m=0,maxm + dm = dble(m) + Fm(m) = 1d0/(2d0*dm+1d0) + enddo + else + do m=0,maxm + dm = dble(m) +! Fm(m) = gamma(dm+0.5d0)*gsl_sf_gamma_inc_P(dm+0.5d0,t)/(2d0*t**(dm+0.5d0)) + Fm(m) = dgami(dm+0.5d0,t)/(2d0*t**(dm+0.5d0)) + enddo + endif + +end subroutine CalcBoysF diff --git a/src/IntPak/CalcNBasis.f90 b/src/IntPak/CalcNBasis.f90 new file mode 100644 index 0000000..49fb2a9 --- /dev/null +++ b/src/IntPak/CalcNBasis.f90 @@ -0,0 +1,28 @@ +subroutine CalcNBasis(nShell,atot,NBasis) + + implicit none + +! Input variables + + integer,intent(in) :: nShell + integer,intent(in) :: atot(nShell) + +! Local variables + + integer :: iShell + +! Output variables + + integer,intent(out) :: NBasis + + NBasis = 0 + do iShell=1,nShell + NBasis = NBasis + (atot(iShell)*atot(iShell) + 3*atot(iShell) + 2)/2 + enddo + + write(*,'(A28)') '------------------' + write(*,'(A28,1X,I16)') 'Number of basis functions',NBasis + write(*,'(A28)') '------------------' + write(*,*) + +end subroutine CalcNBasis diff --git a/src/IntPak/CalcOm.f90 b/src/IntPak/CalcOm.f90 new file mode 100644 index 0000000..0b88277 --- /dev/null +++ b/src/IntPak/CalcOm.f90 @@ -0,0 +1,40 @@ +subroutine CalcOm(maxm,ExpPQi,NormPQSq,Om) + +! Comute the 0^m: (00|00)^m + + implicit none + +! Input variables + + integer,intent(in) :: maxm + double precision,intent(in) :: ExpPQi,NormPQSq + +! Local variables + + integer :: m + double precision :: pi,dm,t + double precision,allocatable :: Fm(:) + +! Output variables + + double precision,intent(inout):: Om (0:maxm) + + allocate(Fm(0:maxm)) + + pi = 4d0*atan(1d0) + +! Campute generalized Boys functions + + t = NormPQSq/ExpPQi + call CalcBoysF(maxm,t,Fm) + +! Compute (00|00)^m + + do m=0,maxm + dm =dble(m) + Om(m) = (2d0/sqrt(pi))*(-1d0)**dm*(1d0/ExpPQi)**(dm+0.5d0)*Fm(m) + enddo + + deallocate(Fm) + +end subroutine CalcOm diff --git a/src/IntPak/CalcOm3e.f90 b/src/IntPak/CalcOm3e.f90 new file mode 100644 index 0000000..aab4085 --- /dev/null +++ b/src/IntPak/CalcOm3e.f90 @@ -0,0 +1,44 @@ +subroutine CalcOm3e(maxm,delta0,delta1,Y1,Y0,Om) + +! Compute the 0^m for ERIs: (00|00)^m + + implicit none + +! Input variables + + integer,intent(in) :: maxm + double precision,intent(in) :: delta0,delta1,Y0,Y1 + +! Local variables + + integer :: m + double precision :: pi,t,OG + double precision,allocatable :: Fm(:) + +! Output variables + + double precision,intent(inout):: Om (0:maxm) + + allocate(Fm(0:maxm)) + + pi = 4d0*atan(1d0) + +! Calculate OG + + OG = (pi**4/delta0)**(3d0/2d0)*exp(-Y0) + +! Campute generalized Boys functions + + t = delta1/(delta1-delta0)*(Y1-Y0) + call CalcBoysF(maxm,t,Fm) + +! Compute (000|000)^m + + do m=0,maxm + Om(m) = (2d0/sqrt(pi))*OG*sqrt(delta0/(delta1-delta0))*(delta1/(delta1-delta0))**m + Om(m) = Om(m)*Fm(m) + enddo + + deallocate(Fm) + +end subroutine CalcOm3e diff --git a/src/IntPak/CalcOmERI.f90 b/src/IntPak/CalcOmERI.f90 new file mode 100644 index 0000000..6054b16 --- /dev/null +++ b/src/IntPak/CalcOmERI.f90 @@ -0,0 +1,39 @@ +subroutine CalcOmERI(maxm,ExpY,NormYSq,Om) + +! Compute the 0^m for ERIs: (00|00)^m + + implicit none + +! Input variables + + integer,intent(in) :: maxm + double precision,intent(in) :: ExpY,NormYSq + +! Local variables + + integer :: m + double precision :: pi,t + double precision,allocatable :: Fm(:) + +! Output variables + + double precision,intent(inout):: Om (0:maxm) + + allocate(Fm(0:maxm)) + + pi = 4d0*atan(1d0) + +! Campute generalized Boys functions + + t = ExpY*NormYSq + call CalcBoysF(maxm,t,Fm) + +! Compute (00|00)^m + + do m=0,maxm + Om(m) = (2d0/sqrt(pi))*sqrt(ExpY)*Fm(m) + enddo + + deallocate(Fm) + +end subroutine CalcOmERI diff --git a/src/IntPak/CalcOmErf.f90 b/src/IntPak/CalcOmErf.f90 new file mode 100644 index 0000000..762cdb3 --- /dev/null +++ b/src/IntPak/CalcOmErf.f90 @@ -0,0 +1,39 @@ +subroutine CalcOmErf(maxm,ExpY,fG,NormYSq,Om) + +! Compute the 0^m for the long-range Coulomb operator: (00|erf(r)/r|00)^m + + implicit none + +! Input variables + + integer,intent(in) :: maxm + double precision,intent(in) :: ExpY,fG,NormYSq + +! Local variables + + integer :: m + double precision :: pi,t + double precision,allocatable :: Fm(:) + +! Output variables + + double precision,intent(inout):: Om (0:maxm) + + allocate(Fm(0:maxm)) + + pi = 4d0*atan(1d0) + +! Campute generalized Boys functions + + t = fG*NormYSq + call CalcBoysF(maxm,t,Fm) + +! Compute (00|00)^m + + do m=0,maxm + Om(m) = (2d0/sqrt(pi))*sqrt(fG)*(fG/ExpY)**m*Fm(m) + enddo + + deallocate(Fm) + +end subroutine CalcOmErf diff --git a/src/IntPak/CalcOmNuc.f90 b/src/IntPak/CalcOmNuc.f90 new file mode 100644 index 0000000..dd953e9 --- /dev/null +++ b/src/IntPak/CalcOmNuc.f90 @@ -0,0 +1,40 @@ +subroutine CalcOmNuc(maxm,ExpPQi,NormPQSq,Om) + +! Compute (0|V|0)^m + + implicit none + +! Input variables + + integer,intent(in) :: maxm + double precision,intent(in) :: ExpPQi,NormPQSq + +! Local variables + + integer :: m + double precision :: pi,dm,t + double precision,allocatable :: Fm(:) + +! Output variables + + double precision,intent(inout):: Om (0:maxm) + + allocate(Fm(0:maxm)) + + pi = 4d0*atan(1d0) + +! Campute generalized Boys functions + + t = NormPQSq/ExpPQi + call CalcBoysF(maxm,t,Fm) + +! Compute (00|00)^m + + do m=0,maxm + dm =dble(m) + Om(m) = (2d0/sqrt(pi))*(1d0/ExpPQi)**(dm+0.5d0)*Fm(m) + enddo + + deallocate(Fm) + +end subroutine CalcOmNuc diff --git a/src/IntPak/CalcOmYuk.f90 b/src/IntPak/CalcOmYuk.f90 new file mode 100644 index 0000000..3836efa --- /dev/null +++ b/src/IntPak/CalcOmYuk.f90 @@ -0,0 +1,43 @@ +subroutine CalcOmYuk(maxm,ExpG,ExpY,fG,NormYSq,Om) + +! Compute the 0^m for the screened Coulomb operator: (00|f12/r12|00)^m + + implicit none + +! Input variables + + integer,intent(in) :: maxm + double precision,intent(in) :: ExpG,ExpY,fG,NormYSq + +! Local variables + + integer :: m,k + double precision :: pi,t,dbinom + double precision,allocatable :: Fm(:) + +! Output variables + + double precision,intent(inout):: Om(0:maxm) + + allocate(Fm(0:maxm)) + + pi = 4d0*atan(1d0) + +! Campute generalized Boys functions + + t = (ExpY - fG)*NormYSq + call CalcBoysF(maxm,t,Fm) + +! Compute (00|00)^m + + do m=0,maxm + Om(m) = 0d0 + do k=0,m + Om(m) = Om(m) + dbinom(m,k)*(ExpY/ExpG)**k*Fm(k) + enddo + Om(m) = (2d0/sqrt(pi))*sqrt(ExpY)*(fG/ExpG)*exp(-fG*NormYSq)*Om(m) + enddo + + deallocate(Fm) + +end subroutine CalcOmYuk diff --git a/src/IntPak/Compute2eInt.f90 b/src/IntPak/Compute2eInt.f90 new file mode 100644 index 0000000..1c53e46 --- /dev/null +++ b/src/IntPak/Compute2eInt.f90 @@ -0,0 +1,308 @@ +subroutine Compute2eInt(debug,iType,nShell, & + ExpS,KG,DG,ExpG, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np2eInt,nSigp2eInt,nc2eInt,nSigc2eInt) + + +! Compute various two-electron integrals + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: debug + integer,intent(in) :: iType,nShell + double precision,intent(in) :: ExpS + integer,intent(in) :: KG + double precision,intent(in) :: DG(KG),ExpG(KG) + double precision,intent(in) :: CenterShell(maxShell,3) + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + logical :: chemist_notation + integer :: KBra(2),KKet(2) + double precision :: CenterBra(2,3),CenterKet(2,3) + integer :: TotAngMomBra(2),TotAngMomKet(2) + integer :: AngMomBra(2,3),AngMomKet(2,3) + integer :: nShellFunctionBra(2),nShellFunctionKet(2) + integer,allocatable :: ShellFunctionA1(:,:),ShellFunctionA2(:,:) + integer,allocatable :: ShellFunctionB1(:,:),ShellFunctionB2(:,:) + double precision :: ExpBra(2),ExpKet(2) + double precision :: DBra(2),DKet(2) + double precision :: NormCoeff + + integer :: iBasA1,iBasA2,iBasB1,iBasB2 + integer :: iShA1,iShA2,iShB1,iShB2 + integer :: iShFA1,iShFA2,iShFB1,iShFB2 + integer :: iKA1,iKA2,iKB1,iKB2 + integer :: iFile + + double precision :: p2eInt,c2eInt + double precision :: start_c2eInt,end_c2eInt,t_c2eInt + +! Output variables + + integer,intent(out) :: np2eInt,nSigp2eInt,nc2eInt,nSigc2eInt + + chemist_notation = .true. + + np2eInt = 0 + nSigp2eInt = 0 + + nc2eInt = 0 + nSigc2eInt = 0 + + iBasA1 = 0 + iBasA2 = 0 + iBasB1 = 0 + iBasB2 = 0 + +! Open file to write down integrals + + iFile = 0 + + if(iType == 1) then + +! Compute two-electron integrals over the Coulomb operator + + write(*,*) '******************************************' + write(*,*) ' Compute two-electron repulsion integrals ' + write(*,*) '******************************************' + write(*,*) + + iFile = 21 + open(unit=iFile,file='int/ERI.dat') + + elseif(iType == 2) then + +! Compute two-electron integrals over Slater geminals + + write(*,*) '****************************************' + write(*,*) ' Compute two-electron geminal integrals ' + write(*,*) '****************************************' + write(*,*) + + iFile = 22 + open(unit=iFile,file='int/F12.dat') + + elseif(iType == 3) then + +! Compute two-electron integrals over the Yukawa operator + + write(*,*) '***************************************' + write(*,*) ' Compute two-electron Yukawa integrals ' + write(*,*) '***************************************' + write(*,*) + + iFile = 23 + open(unit=iFile,file='int/Yuk.dat') + + elseif(iType == 4) then + +! Compute two-electron integrals over the long-range Coulomb operator + + write(*,*) '**************************************' + write(*,*) ' Compute long-range Coulomb integrals ' + write(*,*) '**************************************' + write(*,*) + + iFile = 24 + open(unit=iFile,file='int/Erf.dat') + + endif + +!------------------------------------------------------------------------ +! Loops over shell A1 +!------------------------------------------------------------------------ + do iShA1=1,nShell + + CenterBra(1,1) = CenterShell(iShA1,1) + CenterBra(1,2) = CenterShell(iShA1,2) + CenterBra(1,3) = CenterShell(iShA1,3) + + TotAngMomBra(1) = TotAngMomShell(iShA1) + nShellFunctionBra(1) = (TotAngMomBra(1)*TotAngMomBra(1) + 3*TotAngMomBra(1) + 2)/2 + allocate(ShellFunctionA1(1:nShellFunctionBra(1),1:3)) + call GenerateShell(TotAngMomBra(1),nShellFunctionBra(1),ShellFunctionA1) + + KBra(1) = KShell(iShA1) + + do iShFA1=1,nShellFunctionBra(1) + + iBasA1 = iBasA1 + 1 + AngMomBra(1,1) = ShellFunctionA1(iShFA1,1) + AngMomBra(1,2) = ShellFunctionA1(iShFA1,2) + AngMomBra(1,3) = ShellFunctionA1(iShFA1,3) + +!------------------------------------------------------------------------ +! Loops over shell B1 +!------------------------------------------------------------------------ + do iShB1=1,iShA1 + + CenterKet(1,1) = CenterShell(iShB1,1) + CenterKet(1,2) = CenterShell(iShB1,2) + CenterKet(1,3) = CenterShell(iShB1,3) + + TotAngMomKet(1) = TotAngMomShell(iShB1) + nShellFunctionKet(1) = (TotAngMomKet(1)*TotAngMomKet(1) + 3*TotAngMomKet(1) + 2)/2 + allocate(ShellFunctionB1(1:nShellFunctionKet(1),1:3)) + call GenerateShell(TotAngMomKet(1),nShellFunctionKet(1),ShellFunctionB1) + + KKet(1) = KShell(iShB1) + + do iShFB1=1,nShellFunctionKet(1) + + iBasB1 = iBasB1 + 1 + AngMomKet(1,1) = ShellFunctionB1(iShFB1,1) + AngMomKet(1,2) = ShellFunctionB1(iShFB1,2) + AngMomKet(1,3) = ShellFunctionB1(iShFB1,3) + +!------------------------------------------------------------------------ +! Loops over shell A2 +!------------------------------------------------------------------------ + do iShA2=1,iShA1 + + CenterBra(2,1) = CenterShell(iShA2,1) + CenterBra(2,2) = CenterShell(iShA2,2) + CenterBra(2,3) = CenterShell(iShA2,3) + + TotAngMomBra(2) = TotAngMomShell(iShA2) + nShellFunctionBra(2) = (TotAngMomBra(2)*TotAngMomBra(2) + 3*TotAngMomBra(2) + 2)/2 + allocate(ShellFunctionA2(1:nShellFunctionBra(2),1:3)) + call GenerateShell(TotAngMomBra(2),nShellFunctionBra(2),ShellFunctionA2) + + KBra(2) = KShell(iShA2) + + do iShFA2=1,nShellFunctionBra(2) + + iBasA2 = iBasA2 + 1 + AngMomBra(2,1) = ShellFunctionA2(iShFA2,1) + AngMomBra(2,2) = ShellFunctionA2(iShFA2,2) + AngMomBra(2,3) = ShellFunctionA2(iShFA2,3) + +!------------------------------------------------------------------------ +! Loops over shell B2 +!------------------------------------------------------------------------ + do iShB2=1,iShA2 + + CenterKet(2,1) = CenterShell(iShB2,1) + CenterKet(2,2) = CenterShell(iShB2,2) + CenterKet(2,3) = CenterShell(iShB2,3) + + TotAngMomKet(2) = TotAngMomShell(iShB2) + nShellFunctionKet(2) = (TotAngMomKet(2)*TotAngMomKet(2) + 3*TotAngMomKet(2) + 2)/2 + allocate(ShellFunctionB2(1:nShellFunctionKet(2),1:3)) + call GenerateShell(TotAngMomKet(2),nShellFunctionKet(2),ShellFunctionB2) + + KKet(2) = KShell(iShB2) + + do iShFB2=1,nShellFunctionKet(2) + + iBasB2 = iBasB2 + 1 + AngMomKet(2,1) = ShellFunctionB2(iShFB2,1) + AngMomKet(2,2) = ShellFunctionB2(iShFB2,2) + AngMomKet(2,3) = ShellFunctionB2(iShFB2,3) + +!------------------------------------------------------------------------ +! Loops over contraction degrees +!------------------------------------------------------------------------- + call cpu_time(start_c2eInt) + + c2eInt = 0d0 + + do iKA1=1,KBra(1) + ExpBra(1) = ExpShell(iShA1,iKA1) + DBra(1) = DShell(iShA1,iKA1)*NormCoeff(ExpBra(1),AngMomBra(1,1:3)) + do iKA2=1,KBra(2) + ExpBra(2) = ExpShell(iShA2,iKA2) + DBra(2) = DShell(iShA2,iKA2)*NormCoeff(ExpBra(2),AngMomBra(2,1:3)) + do iKB1=1,KKet(1) + ExpKet(1) = ExpShell(iShB1,iKB1) + DKet(1) = DShell(iShB1,iKB1)*NormCoeff(ExpKet(1),AngMomKet(1,1:3)) + do iKB2=1,KKet(2) + ExpKet(2) = ExpShell(iShB2,iKB2) + DKet(2) = DShell(iShB2,iKB2)*NormCoeff(ExpKet(2),AngMomKet(2,1:3)) + + call S2eInt(debug,iType,np2eInt,nSigp2eInt, & + ExpS,KG,DG,ExpG, & + ExpBra,CenterBra,AngMomBra, & + ExpKet,CenterKet,AngMomKet, & + p2eInt) + + c2eInt = c2eInt + DBra(1)*DBra(2)*DKet(1)*DKet(2)*p2eInt + + enddo + enddo + enddo + enddo + call cpu_time(end_c2eInt) + + nc2eInt = nc2eInt + 1 + + if(abs(c2eInt) > 1d-15) then + + nSigc2eInt = nSigc2eInt + 1 + t_c2eInt = end_c2eInt - start_c2eInt + + if(chemist_notation) then + + write(iFile,'(I6,I6,I6,I6,F20.15)') iBasA1,iBasB1,iBasA2,iBasB2,c2eInt + + if(debug) then + write(*,'(A10,1X,F16.10,1X,I6,1X,I6,1X,I6,1X,I6)') & + '(a1b1|a2b2) = ',c2eInt,iBasA1,iBasB1,iBasA2,iBasB2 + endif + + else + + write(iFile,'(I6,I6,I6,I6,F20.15)') iBasA1,iBasA2,iBasB1,iBasB2,c2eInt + + if(debug) then + write(*,'(A10,1X,F16.10,1X,I6,1X,I6,1X,I6,1X,I6)') & + ' = ',c2eInt,iBasA1,iBasA2,iBasB1,iBasB2 + endif + + endif + endif + +!------------------------------------------------------------------------ +! End loops over contraction degrees +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionB2) + enddo + iBasB2 = 0 +!------------------------------------------------------------------------ +! End loops over shell B2 +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionA2) + enddo + iBasA2 = 0 +!------------------------------------------------------------------------ +! End loops over shell A2 +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionB1) + enddo + iBasB1 = 0 +!------------------------------------------------------------------------ +! End loops over shell B1 +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionA1) + enddo + iBasA1 = 0 +!------------------------------------------------------------------------ +! End loops over shell A1 +!------------------------------------------------------------------------ + write(*,*) + +! Close files to write down integrals + + close(unit=iFile) + +end subroutine Compute2eInt diff --git a/src/IntPak/Compute3eInt.f90 b/src/IntPak/Compute3eInt.f90 new file mode 100644 index 0000000..c787602 --- /dev/null +++ b/src/IntPak/Compute3eInt.f90 @@ -0,0 +1,328 @@ +subroutine Compute3eInt(debug,iType,nShell, & + ExpS,KG,DG,ExpG, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np3eInt,nSigp3eInt,nc3eInt,nSigc3eInt) + + +! Compute long-range Coulomb integrals + + implicit none + include 'parameters.h' + + +! Input variables + + logical,intent(in) :: debug + integer,intent(in) :: iType,nShell + double precision,intent(in) :: ExpS + integer,intent(in) :: KG + double precision,intent(in) :: DG(KG),ExpG(KG) + double precision,intent(in) :: CenterShell(maxShell,3) + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + integer :: KBra(3),KKet(3) + double precision :: CenterBra(3,3),CenterKet(3,3) + integer :: TotAngMomBra(3),TotAngMomKet(3) + integer :: AngMomBra(3,3),AngMomKet(3,3) + integer :: nShellFunctionBra(3),nShellFunctionKet(3) + integer,allocatable :: ShellFunctionA1(:,:),ShellFunctionA2(:,:),ShellFunctionA3(:,:) + integer,allocatable :: ShellFunctionB1(:,:),ShellFunctionB2(:,:),ShellFunctionB3(:,:) + double precision :: ExpBra(3),ExpKet(3) + double precision :: DBra(3),DKet(3) + double precision :: NormCoeff + + integer :: iBasA1,iBasA2,iBasA3,iBasB1,iBasB2,iBasB3 + integer :: iShA1,iShA2,iShA3,iShB1,iShB2,iShB3 + integer :: iShFA1,iShFA2,iShFA3,iShFB1,iShFB2,iShFB3 + integer :: iKA1,iKA2,iKA3,iKB1,iKB2,iKB3 + integer :: iFile + + double precision :: p3eInt,c3eInt + double precision :: start_c3eInt,end_c3eInt,t_c3eInt + +! Output variables + + integer,intent(out) :: np3eInt,nSigp3eInt,nc3eInt,nSigc3eInt + +! Compute three-electron integrals + + write(*,*) '**********************************' + write(*,*) ' Compute three-electron integrals ' + write(*,*) '**********************************' + write(*,*) + + np3eInt = 0 + nSigp3eInt = 0 + + nc3eInt = 0 + nSigc3eInt = 0 + + iBasA1 = 0 + iBasA2 = 0 + iBasA3 = 0 + iBasB1 = 0 + iBasB2 = 0 + iBasB3 = 0 + +! Open file to write down integrals + + iFile = 0 + + if(iType == 1) then + iFile = 31 + open(unit=iFile,file='int/3eInt_Type1.dat') + elseif(iType == 2) then + iFile = 32 + open(unit=iFile,file='int/3eInt_Type2.dat') + elseif(iType == 3) then + iFile = 33 + open(unit=iFile,file='int/3eInt_Type3.dat') + endif + +!------------------------------------------------------------------------ +! Loops over shell A1 +!------------------------------------------------------------------------ + do iShA1=1,nShell + + CenterBra(1,1) = CenterShell(iShA1,1) + CenterBra(1,2) = CenterShell(iShA1,2) + CenterBra(1,3) = CenterShell(iShA1,3) + + TotAngMomBra(1) = TotAngMomShell(iShA1) + nShellFunctionBra(1) = (TotAngMomBra(1)*TotAngMomBra(1) + 3*TotAngMomBra(1) + 2)/2 + allocate(ShellFunctionA1(1:nShellFunctionBra(1),1:3)) + call GenerateShell(TotAngMomBra(1),nShellFunctionBra(1),ShellFunctionA1) + + KBra(1) = KShell(iShA1) + + do iShFA1=1,nShellFunctionBra(1) + + iBasA1 = iBasA1 + 1 + AngMomBra(1,1) = ShellFunctionA1(iShFA1,1) + AngMomBra(1,2) = ShellFunctionA1(iShFA1,2) + AngMomBra(1,3) = ShellFunctionA1(iShFA1,3) + +!------------------------------------------------------------------------ +! Loops over shell A2 +!------------------------------------------------------------------------ + do iShA2=1,nShell + + CenterBra(2,1) = CenterShell(iShA2,1) + CenterBra(2,2) = CenterShell(iShA2,2) + CenterBra(2,3) = CenterShell(iShA2,3) + + TotAngMomBra(2) = TotAngMomShell(iShA2) + nShellFunctionBra(2) = (TotAngMomBra(2)*TotAngMomBra(2) + 3*TotAngMomBra(2) + 2)/2 + allocate(ShellFunctionA2(1:nShellFunctionBra(2),1:3)) + call GenerateShell(TotAngMomBra(2),nShellFunctionBra(2),ShellFunctionA2) + + KBra(2) = KShell(iShA2) + + do iShFA2=1,nShellFunctionBra(2) + + iBasA2 = iBasA2 + 1 + AngMomBra(2,1) = ShellFunctionA2(iShFA2,1) + AngMomBra(2,2) = ShellFunctionA2(iShFA2,2) + AngMomBra(2,3) = ShellFunctionA2(iShFA2,3) + +!------------------------------------------------------------------------ +! Loops over shell A3 +!------------------------------------------------------------------------ + do iShA3=1,nShell + + CenterBra(3,1) = CenterShell(iShA3,1) + CenterBra(3,2) = CenterShell(iShA3,2) + CenterBra(3,3) = CenterShell(iShA3,3) + + TotAngMomBra(3) = TotAngMomShell(iShA3) + nShellFunctionBra(3) = (TotAngMomBra(3)*TotAngMomBra(3) + 3*TotAngMomBra(3) + 2)/2 + allocate(ShellFunctionA3(1:nShellFunctionBra(3),1:3)) + call GenerateShell(TotAngMomBra(3),nShellFunctionBra(3),ShellFunctionA3) + + KBra(3) = KShell(iShA3) + + do iShFA3=1,nShellFunctionBra(3) + + iBasA3 = iBasA3 + 1 + AngMomBra(3,1) = ShellFunctionA3(iShFA3,1) + AngMomBra(3,2) = ShellFunctionA3(iShFA3,2) + AngMomBra(3,3) = ShellFunctionA3(iShFA3,3) + +!------------------------------------------------------------------------ +! Loops over shell B1 +!------------------------------------------------------------------------ + do iShB1=1,nShell + + CenterKet(1,1) = CenterShell(iShB1,1) + CenterKet(1,2) = CenterShell(iShB1,2) + CenterKet(1,3) = CenterShell(iShB1,3) + + TotAngMomKet(1) = TotAngMomShell(iShB1) + nShellFunctionKet(1) = (TotAngMomKet(1)*TotAngMomKet(1) + 3*TotAngMomKet(1) + 2)/2 + allocate(ShellFunctionB1(1:nShellFunctionKet(1),1:3)) + call GenerateShell(TotAngMomKet(1),nShellFunctionKet(1),ShellFunctionB1) + + KKet(1) = KShell(iShB1) + + do iShFB1=1,nShellFunctionKet(1) + + iBasB1 = iBasB1 + 1 + AngMomKet(1,1) = ShellFunctionB1(iShFB1,1) + AngMomKet(1,2) = ShellFunctionB1(iShFB1,2) + AngMomKet(1,3) = ShellFunctionB1(iShFB1,3) + +!------------------------------------------------------------------------ +! Loops over shell B2 +!------------------------------------------------------------------------ + do iShB2=1,nShell + + CenterKet(2,1) = CenterShell(iShB2,1) + CenterKet(2,2) = CenterShell(iShB2,2) + CenterKet(2,3) = CenterShell(iShB2,3) + + TotAngMomKet(2) = TotAngMomShell(iShB2) + nShellFunctionKet(2) = (TotAngMomKet(2)*TotAngMomKet(2) + 3*TotAngMomKet(2) + 2)/2 + allocate(ShellFunctionB2(1:nShellFunctionKet(2),1:3)) + call GenerateShell(TotAngMomKet(2),nShellFunctionKet(2),ShellFunctionB2) + + KKet(2) = KShell(iShB2) + + do iShFB2=1,nShellFunctionKet(2) + + iBasB2 = iBasB2 + 1 + AngMomKet(2,1) = ShellFunctionB2(iShFB2,1) + AngMomKet(2,2) = ShellFunctionB2(iShFB2,2) + AngMomKet(2,3) = ShellFunctionB2(iShFB2,3) + +!------------------------------------------------------------------------ +! Loops over shell B3 +!------------------------------------------------------------------------ + do iShB3=1,nShell + + CenterKet(3,1) = CenterShell(iShB3,1) + CenterKet(3,2) = CenterShell(iShB3,2) + CenterKet(3,3) = CenterShell(iShB3,3) + + TotAngMomKet(3) = TotAngMomShell(iShB3) + nShellFunctionKet(3) = (TotAngMomKet(3)*TotAngMomKet(3) + 3*TotAngMomKet(3) + 2)/2 + allocate(ShellFunctionB3(1:nShellFunctionKet(3),1:3)) + call GenerateShell(TotAngMomKet(3),nShellFunctionKet(3),ShellFunctionB3) + + KKet(3) = KShell(iShB3) + + do iShFB3=1,nShellFunctionKet(3) + + iBasB3 = iBasB3 + 1 + AngMomKet(3,1) = ShellFunctionB3(iShFB3,1) + AngMomKet(3,2) = ShellFunctionB3(iShFB3,2) + AngMomKet(3,3) = ShellFunctionB3(iShFB3,3) + +!------------------------------------------------------------------------ +! Loops over contraction degrees +!------------------------------------------------------------------------- + call cpu_time(start_c3eInt) + + c3eInt = 0d0 + + do iKA1=1,KBra(1) + ExpBra(1) = ExpShell(iShA1,iKA1) + DBra(1) = DShell(iShA1,iKA1)*NormCoeff(ExpBra(1),AngMomBra(1,1:3)) + do iKA2=1,KBra(2) + ExpBra(2) = ExpShell(iShA2,iKA2) + DBra(2) = DShell(iShA2,iKA2)*NormCoeff(ExpBra(2),AngMomBra(2,1:3)) + do iKA3=1,KBra(3) + ExpBra(3) = ExpShell(iShA3,iKA3) + DBra(3) = DShell(iShA3,iKA3)*NormCoeff(ExpBra(3),AngMomBra(3,1:3)) + do iKB1=1,KKet(1) + ExpKet(1) = ExpShell(iShB1,iKB1) + DKet(1) = DShell(iShB1,iKB1)*NormCoeff(ExpKet(1),AngMomKet(1,1:3)) + do iKB2=1,KKet(2) + ExpKet(2) = ExpShell(iShB2,iKB2) + DKet(2) = DShell(iShB2,iKB2)*NormCoeff(ExpKet(2),AngMomKet(2,1:3)) + do iKB3=1,KKet(3) + ExpKet(3) = ExpShell(iShB3,iKB3) + DKet(3) = DShell(iShB3,iKB3)*NormCoeff(ExpKet(3),AngMomKet(3,1:3)) + + call S3eInt(debug,iType,np3eInt,nSigp3eInt, & + ExpS,KG,DG,ExpG, & + ExpBra,CenterBra,AngMomBra, & + ExpKet,CenterKet,AngMomKet, & + p3eInt) + + c3eInt = c3eInt + DBra(1)*DBra(2)*DBra(3)*DKet(1)*DKet(2)*DKet(3)*p3eInt + + enddo + enddo + enddo + enddo + enddo + enddo + call cpu_time(end_c3eInt) + + nc3eInt = nc3eInt + 1 + if(abs(c3eInt) > 1d-15) then + nSigc3eInt = nSigc3eInt + 1 + t_c3eInt = end_c3eInt - start_c3eInt + write(iFile,'(F20.15,I6,I6,I6,I6,I6,I6)') & + c3eInt,iBasA1,iBasA2,iBasA3,iBasB1,iBasB2,iBasB3 + if(.true.) then + write(*,'(A15,1X,F16.10,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6)') & + '(a1a2a3|b1b2b3) = ',c3eInt,iBasA1,iBasA2,iBasA3,iBasB1,iBasB2,iBasB3 + endif + endif + +!------------------------------------------------------------------------ +! End loops over contraction degrees +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionB3) + enddo + iBasB3 = 0 +!------------------------------------------------------------------------ +! End loops over shell B3 +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionB2) + enddo + iBasB2 = 0 +!------------------------------------------------------------------------ +! End loops over shell B2 +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionB1) + enddo + iBasB1 = 0 +!------------------------------------------------------------------------ +! End loops over shell B1 +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionA3) + enddo + iBasA3 = 0 +!------------------------------------------------------------------------ +! End loops over shell A3 +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionA2) + enddo + iBasA2 = 0 +!------------------------------------------------------------------------ +! End loops over shell A2 +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionA1) + enddo + iBasA1 = 0 +!------------------------------------------------------------------------ +! End loops over shell A1 +!------------------------------------------------------------------------ + write(*,*) + +! Close files to write down integrals + + close(unit=iFile) + +end subroutine Compute3eInt diff --git a/src/IntPak/Compute4eInt.f90 b/src/IntPak/Compute4eInt.f90 new file mode 100644 index 0000000..0f21fef --- /dev/null +++ b/src/IntPak/Compute4eInt.f90 @@ -0,0 +1,246 @@ +subroutine Compute4eInt(debug,nEl,iType,nShell,ExpS, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + npErf,nSigpErf,ncErf,nSigcErf) + + +! Compute long-range Coulomb integrals + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: debug + integer,intent(in) :: nEl,iType,nShell + double precision :: ExpS + double precision,intent(in) :: CenterShell(maxShell,3) + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + integer :: KA,KB,KC,KD + double precision :: CenterA(3),CenterB(3),CenterC(3),CenterD(3) + integer :: TotAngMomA,TotAngMomB,TotAngMomC,TotAngMomD + integer :: AngMomA(3),AngMomB(3),AngMomC(3),AngMomD(3) + integer :: nShellFunctionA,nShellFunctionB, & + nShellFunctionC,nShellFunctionD + integer,allocatable :: ShellFunctionA(:,:),ShellFunctionB(:,:), & + ShellFunctionC(:,:),ShellFunctionD(:,:) + double precision :: ExpA,ExpB,ExpC,ExpD + double precision,allocatable :: DA,DB,DC,DD + double precision :: NormCoeff + + integer :: iBasA,iBasB,iBasC,iBasD + integer :: iShA,iShB,iShC,iShD + integer :: iShFA,iShFB,iShFC,iShFD + integer :: iKA,iKB,iKC,iKD + + double precision :: pErf,cErf + double precision :: start_cErf,end_cErf,t_cErf + +! Output variables + + integer,intent(out) :: npErf,nSigpErf,ncErf,nSigcErf + +! Compute two-electron integrals over long-range Coulomb operator + + write(*,*) '**********************************' + write(*,*) ' Compute three-electron integrals ' + write(*,*) '**********************************' + write(*,*) + + npErf = 0 + nSigpErf = 0 + + ncErf = 0 + nSigcErf = 0 + + iBasA = 0 + iBasB = 0 + iBasC = 0 + iBasD = 0 + +! Open file to write down integrals + + open(unit=41,file='int/4eInt_Type1.dat') + +!------------------------------------------------------------------------ +! Loops over shell A +!------------------------------------------------------------------------ + do iShA=1,nShell + + CenterA(1) = CenterShell(iShA,1) + CenterA(2) = CenterShell(iShA,2) + CenterA(3) = CenterShell(iShA,3) + + TotAngMomA = TotAngMomShell(iShA) + nShellFunctionA = (TotAngMomA*TotAngMomA + 3*TotAngMomA + 2)/2 + allocate(ShellFunctionA(1:nShellFunctionA,1:3)) + call GenerateShell(TotAngMomA,nShellFunctionA,ShellFunctionA) + + KA = KShell(iShA) + + do iShFA=1,nShellFunctionA + + iBasA = iBasA + 1 + AngMomA(1) = ShellFunctionA(iShFA,1) + AngMomA(2) = ShellFunctionA(iShFA,2) + AngMomA(3) = ShellFunctionA(iShFA,3) + +!------------------------------------------------------------------------ +! Loops over shell B +!------------------------------------------------------------------------ + do iShB=1,iShA + + CenterB(1) = CenterShell(iShB,1) + CenterB(2) = CenterShell(iShB,2) + CenterB(3) = CenterShell(iShB,3) + + TotAngMomB = TotAngMomShell(iShB) + nShellFunctionB = (TotAngMomB*TotAngMomB + 3*TotAngMomB + 2)/2 + allocate(ShellFunctionB(1:nShellFunctionB,1:3)) + call GenerateShell(TotAngMomB,nShellFunctionB,ShellFunctionB) + + KB = KShell(iShB) + + do iShFB=1,nShellFunctionB + + iBasB = iBasB + 1 + AngMomB(1) = ShellFunctionB(iShFB,1) + AngMomB(2) = ShellFunctionB(iShFB,2) + AngMomB(3) = ShellFunctionB(iShFB,3) + +!------------------------------------------------------------------------ +! Loops over shell C +!------------------------------------------------------------------------ + do iShC=1,iShA + + CenterC(1) = CenterShell(iShC,1) + CenterC(2) = CenterShell(iShC,2) + CenterC(3) = CenterShell(iShC,3) + + TotAngMomC = TotAngMomShell(iShC) + nShellFunctionC = (TotAngMomC*TotAngMomC + 3*TotAngMomC + 2)/2 + allocate(ShellFunctionC(1:nShellFunctionC,1:3)) + call GenerateShell(TotAngMomC,nShellFunctionC,ShellFunctionC) + + KC = KShell(iShC) + + do iShFC=1,nShellFunctionC + + iBasC = iBasC + 1 + AngMomC(1) = ShellFunctionC(iShFC,1) + AngMomC(2) = ShellFunctionC(iShFC,2) + AngMomC(3) = ShellFunctionC(iShFC,3) + +!------------------------------------------------------------------------ +! Loops over shell D +!------------------------------------------------------------------------ + do iShD=1,iShC + + CenterD(1) = CenterShell(iShD,1) + CenterD(2) = CenterShell(iShD,2) + CenterD(3) = CenterShell(iShD,3) + + TotAngMomD = TotAngMomShell(iShD) + nShellFunctionD = (TotAngMomD*TotAngMomD + 3*TotAngMomD + 2)/2 + allocate(ShellFunctionD(1:nShellFunctionD,1:3)) + call GenerateShell(TotAngMomD,nShellFunctionD,ShellFunctionD) + + KD = KShell(iShD) + + do iShFD=1,nShellFunctionD + + iBasD = iBasD + 1 + AngMomD(1) = ShellFunctionD(iShFD,1) + AngMomD(2) = ShellFunctionD(iShFD,2) + AngMomD(3) = ShellFunctionD(iShFD,3) + +!------------------------------------------------------------------------ +! Loops over contraction degrees +!------------------------------------------------------------------------- + call cpu_time(start_cErf) + + cErf = 0d0 + + do iKA=1,KA + ExpA = ExpShell(iShA,iKA) + DA = DShell(iShA,iKA)*NormCoeff(ExpA,AngMomA) + do iKB=1,KB + ExpB = ExpShell(iShB,iKB) + DB = DShell(iShB,iKB)*NormCoeff(ExpB,AngMomB) + do iKC=1,KC + ExpC = ExpShell(iShC,iKC) + DC = DShell(iShC,iKC)*NormCoeff(ExpC,AngMomC) + do iKD=1,KD + ExpD = ExpShell(iShD,iKD) + DD = DShell(iShD,iKD)*NormCoeff(ExpD,AngMomD) + +! Erf module +! call ErfInt(debug,npErf,nSigpErf, & +! ExpS, & +! ExpA,CenterA,AngMomA, & +! ExpB,CenterB,AngMomB, & +! ExpC,CenterC,AngMomC, & +! ExpD,CenterD,AngMomD, & +! pErf) + +! cErf = cErf + DA*DB*DC*DD*pErf + + enddo + enddo + enddo + enddo + call cpu_time(end_cErf) + + ncErf = ncErf + 1 + if(abs(cErf) > 1d-15) then + nSigcErf = nSigcErf + 1 + t_cErf = end_cErf - start_cErf + write(41,'(F20.15,I6,I6,I6,I6)') & + cErf,iBasA,iBasB,iBasC,iBasD + if(debug) then + write(*,'(A10,1X,F16.10,1X,I6,1X,I6,1X,I6,1X,I6)') & + '(ab|erf(r)/r|cd) = ',cErf,iBasA,iBasB,iBasC,iBasD + endif + endif + +!------------------------------------------------------------------------ +! End loops over contraction degrees +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionD) + enddo + iBasD = 0 +!------------------------------------------------------------------------ +! End loops over shell D +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionC) + enddo + iBasC = 0 +!------------------------------------------------------------------------ +! End loops over shell C +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionB) + enddo + iBasB = 0 +!------------------------------------------------------------------------ +! End loops over shell B +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionA) + enddo + iBasA = 0 +!------------------------------------------------------------------------ +! End loops over shell A +!------------------------------------------------------------------------ + write(*,*) + +! Close files to write down integrals + + close(unit=41) + +end subroutine Compute4eInt diff --git a/src/IntPak/ComputeKin.f90 b/src/IntPak/ComputeKin.f90 new file mode 100644 index 0000000..2a9fd0c --- /dev/null +++ b/src/IntPak/ComputeKin.f90 @@ -0,0 +1,166 @@ +subroutine ComputeKin(debug,nShell, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + npKin,nSigpKin,ncKin,nSigcKin) + + +! Compute one-electron kinetic integrals + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: debug + integer,intent(in) :: nShell + double precision,intent(in) :: CenterShell(maxShell,3) + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + integer :: KA,KB + double precision :: CenterA(3),CenterB(3) + integer :: TotAngMomA,TotAngMomB + integer :: AngMomA(3),AngMomB(3) + integer :: nShellFunctionA,nShellFunctionB + integer,allocatable :: ShellFunctionA(:,:),ShellFunctionB(:,:) + double precision :: ExpA,ExpB + double precision,allocatable :: DA,DB + double precision :: NormCoeff + + integer :: iBasA,iBasB + integer :: iShA,iShB + integer :: iShFA,iShFB + integer :: iKA,iKB + + double precision :: pKin,cKin + double precision :: start_cKin,end_cKin,t_cKin + +! Output variables + + integer,intent(out) :: npKin,nSigpKin,ncKin,nSigcKin + +! Compute one-electron integrals + + write(*,*) '****************************************' + write(*,*) ' Compute one-electron kinetic integrals ' + write(*,*) '****************************************' + write(*,*) + + npKin = 0 + nSigpKin = 0 + + ncKin = 0 + nSigcKin = 0 + + iBasA = 0 + iBasB = 0 + +! Open file to write down integrals + + open(unit=9,file='int/Kin.dat') + +!------------------------------------------------------------------------ +! Loops over shell A +!------------------------------------------------------------------------ + do iShA=1,nShell + + CenterA(1) = CenterShell(iShA,1) + CenterA(2) = CenterShell(iShA,2) + CenterA(3) = CenterShell(iShA,3) + + TotAngMomA = TotAngMomShell(iShA) + nShellFunctionA = (TotAngMomA*TotAngMomA + 3*TotAngMomA + 2)/2 + allocate(ShellFunctionA(1:nShellFunctionA,1:3)) + call GenerateShell(TotAngMomA,nShellFunctionA,ShellFunctionA) + + KA = KShell(iShA) + + do iShFA=1,nShellFunctionA + + iBasA = iBasA + 1 + AngMomA(1) = ShellFunctionA(iShFA,1) + AngMomA(2) = ShellFunctionA(iShFA,2) + AngMomA(3) = ShellFunctionA(iShFA,3) + +!------------------------------------------------------------------------ +! Loops over shell B +!------------------------------------------------------------------------ + do iShB=1,nShell + + CenterB(1) = CenterShell(iShB,1) + CenterB(2) = CenterShell(iShB,2) + CenterB(3) = CenterShell(iShB,3) + + TotAngMomB = TotAngMomShell(iShB) + nShellFunctionB = (TotAngMomB*TotAngMomB + 3*TotAngMomB + 2)/2 + allocate(ShellFunctionB(1:nShellFunctionB,1:3)) + call GenerateShell(TotAngMomB,nShellFunctionB,ShellFunctionB) + + KB = KShell(iShB) + + do iShFB=1,nShellFunctionB + + iBasB = iBasB + 1 + AngMomB(1) = ShellFunctionB(iShFB,1) + AngMomB(2) = ShellFunctionB(iShFB,2) + AngMomB(3) = ShellFunctionB(iShFB,3) + +!------------------------------------------------------------------------ +! Loops over contraction degrees +!------------------------------------------------------------------------- + call cpu_time(start_cKin) + + cKin = 0d0 + + do iKA=1,KA + ExpA = ExpShell(iShA,iKA) + DA = DShell(iShA,iKA)*NormCoeff(ExpA,AngMomA) + do iKB=1,KB + ExpB = ExpShell(iShB,iKB) + DB = DShell(iShB,iKB)*NormCoeff(ExpB,AngMomB) + + call KinInt(npKin,nSigpKin, & + ExpA,CenterA,AngMomA, & + ExpB,CenterB,AngMomB, & + pKin) + + cKin = cKin + DA*DB*pKin + + enddo + enddo + call cpu_time(end_cKin) + + ncKin = ncKin + 1 + if(abs(cKin) > 1d-15) then + nSigcKin = nSigcKin + 1 + t_cKin = end_cKin - start_cKin + write(9,'(I6,I6,F20.15)') iBasA,iBasB,cKin + if(debug) then + write(*,'(A10,1X,F16.10,1X,I6,1X,I6)') '(a|T|b) = ',cKin,iBasA,iBasB + endif + endif +!------------------------------------------------------------------------ +! End loops over contraction degrees +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionB) + enddo + iBasB = 0 +!------------------------------------------------------------------------ +! End loops over shell B +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionA) + enddo + iBasA = 0 +!------------------------------------------------------------------------ +! End loops over shell A +!------------------------------------------------------------------------ + write(*,*) + +! Close files to write down integrals + + close(unit=9) + +end subroutine ComputeKin diff --git a/src/IntPak/ComputeNuc.f90 b/src/IntPak/ComputeNuc.f90 new file mode 100644 index 0000000..40e10f9 --- /dev/null +++ b/src/IntPak/ComputeNuc.f90 @@ -0,0 +1,189 @@ +subroutine ComputeNuc(debug,nShell, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + NAtoms,ZNuc,XYZAtoms, & + npNuc,nSigpNuc,ncNuc,nSigcNuc) + + +! Compute electron repulsion integrals + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: debug + integer,intent(in) :: nShell + double precision,intent(in) :: CenterShell(maxShell,3) + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + integer :: NAtoms + double precision :: ZNuc(NAtoms),XYZAtoms(NAtoms,3) + +! Local variables + + integer :: KA,KB + double precision :: CenterA(3),CenterB(3),CenterC(3) + integer :: TotAngMomA,TotAngMomB + integer :: AngMomA(3),AngMomB(3) + integer :: nShellFunctionA,nShellFunctionB + integer,allocatable :: ShellFunctionA(:,:),ShellFunctionB(:,:) + double precision :: ExpA,ExpB,ZC + double precision,allocatable :: DA,DB + double precision :: NormCoeff + + integer :: iBasA,iBasB + integer :: iShA,iShB,iNucC + integer :: iShFA,iShFB + integer :: iKA,iKB + + double precision :: pNuc,cNuc + double precision :: start_cNuc,end_cNuc,t_cNuc + +! Output variables + + integer,intent(out) :: npNuc,nSigpNuc,ncNuc,nSigcNuc + +! Compute one-electron nuclear attraction integrals + + write(*,*) '***************************************************' + write(*,*) ' Compute one-electron nuclear attraction integrals ' + write(*,*) '***************************************************' + write(*,*) + + npNuc = 0 + nSigpNuc = 0 + + ncNuc = 0 + nSigcNuc = 0 + + iBasA = 0 + iBasB = 0 + iNucC = 0 + +! Open file to write down integrals + + open(unit=10,file='int/Nuc.dat') + +!------------------------------------------------------------------------ +! Loops over shell A +!------------------------------------------------------------------------ + do iShA=1,nShell + + CenterA(1) = CenterShell(iShA,1) + CenterA(2) = CenterShell(iShA,2) + CenterA(3) = CenterShell(iShA,3) + + TotAngMomA = TotAngMomShell(iShA) + nShellFunctionA = (TotAngMomA*TotAngMomA + 3*TotAngMomA + 2)/2 + allocate(ShellFunctionA(1:nShellFunctionA,1:3)) + call GenerateShell(TotAngMomA,nShellFunctionA,ShellFunctionA) + + KA = KShell(iShA) + + do iShFA=1,nShellFunctionA + + iBasA = iBasA + 1 + AngMomA(1) = ShellFunctionA(iShFA,1) + AngMomA(2) = ShellFunctionA(iShFA,2) + AngMomA(3) = ShellFunctionA(iShFA,3) + +!------------------------------------------------------------------------ +! Loops over shell B +!------------------------------------------------------------------------ + do iShB=1,nShell + + CenterB(1) = CenterShell(iShB,1) + CenterB(2) = CenterShell(iShB,2) + CenterB(3) = CenterShell(iShB,3) + + TotAngMomB = TotAngMomShell(iShB) + nShellFunctionB = (TotAngMomB*TotAngMomB + 3*TotAngMomB + 2)/2 + allocate(ShellFunctionB(1:nShellFunctionB,1:3)) + call GenerateShell(TotAngMomB,nShellFunctionB,ShellFunctionB) + + KB = KShell(iShB) + + do iShFB=1,nShellFunctionB + + iBasB = iBasB + 1 + AngMomB(1) = ShellFunctionB(iShFB,1) + AngMomB(2) = ShellFunctionB(iShFB,2) + AngMomB(3) = ShellFunctionB(iShFB,3) + +!------------------------------------------------------------------------ +! Loops over nuclear centers +!------------------------------------------------------------------------ + call cpu_time(start_cNuc) + + cNuc = 0d0 + + do iNucC=1,NAtoms + + CenterC(1) = XYZAtoms(iNucC,1) + CenterC(2) = XYZAtoms(iNucC,2) + CenterC(3) = XYZAtoms(iNucC,3) + + ZC = ZNuc(iNucC) + +!------------------------------------------------------------------------ +! Loops over contraction degrees +!------------------------------------------------------------------------- + + do iKA=1,KA + ExpA = ExpShell(iShA,iKA) + DA = DShell(iShA,iKA)*NormCoeff(ExpA,AngMomA) + do iKB=1,KB + ExpB = ExpShell(iShB,iKB) + DB = DShell(iShB,iKB)*NormCoeff(ExpB,AngMomB) + + call NucInt(debug,npNuc,nSigpNuc, & + ExpA,CenterA,AngMomA, & + ExpB,CenterB,AngMomB, & + CenterC, & + pNuc) + + cNuc = cNuc - DA*DB*ZC*pNuc + + enddo + enddo +!------------------------------------------------------------------------ +! End loops over contraction degrees +!------------------------------------------------------------------------ + enddo + call cpu_time(end_cNuc) +!------------------------------------------------------------------------ +! End loops over nuclear centers C +!------------------------------------------------------------------------ + + ncNuc = ncNuc + 1 + if(abs(cNuc) > 1d-15) then + nSigcNuc = nSigcNuc + 1 + t_cNuc = end_cNuc - start_cNuc + write(10,'(I6,I6,F20.15)') iBasA,iBasB,cNuc + if(debug) then + write(*,'(A10,1X,F16.10,1X,I6,1X,I6)') '(a|V|b) = ',cNuc,iBasA,iBasB + write(*,*) + endif + endif + + enddo + deallocate(ShellFunctionB) + enddo + iBasB = 0 +!------------------------------------------------------------------------ +! End loops over shell B +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionA) + enddo + iBasA = 0 +!------------------------------------------------------------------------ +! End loops over shell A +!------------------------------------------------------------------------ + write(*,*) + +! Close files to write down integrals + + close(unit=10) + +end subroutine ComputeNuc diff --git a/src/IntPak/ComputeOv.f90 b/src/IntPak/ComputeOv.f90 new file mode 100644 index 0000000..3aceb65 --- /dev/null +++ b/src/IntPak/ComputeOv.f90 @@ -0,0 +1,170 @@ +subroutine ComputeOv(debug,NBasis,nShell, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + npOv,nSigpOv,ncOv,nSigcOv,S) + + +! Compute one-electron overlap integrals + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: debug + integer,intent(in) :: NBasis,nShell + double precision,intent(in) :: CenterShell(maxShell,3) + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + integer :: KA,KB + double precision :: CenterA(3),CenterB(3) + integer :: TotAngMomA,TotAngMomB + integer :: AngMomA(3),AngMomB(3) + integer :: nShellFunctionA,nShellFunctionB + integer,allocatable :: ShellFunctionA(:,:),ShellFunctionB(:,:) + double precision :: ExpA,ExpB + double precision,allocatable :: DA,DB + double precision :: NormCoeff + + integer :: iBasA,iBasB + integer :: iShA,iShB + integer :: iShFA,iShFB + integer :: iKA,iKB + + double precision :: pOv,cOv + double precision :: start_cOv,end_cOv,t_cOv + +! Output variables + + integer,intent(out) :: npOv,nSigpOv,ncOv,nSigcOv + double precision,intent(out) :: S(NBasis,NBasis) + + +! Compute one-electron integrals + + write(*,*) '****************************************' + write(*,*) ' Compute one-electron overlap integrals ' + write(*,*) '****************************************' + write(*,*) + + npOv = 0 + nSigpOv = 0 + + ncOv = 0 + nSigcOv = 0 + + iBasA = 0 + iBasB = 0 + +! Open file to write down integrals + + open(unit=8,file='int/Ov.dat') + +!------------------------------------------------------------------------ +! Loops over shell A +!------------------------------------------------------------------------ + do iShA=1,nShell + + CenterA(1) = CenterShell(iShA,1) + CenterA(2) = CenterShell(iShA,2) + CenterA(3) = CenterShell(iShA,3) + + TotAngMomA = TotAngMomShell(iShA) + nShellFunctionA = (TotAngMomA*TotAngMomA + 3*TotAngMomA + 2)/2 + allocate(ShellFunctionA(1:nShellFunctionA,1:3)) + call GenerateShell(TotAngMomA,nShellFunctionA,ShellFunctionA) + + KA = KShell(iShA) + + do iShFA=1,nShellFunctionA + + iBasA = iBasA + 1 + AngMomA(1) = ShellFunctionA(iShFA,1) + AngMomA(2) = ShellFunctionA(iShFA,2) + AngMomA(3) = ShellFunctionA(iShFA,3) + +!------------------------------------------------------------------------ +! Loops over shell B +!------------------------------------------------------------------------ + do iShB=1,nShell + + CenterB(1) = CenterShell(iShB,1) + CenterB(2) = CenterShell(iShB,2) + CenterB(3) = CenterShell(iShB,3) + + TotAngMomB = TotAngMomShell(iShB) + nShellFunctionB = (TotAngMomB*TotAngMomB + 3*TotAngMomB + 2)/2 + allocate(ShellFunctionB(1:nShellFunctionB,1:3)) + call GenerateShell(TotAngMomB,nShellFunctionB,ShellFunctionB) + + KB = KShell(iShB) + + do iShFB=1,nShellFunctionB + + iBasB = iBasB + 1 + AngMomB(1) = ShellFunctionB(iShFB,1) + AngMomB(2) = ShellFunctionB(iShFB,2) + AngMomB(3) = ShellFunctionB(iShFB,3) + +!------------------------------------------------------------------------ +! Loops over contraction degrees +!------------------------------------------------------------------------- + call cpu_time(start_cOv) + + cOv = 0d0 + + do iKA=1,KA + ExpA = ExpShell(iShA,iKA) + DA = DShell(iShA,iKA)*NormCoeff(ExpA,AngMomA) + do iKB=1,KB + ExpB = ExpShell(iShB,iKB) + DB = DShell(iShB,iKB)*NormCoeff(ExpB,AngMomB) + + call OvInt(npOv,nSigpOv, & + ExpA,CenterA,AngMomA, & + ExpB,CenterB,AngMomB, & + pOv) + + cOv = cOv + DA*DB*pOv + + enddo + enddo + call cpu_time(end_cOv) + + ncOv = ncOv + 1 + S(iBasA,iBasB) = cOv + if(abs(cOv) > 1d-15) then + nSigcOv = nSigcOv + 1 + t_cOv = end_cOv - start_cOv + write(8,'(I6,I6,F20.15)') iBasA,iBasB,cOv + if(debug) then + write(*,'(A10,1X,F16.10,1X,I6,1X,I6)') '(a|b) = ',cOv,iBasA,iBasB + endif + endif + +!------------------------------------------------------------------------ +! End loops over contraction degrees +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionB) + enddo + iBasB = 0 +!------------------------------------------------------------------------ +! End loops over shell B +!------------------------------------------------------------------------ + enddo + deallocate(ShellFunctionA) + enddo + iBasA = 0 +!------------------------------------------------------------------------ +! End loops over shell A +!------------------------------------------------------------------------ + write(*,*) + +! Close files to write down integrals + + close(unit=8) + +end subroutine ComputeOv diff --git a/src/IntPak/FormVRR3e.f90 b/src/IntPak/FormVRR3e.f90 new file mode 100644 index 0000000..124fbe9 --- /dev/null +++ b/src/IntPak/FormVRR3e.f90 @@ -0,0 +1,174 @@ +subroutine FormVRR3e(ExpZ,ExpG,CenterZ,DY0,DY1,D2Y0,D2Y1,delta0,delta1,Y0,Y1) + +! Form stuff we need... + + implicit none + include 'parameters.h' + + +! Input variables + + double precision,intent(in) :: ExpZ(3),ExpG(3,3) + double precision,intent(in) :: CenterZ(3,3) + +! Local variables + + integer :: i,j,k,l + double precision :: ZetaMat(3,3) + double precision :: CMat(3,3),GMat(3,3) + double precision :: Delta0Mat(3,3),Delta1Mat(3,3) + double precision :: InvDelta0Mat(3,3),InvDelta1Mat(3,3) + double precision :: CenterY(3,3,3) + double precision :: YMat(3,3),Y2Mat(3,3) + double precision :: DYMat(3,3,3),D2YMat(3,3,3,3) + double precision :: D0Mat(3,3),D1Mat(3,3) + + double precision :: KappaCross + +! Output variables + + double precision,intent(out) :: DY0(3),DY1(3),D2Y0(3,3),D2Y1(3,3) + double precision,intent(out) :: delta0,delta1,Y0,Y1 + +! Initalize arrays + + ZetaMat = 0d0 + CMat = 0d0 + GMat = 0d0 + YMat = 0d0 + Y2Mat = 0d0 + D0Mat = 0d0 + D1Mat = 0d0 + +! Form the zeta matrix Eq. (15a) + + do i=1,3 + ZetaMat(i,i) = ExpZ(i) + enddo + +! print*,'Zeta' +! call matout(3,3,ZetaMat) + +! Form the C matrix Eq. (15a) + + CMat(1,1) = 1d0 + CMat(2,2) = 1d0 + CMat(1,2) = -1d0 + CMat(2,1) = -1d0 + +! print*,'C' +! call matout(3,3,CMat) + +! Form the G matrix Eq. (15b) + + do i=1,3 + do j=1,i-1 + GMat(i,j) = - ExpG(j,i) + enddo + do j=i+1,3 + GMat(i,j) = - ExpG(i,j) + enddo + enddo + + do i=1,3 + do j=1,i-1 + GMat(i,i) = GMat(i,i) + ExpG(j,i) + enddo + do j=i+1,3 + GMat(i,i) = GMat(i,i) + ExpG(i,j) + enddo + enddo + +! print*,'G' +! call matout(3,3,GMat) + +! Form the Y and Y^2 matrices Eq. (16b) + + do i=1,3 + do j=i+1,3 + do k=1,3 + CenterY(i,j,k) = CenterZ(i,k) - CenterZ(j,k) + Y2Mat(i,j) = Y2Mat(i,j) + CenterY(i,j,k)**2 + enddo + YMat(i,j) = sqrt(Y2Mat(i,j)) + enddo + enddo + +! print*,'Y' +! call matout(3,3,YMat) + +! print*,'Y2' +! call matout(3,3,Y2Mat) + +! Form the delta0 and delta1 matrices Eq. (14) + + do i=1,3 + do j=1,3 + Delta0Mat(i,j) = ZetaMat(i,j) + GMat(i,j) + Delta1Mat(i,j) = Delta0Mat(i,j) + CMat(i,j) + enddo + enddo + +! Form the DY and D2Y matrices + + do i=1,3 + do j=1,3 + do k=1,3 + DYMat(i,j,k) = KappaCross(i,j,k)*YMat(j,k)/ExpZ(i) + do l=1,3 + D2YMat(i,j,k,l) = 0.5d0*KappaCross(i,k,l)*KappaCross(j,k,l)/(ExpZ(i)*ExpZ(j)) + enddo + enddo + enddo + enddo + +! Compute the inverse of the Delta0 and Delta1 matrices + +! InvDelta0Mat = Delta0Mat +! InvDelta1Mat = Delta1Mat + do i=1,3 + do j=1,3 + InvDelta0Mat(i,j) = Delta0Mat(i,j) + InvDelta1Mat(i,j) = Delta1Mat(i,j) + enddo + enddo +! call amove(3,3,Delta0Mat,InvDelta0Mat) +! call amove(3,3,Delta1Mat,InvDelta1Mat) + + call CalcInv3(InvDelta0Mat,delta0) + call CalcInv3(InvDelta1Mat,delta1) + +! call matout(3,3,InvDelta0Mat) +! call matout(3,3,InvDelta1Mat) +! print*, 'delta0,delta1 = ',delta0,delta1 + +! Form the Delta matrix Eq. (16a) + + do i=1,3 + do j=1,3 + do k=1,3 + do l=1,3 + D0Mat(i,j) = D0Mat(i,k) + ZetaMat(i,k)*InvDelta0Mat(k,l)*ZetaMat(l,j) + D1Mat(i,j) = D1Mat(i,k) + ZetaMat(i,k)*InvDelta1Mat(k,l)*ZetaMat(l,j) + enddo + enddo + enddo + enddo + +! Form the derivative matrices + + do i=1,3 + call CalcTrAB(3,D0Mat,D2YMat,DY0(i)) + call CalcTrAB(3,D1Mat,D2YMat,DY1(i)) + do j=1,3 + call CalcTrAB(3,D0Mat,D2YMat,D2Y0(i,j)) + call CalcTrAB(3,D1Mat,D2YMat,D2Y1(i,j)) + enddo + enddo + +! Compute Y0 and Y1 + + call CalcTrAB(3,D0Mat,Y2Mat,Y0) + call CalcTrAB(3,D1Mat,Y2Mat,Y1) + +end subroutine FormVRR3e diff --git a/src/IntPak/G2eInt.f90 b/src/IntPak/G2eInt.f90 new file mode 100644 index 0000000..bdccbd7 --- /dev/null +++ b/src/IntPak/G2eInt.f90 @@ -0,0 +1,140 @@ +function G2eInt(debug,iType, & + ExpG, & + ExpBra,CenterBra,AngMomBra, & + ExpKet,CenterKet,AngMomKet) + +! Compute recursively the primitive two-electron integral [ab|cd] + + implicit none + include 'parameters.h' + + +! Input variables + + logical,intent(in) :: debug + integer,intent(in) :: iType + double precision,intent(in) :: ExpBra(2),ExpKet(2) + double precision,intent(in) :: ExpG + double precision,intent(in) :: CenterBra(2,3),CenterKet(2,3) + integer,intent(in) :: AngMomBra(2,3),AngMomKet(2,3) + +! Local variables + + integer :: TotAngMomBra(3),TotAngMomKet(3) + double precision :: ExpZi(2),ExpY(2,2) + double precision :: CenterZ(2,3),CenterAB(2,3),CenterZA(2,3),CenterY(2,2,3) + double precision :: NormABSq(2),NormYSq(2,2) + double precision :: GAB(2) + double precision,allocatable :: Om(:) + double precision :: fG + double precision :: HRR2e,VRR2e + double precision :: a1a2b1b2 + + integer :: i,j,k,maxm + double precision :: start_Om,finish_Om,start_RR,finish_RR,t_Om,t_RR + +! Output variables + double precision :: G2eInt + +! Pre-computed shell-pair quantities + + do i=1,2 + ExpZi(i) = 1d0/(ExpBra(i) + ExpKet(i)) + enddo + + NormABSq = 0d0 + do j=1,3 + do i=1,2 + CenterZ(i,j) = (ExpBra(i)*CenterBra(i,j) + ExpKet(i)*CenterKet(i,j))*ExpZi(i) + CenterAB(i,j) = CenterBra(i,j) - CenterKet(i,j) + CenterZA(i,j) = CenterZ(i,j) - CenterBra(i,j) + NormABSq(i) = NormABSq(i) + CenterAB(i,j)**2 + enddo + enddo + + do i=1,2 + GAB(i) = (pi*ExpZi(i))**(1.5d0)*exp(-ExpBra(i)*ExpKet(i)*NormABSq(i)*ExpZi(i)) + enddo + +! Pre-computed shell-quartet quantities + + do i=1,2 + do j=1,2 + ExpY(i,j) = 1d0/(ExpZi(i) + ExpZi(j)) + enddo + enddo + + do i=1,2 + do j=1,2 + NormYSq(i,j) = 0d0 + do k=1,3 + CenterY(i,j,k) = CenterZ(i,k) - CenterZ(j,k) + NormYSq(i,j) = NormYSq(i,j) + CenterY(i,j,k)**2 + enddo + enddo + enddo + +! fG = (ExpZ(1)*ExpZ(2)*ExpG)/(ExpZ(1)*ExpZ(2) + ExpZ(1)*ExpG + ExpZ(2)*ExpG) + fG = 1d0/(ExpZi(1) + 1d0/ExpG + ExpZi(2)) + +! Total angular momemtum + + maxm = 0 + do i=1,2 + TotAngMomBra(i) = AngMomBra(i,1) + AngMomBra(i,2) + AngMomBra(i,3) + TotAngMomKet(i) = AngMomKet(i,1) + AngMomKet(i,2) + AngMomKet(i,3) + maxm = maxm + TotAngMomBra(i) + TotAngMomKet(i) + enddo + +! Pre-compute (00|00)^m + + allocate(Om(0:maxm)) + call cpu_time(start_Om) + + if(iType == 1) then + call CalcOmERI(maxm,ExpY(1,2),NormYSq(1,2),Om) + elseif(iType == 3) then + call CalcOmYuk(maxm,ExpG,ExpY(1,2),fG,NormYSq(1,2),Om) + elseif(iType == 4) then + call CalcOmErf(maxm,ExpY(1,2),fG,NormYSq(1,2),Om) + endif + + call cpu_time(finish_Om) + +! Print (00|00)^m + + if(debug) then + write(*,*) '(00|00)^m' + do i=0,maxm + write(*,*) i,Om(i) + enddo + write(*,*) + endif + +!------------------------------------------------------------------------ +! Launch reccurence relations! +!------------------------------------------------------------------------ + call cpu_time(start_RR) + + if(TotAngMomKet(1) == 0 .and. TotAngMomKet(2) == 0) then + if(TotAngMomBra(1) == 0 .and. TotAngMomBra(2) == 0) then + a1a2b1b2 = Om(0) + else + a1a2b1b2 = VRR2e(0,AngMomBra,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) + endif + else + a1a2b1b2 = HRR2e(AngMomBra,AngMomKet,maxm,Om,ExpZi,ExpY,CenterAB,CenterZA,CenterY) + endif + + call cpu_time(finish_RR) + +! Timings + + t_Om = finish_Om - start_Om + t_RR = finish_RR - start_RR + +! Print result + + G2eInt = GAB(1)*GAB(2)*a1a2b1b2 + +end function G2eInt diff --git a/src/IntPak/G3eInt.f90 b/src/IntPak/G3eInt.f90 new file mode 100644 index 0000000..e91f721 --- /dev/null +++ b/src/IntPak/G3eInt.f90 @@ -0,0 +1,124 @@ +function G3eInt(debug,iType, & + ExpG13,ExpG23, & + ExpBra,CenterBra,AngMomBra, & + ExpKet,CenterKet,AngMomKet) + +! Compute two-electron integrals over the Yukawa operator + + implicit none + include 'parameters.h' + + +! Input variables + + logical,intent(in) :: debug + integer,intent(in) :: iType + double precision,intent(in) :: ExpG13,ExpG23 + double precision,intent(in) :: ExpBra(3),ExpKet(3) + double precision,intent(in) :: CenterBra(3,3),CenterKet(3,3) + integer,intent(in) :: AngMomBra(3,3),AngMomKet(3,3) + +! Local variables + + double precision :: ExpG(3,3) + integer :: TotAngMomBra(3),TotAngMomKet(3) + double precision :: ExpZ(3) + double precision :: CenterZ(3,3),CenterAB(3,3),CenterZA(3,3) + double precision :: NormABSq(3) + double precision :: GAB(3) + double precision,allocatable :: Om(:) + double precision :: HRR3e,VRR3e + + double precision :: DY0(3),DY1(3),D2Y0(3,3),D2Y1(3,3) + double precision :: delta0,delta1,Y0,Y1 + + integer :: i,j,maxm + double precision :: start_Om,finish_Om,t_Om,start_RR,finish_RR,t_RR + double precision :: a1a2a3b1b2b3 + +! Output variables + double precision :: G3eInt + +! Gaussian geminal exponents + + ExpG = 0d0 + ExpG(1,3) = ExpG13 + ExpG(2,3) = ExpG23 + +! Pre-computed quantities for shell-pair + + do i=1,3 + ExpZ(i) = ExpBra(i) + ExpKet(i) + enddo + + NormABSq = 0d0 + do i=1,3 + do j=1,3 + CenterZ(i,j) = (ExpBra(i)*CenterBra(i,j) + ExpKet(i)*CenterKet(i,j))/ExpZ(i) + CenterAB(i,j) = CenterBra(i,j) - CenterKet(i,j) + CenterZA(i,j) = CenterZ(i,j) - CenterBra(i,j) + NormABSq(i) = NormABSq(i) + CenterAB(i,j)**2 + enddo + enddo + + do i=1,3 + GAB(i) = (pi/ExpZ(i))**(1.5d0)*exp(-ExpBra(i)*ExpKet(i)*NormABSq(i)/ExpZ(i)) + enddo + +! Pre-computed shell-sextet quantities + + call FormVRR3e(ExpZ,ExpG,CenterZ,DY0,DY1,D2Y0,D2Y1,delta0,delta1,Y0,Y1) + +! Total angular momemtum + + maxm = 0 + do i=1,3 + TotAngMomBra(i) = AngMomBra(i,1) + AngMomBra(i,2) + AngMomBra(i,3) + TotAngMomKet(i) = AngMomKet(i,1) + AngMomKet(i,2) + AngMomKet(i,3) + maxm = maxm + TotAngMomBra(i) + TotAngMomKet(i) + enddo + +! Pre-compute (000|000)^m + + allocate(Om(0:maxm)) + call cpu_time(start_Om) + call CalcOm3e(maxm,delta0,delta1,Y0,Y1,Om) + call cpu_time(finish_Om) + +! Print (000|000)^m + + if(.false.) then + write(*,*) '(000|000)^m' + do i=0,maxm + write(*,*) i,Om(i) + enddo + write(*,*) + endif + +!------------------------------------------------------------------------ +! Launch reccurence relations! +!------------------------------------------------------------------------ + call cpu_time(start_RR) + if(TotAngMomKet(1) == 0 .and. TotAngMomKet(2) == 0 .and. TotAngMomKet(3) == 0) then + if(TotAngMomBra(1) == 0 .and. TotAngMomBra(2) == 0 .and. TotAngMomBra(3) == 0) then + a1a2a3b1b2b3 = Om(0) + else + a1a2a3b1b2b3 = VRR3e(0,AngMomBra,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) + endif + else + a1a2a3b1b2b3 = HRR3e(AngMomBra,AngMomKet,maxm,Om,ExpZ,CenterAB,CenterZA,DY0,DY1,D2Y0,D2Y1) + endif + + + call cpu_time(finish_RR) + +! Timings + + t_Om = finish_Om - start_Om + t_RR = finish_RR - start_RR + +! Print result + + G3eInt = GAB(1)*GAB(2)*GAB(3)*a1a2a3b1b2b3 + +end function G3eInt diff --git a/src/IntPak/GF12Int.f90 b/src/IntPak/GF12Int.f90 new file mode 100644 index 0000000..38be824 --- /dev/null +++ b/src/IntPak/GF12Int.f90 @@ -0,0 +1,107 @@ +function GF12Int(ExpG,ExpA,CenterA,AngMomA,ExpB,CenterB,AngMomB,ExpC,CenterC,AngMomC,ExpD,CenterD,AngMomD) + +! Compute two-electron integrals over Gaussian geminals + + implicit none + +! Input variables + + double precision,intent(in) :: ExpG + double precision,intent(in) :: ExpA,ExpB,ExpC,ExpD + double precision,intent(in) :: CenterA(3),CenterB(3),CenterC(3),CenterD(3) + integer,intent(in) :: AngMomA(3),AngMomB(3),AngMomC(3),AngMomD(3) + + +! Local variables + + double precision :: ExpAi,ExpBi,ExpCi,ExpDi,ExpGi + double precision :: ExpP,ExpQ,ExpPi,ExpQi,ExpPGQi + double precision :: CenterP(3),CenterQ(3),CenterAB(3),CenterCD(3),CenterPQSq(3),CenterRA(3),CenterRC(3) + double precision :: NormABSq,NormCDSq + double precision :: GAB,GCD + double precision :: fP,fG,fQ,gP,gG,gQ + double precision :: HRRF12 + + integer :: i + double precision :: pi + double precision :: start_RR,finish_RR,t_RR + double precision :: Gabcd(3) + +! Output variables + double precision :: GF12Int + + pi = 4d0*atan(1d0) + +! Pre-computed shell quantities + + ExpAi = 1d0/ExpA + ExpBi = 1d0/ExpB + ExpCi = 1d0/ExpC + ExpDi = 1d0/ExpD + ExpGi = 1d0/ExpG + +! Pre-computed quantities for shell-pair AB + + ExpP = ExpA + ExpB + ExpPi = 1d0/ExpP + + NormABSq = 0d0 + Do i=1,3 + CenterP(i) = (ExpA*CenterA(i) + ExpB*CenterB(i))*ExpPi + CenterAB(i) = CenterA(i) - CenterB(i) + NormABSq = NormABSq + CenterAB(i)**2 + Enddo + + GAB = (pi*ExpPi)**(1.5d0)*exp(-NormABSq/(ExpAi+ExpBi)) + +! Pre-computed quantities for shell-pair CD + + ExpQ = ExpC + ExpD + ExpQi = 1d0/ExpQ + + NormCDSq = 0d0 + Do i=1,3 + CenterQ(i) = (ExpC*CenterC(i) + ExpD*CenterD(i))*ExpQi + CenterCD(i) = CenterC(i) - CenterD(i) + NormCDSq = NormCDSq + CenterCD(i)**2 + Enddo + + GCD = (pi*ExpQi)**(1.5d0)*exp(-NormCDSq/(ExpCi+ExpDi)) + +! Pre-computed shell-quartet quantities + + ExpPGQi = ExpPi + ExpGi + ExpQi + + Do i=1,3 + CenterPQSq(i) = (CenterP(i) - CenterQ(i))**2 + Enddo + + fP = ExpPi/ExpPGQi + fG = ExpGi/ExpPGQi + fQ = ExpQi/ExpPGQi + + gP = (1d0 - fP)*0.5d0*ExpPi + gG = fP*0.5d0*expQi + gQ = (1d0 - fQ)*0.5d0*ExpQi + + do i=1,3 + CenterRA(i) = CenterP(i) - CenterA(i) + fP*(CenterQ(i) - CenterP(i)) + CenterRC(i) = CenterQ(i) - CenterC(i) + fQ*(CenterP(i) - CenterQ(i)) + enddo +!------------------------------------------------------------------------ +! Launch reccurence relations! +!------------------------------------------------------------------------ + call cpu_time(start_RR) +! Loop over cartesian directions + Do i=1,3 + Gabcd(i) = HRRF12(AngMomA(i),AngMomB(i),AngMomC(i),AngMomD(i),fG,gP,gG,gQ,ExpPGQi, & + CenterPQSq(i),CenterRA(i),CenterRC(i),CenterAB(i),CenterCD(i)) + Enddo + call cpu_time(finish_RR) + +! Print result + + GF12Int = GAB*GCD*Gabcd(1)*Gabcd(2)*Gabcd(3) + t_RR = finish_RR - start_RR + +end function GF12Int diff --git a/src/IntPak/GenerateShell.f90 b/src/IntPak/GenerateShell.f90 new file mode 100644 index 0000000..933d40b --- /dev/null +++ b/src/IntPak/GenerateShell.f90 @@ -0,0 +1,30 @@ +subroutine GenerateShell(atot,nShellFunction,ShellFunction) + + implicit none + +! Input variables + + integer,intent(in) :: atot,nShellFunction + +! Local variables + + integer :: ax,ay,az,ia + +! Output variables + + integer,intent(out) :: ShellFunction(nShellFunction,3) + + ia = 0 + do ax=atot,0,-1 + do az=0,atot + ay = atot - ax - az + if(ay >= 0) then + ia = ia + 1 + ShellFunction(ia,1) = ax + ShellFunction(ia,2) = ay + ShellFunction(ia,3) = az + endif + enddo + enddo + +end subroutine GenerateShell diff --git a/src/IntPak/HRR2e.f90 b/src/IntPak/HRR2e.f90 new file mode 100644 index 0000000..bd22a34 --- /dev/null +++ b/src/IntPak/HRR2e.f90 @@ -0,0 +1,101 @@ +recursive function HRR2e(AngMomBra,AngMomKet, & + maxm,Om,ExpZi,ExpY, & + CenterAB,CenterZA,CenterY) & + result(a1a2b1b2) + +! Horintal recurrence relations for two-electron integrals + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: AngMomBra(2,3),AngMomKet(2,3) + integer,intent(in) :: maxm + double precision,intent(in) :: Om(0:maxm),ExpZi(2),ExpY(2,2) + double precision,intent(in) :: CenterAB(2,3),CenterZA(2,3),CenterY(2,2,3) + +! Local variables + + logical :: NegAngMomKet(2) + integer :: TotAngMomBra(2),TotAngMomKet(2) + integer :: a1p(2,3),b1m(2,3),a2p(2,3),b2m(2,3) + integer :: i,j,xyz + double precision :: VRR2e + +! Output variables + + double precision :: a1a2b1b2 + + do i=1,2 + NegAngMomKet(i) = AngMomKet(i,1) < 0 .or. AngMomKet(i,2) < 0 .or. AngMomKet(i,3) < 0 + TotAngMomBra(i) = AngMomBra(i,1) + AngMomBra(i,2) + AngMomBra(i,3) + TotAngMomKet(i) = AngMomKet(i,1) + AngMomKet(i,2) + AngMomKet(i,3) + enddo + +!------------------------------------------------------------------------ +! Termination condition +!------------------------------------------------------------------------ +! if(NegAngMomKet(1) .or. NegAngMomKet(2)) then +! a1a2b1b2 = 0d0 +!------------------------------------------------------------------------ +! 1st and 2nd vertical recurrence relations: +!------------------------------------------------------------------------ +! elseif(TotAngMomKet(1) == 0 .and. TotAngMomKet(2) == 0) then + if(TotAngMomKet(1) == 0 .and. TotAngMomKet(2) == 0) then + a1a2b1b2 = VRR2e(0,AngMomBra,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) +!------------------------------------------------------------------------ +! 1st horizontal recurrence relation (2 terms): +!------------------------------------------------------------------------ + elseif(TotAngMomKet(2) == 0) then + do i=1,2 + do j=1,3 + a1p(i,j) = AngMomBra(i,j) + b1m(i,j) = AngMomKet(i,j) + enddo + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomKet(1,1) > 0) then + xyz = 1 + elseif(AngMomKet(1,2) > 0) then + xyz = 2 + elseif(AngMomKet(1,3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in HRR2e!' + endif +! End loop over cartesian directions + a1p(1,xyz) = a1p(1,xyz) + 1 + b1m(1,xyz) = b1m(1,xyz) - 1 + a1a2b1b2 = HRR2e(a1p,b1m,maxm,Om,ExpZi,ExpY,CenterAB,CenterZA,CenterY) & + + CenterAB(1,xyz)*HRR2e(AngMomBra,b1m,maxm,Om,ExpZi,ExpY,CenterAB,CenterZA,CenterY) +!------------------------------------------------------------------------ +! 2nd horizontal recurrence relation (2 terms): +!------------------------------------------------------------------------ + else + do i=1,2 + do j=1,3 + a2p(i,j) = AngMomBra(i,j) + b2m(i,j) = AngMomKet(i,j) + enddo + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomKet(2,1) > 0) then + xyz = 1 + elseif(AngMomKet(2,2) > 0) then + xyz = 2 + elseif(AngMomKet(2,3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in HRR2e!' + endif +! End loop over cartesian directions + a2p(2,xyz) = a2p(2,xyz) + 1 + b2m(2,xyz) = b2m(2,xyz) - 1 + a1a2b1b2 = HRR2e(a2p,b2m,maxm,Om,ExpZi,ExpY,CenterAB,CenterZA,CenterY) & + + CenterAB(2,xyz)*HRR2e(AngMomBra,b2m,maxm,Om,ExpZi,ExpY,CenterAB,CenterZA,CenterY) + endif + +end function HRR2e diff --git a/src/IntPak/HRR3e.f90 b/src/IntPak/HRR3e.f90 new file mode 100644 index 0000000..0e1fa21 --- /dev/null +++ b/src/IntPak/HRR3e.f90 @@ -0,0 +1,128 @@ +recursive function HRR3e(AngMomBra,AngMomKet,maxm,Om,ExpZ,CenterAB,CenterZA,DY0,DY1,D2Y0,D2Y1) & + result(a1a2a3b1b2b3) + +! Horizontal recurrence relations for three-electron integrals + + implicit none + include 'parameters.h' + + +! Input variables + + integer,intent(in) :: AngMomBra(3,3),AngMomKet(3,3) + integer,intent(in) :: maxm + double precision,intent(in) :: Om(0:maxm),ExpZ(3),CenterAB(3,3),CenterZA(3,3) + double precision,intent(in) :: DY0(3),DY1(3),D2Y0(3,3),D2Y1(3,3) + +! Local variables + + logical :: NegAngMomKet(3) + integer :: TotAngMomBra(3),TotAngMomKet(3) + integer :: a1p(3,3),b1m(3,3),a2p(3,3),b2m(3,3),a3p(3,3),b3m(3,3) + integer :: i,j,xyz + double precision :: VRR3e + +! Output variables + + double precision :: a1a2a3b1b2b3 + + do i=1,3 + NegAngMomKet(i) = AngMomKet(i,1) < 0 .or. AngMomKet(i,2) < 0 .or. AngMomKet(i,3) < 0 + TotAngMomBra(i) = AngMomBra(i,1) + AngMomBra(i,2) + AngMomBra(i,3) + TotAngMomKet(i) = AngMomKet(i,1) + AngMomKet(i,2) + AngMomKet(i,3) + enddo + +!------------------------------------------------------------------------ +! Termination condition +!------------------------------------------------------------------------ + if(NegAngMomKet(1) .or. NegAngMomKet(2) .or. NegAngMomKet(3)) then + a1a2a3b1b2b3 = 0d0 +!------------------------------------------------------------------------ +! 1st and 2nd vertical recurrence relations: +!------------------------------------------------------------------------ + elseif(TotAngMomKet(1) == 0 .and. TotAngMomKet(2) == 0 .and. TotAngMomKet(3) == 0) then + a1a2a3b1b2b3 = VRR3e(0,AngMomBra,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) +!------------------------------------------------------------------------ +! 1st horizontal recurrence relation (2 terms): +!------------------------------------------------------------------------ + elseif(TotAngMomKet(2) == 0 .and. TotAngMomKet(3) == 0) then + do i=1,3 + do j=1,3 + a1p(i,j) = AngMomBra(i,j) + b1m(i,j) = AngMomKet(i,j) + enddo + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomKet(1,1) > 0) then + xyz = 1 + elseif(AngMomKet(1,2) > 0) then + xyz = 2 + elseif(AngMomKet(1,3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in HRR3e!' + endif +! End loop over cartesian directions + a1p(1,xyz) = a1p(1,xyz) + 1 + b1m(1,xyz) = b1m(1,xyz) - 1 + a1a2a3b1b2b3 = HRR3e(a1p,b1m,maxm,Om,ExpZ,CenterAB,CenterZA,DY0,DY1,D2Y0,D2Y1) & + + CenterAB(1,xyz)* & + HRR3e(AngMomBra,b1m,maxm,Om,ExpZ,CenterAB,CenterZA,DY0,DY1,D2Y0,D2Y1) +!------------------------------------------------------------------------ +! 2nd horizontal recurrence relation (2 terms): +!------------------------------------------------------------------------ + elseif(TotAngMomKet(3) == 0) then + do i=1,3 + do j=1,3 + a2p(i,j) = AngMomBra(i,j) + b2m(i,j) = AngMomKet(i,j) + enddo + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomKet(2,1) > 0) then + xyz = 1 + elseif(AngMomKet(2,2) > 0) then + xyz = 2 + elseif(AngMomKet(2,3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in HRR3e!' + endif +! End loop over cartesian directions + a2p(2,xyz) = a2p(2,xyz) + 1 + b2m(2,xyz) = b2m(2,xyz) - 1 + a1a2a3b1b2b3 = HRR3e(a2p,b2m,maxm,Om,ExpZ,CenterAB,CenterZA,DY0,DY1,D2Y0,D2Y1) & + + CenterAB(2,xyz)* & + HRR3e(AngMomBra,b2m,maxm,Om,ExpZ,CenterAB,CenterZA,DY0,DY1,D2Y0,D2Y1) +!------------------------------------------------------------------------ +! 3rd horizontal recurrence relation (2 terms): +!------------------------------------------------------------------------ + else + do i=1,3 + do j=1,3 + a3p(i,j) = AngMomBra(i,j) + b3m(i,j) = AngMomKet(i,j) + enddo + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomKet(3,1) > 0) then + xyz = 1 + elseif(AngMomKet(3,2) > 0) then + xyz = 2 + elseif(AngMomKet(3,3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in HRR3e!' + endif +! End loop over cartesian directions + a3p(3,xyz) = a3p(3,xyz) + 1 + b3m(3,xyz) = b3m(3,xyz) - 1 + a1a2a3b1b2b3 = HRR3e(a3p,b3m,maxm,Om,ExpZ,CenterAB,CenterZA,DY0,DY1,D2Y0,D2Y1) & + + CenterAB(3,xyz)* & + HRR3e(AngMomBra,b3m,maxm,Om,ExpZ,CenterAB,CenterZA,DY0,DY1,D2Y0,D2Y1) + endif + +end function HRR3e diff --git a/src/IntPak/HRRF12.f90 b/src/IntPak/HRRF12.f90 new file mode 100644 index 0000000..6ad2efe --- /dev/null +++ b/src/IntPak/HRRF12.f90 @@ -0,0 +1,40 @@ +recursive function HRRF12(AngMomA,AngMomB,AngMomC,AngMomD,fG,gP,gG,gQ,ExpPGQi, & + CenterPQSq,CenterRA,CenterRC,CenterAB,CenterCD) & + result(Gabcd) + +! Compute two-electron integrals over Gaussian geminals + + implicit none + +! Input variables + integer,intent(in) :: AngMomA,AngMomB,AngMomC,AngMomD + double precision,intent(in) :: ExpPGQi + double precision,intent(in) :: fG,gP,gG,gQ + double precision,intent(in) :: CenterPQSq,CenterRA,CenterRC + double precision,intent(in) :: CenterAB,CenterCD + +! Local variables + double precision :: VRRF12 + double precision :: Gabcd + + If(AngMomB < 0 .or. AngMomD < 0) then + Gabcd = 0d0 + Else + If(AngMomB == 0 .and. AngMomD == 0) then + Gabcd = VRRF12(AngMomA,AngMomC,fG,gP,gG,gQ,ExpPGQi,CenterPQSq,CenterRA,CenterRC) + Else + If(AngMomD == 0) then + Gabcd = HRRF12(AngMomA+1,AngMomB-1,AngMomC,AngMomD,fG,gP,gG,gQ,ExpPGQi, & + CenterPQSq,CenterRA,CenterRC,CenterAB,CenterCD) & + + CenterAB*HRRF12(AngMomA,AngMomB-1,AngMomC,AngMomD,fG,gP,gG,gQ, & + ExpPGQi,CenterPQSq,CenterRA,CenterRC,CenterAB,CenterCD) + Else + Gabcd = HRRF12(AngMomA,AngMomB,AngMomC+1,AngMomD-1,fG,gP,gG,gQ,ExpPGQi, & + CenterPQSq,CenterRA,CenterRC,CenterAB,CenterCD) & + + CenterCD*HRRF12(AngMomA,AngMomB,AngMomC,AngMomD-1,fG,gP,gG,gQ, & + ExpPGQi,CenterPQSq,CenterRA,CenterRC,CenterAB,CenterCD) + EndIf + EndIf + EndIf + +end function HRRF12 diff --git a/src/IntPak/HRRNuc.f90 b/src/IntPak/HRRNuc.f90 new file mode 100644 index 0000000..822a9b5 --- /dev/null +++ b/src/IntPak/HRRNuc.f90 @@ -0,0 +1,71 @@ +recursive function HRRNuc(AngMomA,AngMomB,maxm,Om,ExpPi,CenterAB,CenterPA,CenterPC) & + result(Gab) + +! Horizontal recurrence relation for one-electron nuclear attraction integrals + + implicit none + +! Input variables + + integer,intent(in) :: AngMomA(3),AngMomB(3) + integer,intent(in) :: maxm + double precision,intent(in) :: Om(0:maxm) + double precision,intent(in) :: ExpPi + double precision,intent(in) :: CenterAB(3),CenterPA(3),CenterPC(3) + +! Local variables + + logical :: NegAngMomB + integer :: TotAngMomA,TotAngMomB + integer :: xyz,ap(3),bm(3) + integer :: i + double precision :: VRRNuc + +! Output variables + + double precision :: Gab + + NegAngMomB = AngMomB(1) < 0 .or. AngMomB(2) < 0 .or. AngMomB(3) < 0 + + TotAngMomA = AngMomA(1) + AngMomA(2) + AngMomA(3) + TotAngMomB = AngMomB(1) + AngMomB(2) + AngMomB(3) + +!------------------------------------------------------------------------ +! Termination condition +!------------------------------------------------------------------------ + if(NegAngMomB) then + Gab = 0d0 + else +!------------------------------------------------------------------------ +! Vertical recurrence relations: (a|0) +!------------------------------------------------------------------------ + if(TotAngMomB == 0) then + Gab = VRRNuc(0,AngMomA,maxm,Om,ExpPi,CenterAB,CenterPA,CenterPC) + else +!------------------------------------------------------------------------ +! 1st horizontal recurrence relation (2 terms): (a|b+) +!------------------------------------------------------------------------ + do i=1,3 + ap(i) = AngMomA(i) + bm(i) = AngMomB(i) + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomB(1) > 0) then + xyz = 1 + elseif(AngMomB(2) > 0) then + xyz = 2 + elseif(AngMomB(3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in HRRNuc!' + endif +! End loop over cartesian directions + ap(xyz) = ap(xyz) + 1 + bm(xyz) = bm(xyz) - 1 + Gab = HRRNuc(ap,bm,maxm,Om,ExpPi,CenterAB,CenterPA,CenterPC) & + + CenterAB(xyz)*HRRNuc(AngMomA,bm,maxm,Om,ExpPi,CenterAB,CenterPA,CenterPC) + endif + endif + +end function HRRNuc diff --git a/src/IntPak/HRROv.f90 b/src/IntPak/HRROv.f90 new file mode 100644 index 0000000..135140e --- /dev/null +++ b/src/IntPak/HRROv.f90 @@ -0,0 +1,28 @@ +recursive function HRROv(AngMomA,AngMomB,ExpPi,CenterAB,CenterPA) & + result(Gab) + +! Horizontal recurrence relations for one-electron overlap integrals + + implicit none + +! Input variables + integer,intent(in) :: AngMomA,AngMomB + double precision,intent(in) :: ExpPi + double precision,intent(in) :: CenterAB,CenterPA + +! Local variables + double precision :: VRROv + double precision :: Gab + + if(AngMomB < 0) then + Gab = 0d0 + else + if(AngMomB == 0) then + Gab = VRROv(AngMomA,ExpPi,CenterPA) + else + Gab = HRROv(AngMomA+1,AngMomB-1,ExpPi,CenterAB,CenterPA) & + + CenterAB*HRROv(AngMomA,AngMomB-1,ExpPi,CenterAB,CenterPA) + endif + endif + +end function HRROv diff --git a/src/IntPak/IntPak.f90 b/src/IntPak/IntPak.f90 new file mode 100644 index 0000000..88720bc --- /dev/null +++ b/src/IntPak/IntPak.f90 @@ -0,0 +1,555 @@ +program IntPak + + implicit none + include 'parameters.h' + + logical :: debug + logical :: doOv,doKin,doNuc,doERI,doF12,doYuk,doErf + logical :: do3eInt(n3eInt),do4eInt(n4eInt) + integer :: NAtoms,NBasis,iType + double precision :: ExpS + integer :: KG + double precision,allocatable :: DG(:),ExpG(:) + double precision,allocatable :: ZNuc(:),XYZAtoms(:,:) + + integer :: nShell + integer,allocatable :: TotAngMomShell(:),KShell(:) + double precision,allocatable :: CenterShell(:,:),DShell(:,:),ExpShell(:,:) + + double precision :: start_1eInt(n1eInt),end_1eInt(n1eInt),t_1eInt(n1eInt) + double precision :: start_2eInt(n2eInt),end_2eInt(n2eInt),t_2eInt(n2eInt) + double precision :: start_3eInt(n3eInt),end_3eInt(n3eInt),t_3eInt(n3eInt) + double precision :: start_4eInt(n4eInt),end_4eInt(n4eInt),t_4eInt(n4eInt) + + integer :: np1eInt(n1eInt),nSigp1eInt(n1eInt),nc1eInt(n1eInt),nSigc1eInt(n1eInt) + integer :: np2eInt(n2eInt),nSigp2eInt(n2eInt),nc2eInt(n2eInt),nSigc2eInt(n2eInt) + integer :: np3eInt(n3eInt),nSigp3eInt(n3eInt),nc3eInt(n3eInt),nSigc3eInt(n3eInt) + integer :: np4eInt(n4eInt),nSigp4eInt(n4eInt),nc4eInt(n4eInt),nSigc4eInt(n4eInt) + + double precision,allocatable :: S(:,:) + + +! Hello World + + write(*,*) + write(*,*) '********************************' + write(*,*) '* IntPak *' + write(*,*) '* Integral Package for dummies *' + write(*,*) '********************************' + write(*,*) + +! Debugger on? + + debug = .false. +! debug = .true. + +! Which integrals do you want? + + doOv = .true. + doKin = .true. + doNuc = .true. + doERI = .true. + doF12 = .false. + doYuk = .false. + doErf = .false. + + do3eInt(1) = .false. + do3eInt(2) = .false. + do3eInt(3) = .false. + + do4eInt(1) = .false. + do4eInt(2) = .false. + do4eInt(3) = .false. + +!------------------------------------------------------------------------ +! Read input information +!------------------------------------------------------------------------ + + call ReadNAtoms(NAtoms) + + allocate(ZNuc(1:NAtoms),XYZAtoms(1:NAtoms,1:3)) + + call ReadGeometry(NAtoms,ZNuc,XYZAtoms) + + allocate(CenterShell(1:maxShell,1:3),TotAngMomShell(1:maxShell),KShell(1:maxShell), & + DShell(1:maxShell,1:maxK),ExpShell(1:maxShell,1:maxK)) + + call ReadBasis(NAtoms,XYZAtoms,nShell,CenterShell, & + TotAngMomShell,KShell,DShell,ExpShell) + + call CalcNBasis(nShell,TotAngMomShell,NBasis) + + call ReadGeminal(ExpS) + +!------------------------------------------------------------------------ +! Memory allocation +!------------------------------------------------------------------------ + allocate(S(1:NBasis,1:NBasis)) + +!------------------------------------------------------------------------ +! Compute one-electron overlap integrals +!------------------------------------------------------------------------ + if(doOv) then + + iType = 1 + + call cpu_time(start_1eInt(iType)) + call ComputeOv(debug,NBasis,nShell, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np1eInt(iType),nSigp1eInt(iType),nc1eInt(iType),nSigc1eInt(iType),S) + call cpu_time(end_1eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive overlap integrals = ',np1eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive overlap integrals = ',nSigp1eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted overlap integrals = ',nc1eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted overlap integrals = ',nSigc1eInt(iType) + + write(*,*) + + t_1eInt(iType) = end_1eInt(iType) - start_1eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_1eInt(iType),' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute one-electron kinetic integrals +!------------------------------------------------------------------------ + + if(doKin) then + + iType = 2 + + call cpu_time(start_1eInt(iType)) + call ComputeKin(debug,nShell, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np1eInt(iType),nSigp1eInt(iType),nc1eInt(iType),nSigc1eInt(iType)) + call cpu_time(end_1eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive kinetic integrals = ',np1eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive kinetic integrals = ',nSigp1eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted kinetic integrals = ',nc1eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted kinetic integrals = ',nSigc1eInt(iType) + + write(*,*) + + t_1eInt(iType) = end_1eInt(iType) - start_1eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_1eInt(iType),' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute one-electron nuclear attraction integrals +!------------------------------------------------------------------------ + + if(doNuc) then + + iType = 3 + + call cpu_time(start_1eInt(iType)) + call ComputeNuc(debug,nShell, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + NAtoms,ZNuc,XYZAtoms, & + np1eInt(iType),nSigp1eInt(iType),nc1eInt(iType),nSigc1eInt(iType)) + call cpu_time(end_1eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive nuclear integrals = ',np1eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive nuclear integrals = ',nSigp1eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted nuclear integrals = ',nc1eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted nuclear integrals = ',nSigc1eInt(iType) + + write(*,*) + + t_1eInt(iType) = end_1eInt(iType) - start_1eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_1eInt(iType),' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute ERIs +!------------------------------------------------------------------------ + + if(doERI) then + + iType = 1 + KG = 1 + allocate(DG(1:KG),ExpG(1:KG)) + DG = (/ 1d0 /) + ExpG = (/ 0d0 /) + + call cpu_time(start_2eInt(iType)) + call Compute2eInt(debug,iType,nShell, & + ExpS,KG,DG,ExpG, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np2eInt(iType),nSigp2eInt(iType),nc2eInt(iType),nSigc2eInt(iType)) + call cpu_time(end_2eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive ERIs = ',np2eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive ERIs = ',nSigp2eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted ERIs = ',nc2eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted ERIs = ',nSigc2eInt(iType) + + write(*,*) + + t_2eInt(iType) = end_2eInt(iType) - start_2eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_2eInt(iType),' seconds' + write(*,*) + + deallocate(DG,ExpG) + + endif + +!------------------------------------------------------------------------ +! Compute F12 two-electron integrals +!------------------------------------------------------------------------ + + if(doF12) then + + iType = 2 + KG = 6 + allocate(DG(1:KG),ExpG(1:KG)) + DG = (/ 0.3144d0, 0.3037d0, 0.1681d0, 0.09811d0, 0.06024d0, 0.03726d0 /) + ExpG = (/ 0.2209d0, 1.004d0, 3.622d0, 12.16d0, 45.87d0, 254.4d0 /) + +! KG = 10 +! allocate(DG(1:KG),ExpG(1:KG)) + +! DG = (/ 220.983854141, 18.52358977132, 4.81060044582, 1.892812227999, & +! 0.920641976732, 0.505281134191, 0.295757471525, 0.1753021140139, & +! 0.0969611396173, 0.0386163391551 /) +! ExpG = (/ 5722.54799330, 191.0413784782, 27.4417708701, 6.39987966572, & +! 1.82203908762, 0.548835646170, 0.156252937904, 0.036440796942, & +! 0.0052344680925, 0.00017474733304 /) + +! KG = 20 +! allocate(DG(1:KG),ExpG(1:KG)) + +! DG = (/ 841.88478132, 70.590185207, 18.3616020768, 7.2608642093, & +!3.57483416444, 2.01376031082, 1.24216542801, 0.81754348620, & +!0.564546514023, 0.404228610699, 0.297458536575, 0.223321219537, & +!0.169933732064, 0.130190978230, 0.099652303426, 0.075428246546, & +!0.0555635614051, 0.0386791283055, 0.0237550435652, 0.0100062783874 /) + +! ExpG = (/84135.654509, 2971.58727634, 474.716025959, 130.676724560, & +!47.3938388887, 20.2078651631, 9.5411021938, 4.8109546955, & +!2.52795733067, 1.35894103210, 0.73586710268, 0.39557629706, & +!0.20785895177, 0.104809693858, 0.049485682527, 0.021099788990, & +!0.007652472186, 0.0021065225215, 0.0003365204879, 0.00001188556749 /) + + + + call cpu_time(start_2eInt(iType)) + call Compute2eInt(debug,iType,nShell, & + ExpS,KG,DG,ExpG, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np2eInt(iType),nSigp2eInt(iType),nc2eInt(iType),nSigc2eInt(iType)) + call cpu_time(end_2eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive geminal integrals = ',np2eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive geminal integrals = ',nSigp2eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted geminal integrals = ',nc2eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted geminal integrals = ',nSigc2eInt(iType) + + write(*,*) + + t_2eInt(iType) = end_2eInt(iType) - start_2eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_2eInt(iType),' seconds' + write(*,*) + + deallocate(DG,ExpG) + + endif + +!------------------------------------------------------------------------ +! Compute Yukawa two-electron integrals +!------------------------------------------------------------------------ + + if(doYuk) then + + iType = 3 + KG = 6 + allocate(DG(1:KG),ExpG(1:KG)) + DG = (/ 0.3144d0, 0.3037d0, 0.1681d0, 0.09811d0, 0.06024d0, 0.03726d0 /) + ExpG = (/ 0.2209d0, 1.004d0, 3.622d0, 12.16d0, 45.87d0, 254.4d0 /) + + call cpu_time(start_2eInt(iType)) + call Compute2eInt(debug,iType,nShell, & + ExpS,KG,DG,ExpG, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np2eInt(iType),nSigp2eInt(iType),nc2eInt(iType),nSigc2eInt(iType)) + call cpu_time(end_2eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive Yukawa integrals = ',np2eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive Yukawa integrals = ',nSigp2eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted Yukawa integrals = ',nc2eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted Yukawa integrals = ',nSigc2eInt(iType) + + write(*,*) + + t_2eInt(iType) = end_2eInt(iType) - start_2eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_2eInt(iType),' seconds' + write(*,*) + + deallocate(DG,ExpG) + + endif + +!------------------------------------------------------------------------ +! Compute long-range Coulomb two-electron integrals +!------------------------------------------------------------------------ + + if(doErf) then + + iType = 4 + KG = 1 + allocate(DG(1:KG),ExpG(1:KG)) + DG = (/ 1d0 /) + ExpG = (/ 1d0 /) + ExpS = ExpS*ExpS + + call cpu_time(start_2eInt(iType)) + call Compute2eInt(debug,iType,nShell, & + ExpS,KG,DG,ExpG, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np2eInt(iType),nSigp2eInt(iType),nc2eInt(iType),nSigc2eInt(iType)) + call cpu_time(end_2eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive long-range Coulomb integrals = ',np2eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive long-range Coulomb integrals = ',nSigp2eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted long-range Coulomb integrals = ',nc2eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted long-range Coulomb integrals = ',nSigc2eInt(iType) + + write(*,*) + + t_2eInt(iType) = end_2eInt(iType) - start_2eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_2eInt(iType),' seconds' + write(*,*) + + deallocate(DG,ExpG) + + endif + +!------------------------------------------------------------------------ +! Compute three-electron integrals: Type 1 => chain C12 S23 +!------------------------------------------------------------------------ + + if(do3eInt(1)) then + + iType = 1 + KG = 1 +! KG = 6 + allocate(DG(1:KG),ExpG(1:KG)) + DG = (/ 1d0 /) + ExpG = (/ 1d0 /) +! DG = (/ 0.3144d0, 0.3037d0, 0.1681d0, 0.09811d0, 0.06024d0, 0.03726d0 /) +! ExpG = (/ 0.2209d0, 1.004d0, 3.622d0, 12.16d0, 45.87d0, 254.4d0 /) + + call cpu_time(start_3eInt(iType)) + call Compute3eInt(debug,iType,nShell, & + ExpS,KG,DG,ExpG, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np3eInt(iType),nSigp3eInt(iType),nc3eInt(iType),nSigc3eInt(iType)) + call cpu_time(end_3eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive f23/r12 integrals = ',np3eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive f23/r12 integrals = ',nSigp3eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted f23/r12 integrals = ',nc3eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted f23/r12 integrals = ',nSigc3eInt(iType) + + write(*,*) + + t_3eInt(iType) = end_3eInt(iType) - start_3eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_3eInt(iType),' seconds' + write(*,*) + + deallocate(DG,ExpG) + + endif + +!------------------------------------------------------------------------ +! Compute three-electron integrals: Type 2 => cyclic C12 S13 S23 +!------------------------------------------------------------------------ + + if(do3eInt(2)) then + + iType = 2 + KG = 6 + allocate(DG(1:KG),ExpG(1:KG)) + DG = (/ 0.3144d0, 0.3037d0, 0.1681d0, 0.09811d0, 0.06024d0, 0.03726d0 /) + ExpG = (/ 0.2209d0, 1.004d0, 3.622d0, 12.16d0, 45.87d0, 254.4d0 /) + + call cpu_time(start_3eInt(iType)) + call Compute3eInt(debug,iType,nShell, & + ExpS,KG,DG,ExpG, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np3eInt(iType),nSigp3eInt(iType),nc3eInt(iType),nSigc3eInt(iType)) + call cpu_time(end_3eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive f13.f23/r12 integrals = ',np3eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive f13.f23/r12 integrals = ',nSigp3eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted f13.f23/r12 integrals = ',nc3eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted f13.f23/r12 integrals = ',nSigc3eInt(iType) + + write(*,*) + + t_3eInt(iType) = end_3eInt(iType) - start_3eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_3eInt(iType),' seconds' + write(*,*) + + deallocate(DG,ExpG) + + endif + +!------------------------------------------------------------------------ +! Compute three-electron integrals: Type 3 => chain S13 S23 +!------------------------------------------------------------------------ + + if(do3eInt(3)) then + + iType = 3 + KG = 6 + allocate(DG(1:KG),ExpG(1:KG)) + DG = (/ 0.3144d0, 0.3037d0, 0.1681d0, 0.09811d0, 0.06024d0, 0.03726d0 /) + ExpG = (/ 0.2209d0, 1.004d0, 3.622d0, 12.16d0, 45.87d0, 254.4d0 /) + + call cpu_time(start_3eInt(iType)) + call Compute3eInt(debug,iType,nShell, & + ExpS,KG,DG,ExpG, & + CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + np3eInt(iType),nSigp3eInt(iType),nc3eInt(iType),nSigc3eInt(iType)) + call cpu_time(end_3eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive f13.f23 integrals = ',np3eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive f13.f23 integrals = ',nSigp3eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted f13.f23 integrals = ',nc3eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted f13.f23 integrals = ',nSigc3eInt(iType) + + write(*,*) + + t_3eInt(iType) = end_3eInt(iType) - start_3eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_3eInt(iType),' seconds' + write(*,*) + + deallocate(DG,ExpG) + + endif + +!------------------------------------------------------------------------ +! Compute four-electron integrals: Type 1 => chain C12 S14 S23 +!------------------------------------------------------------------------ + + if(do4eInt(1)) then + + iType = 1 + KG = 6 + allocate(DG(1:KG),ExpG(1:KG)) + DG = (/ 0.3144d0, 0.3037d0, 0.1681d0, 0.09811d0, 0.06024d0, 0.03726d0 /) + ExpG = (/ 0.2209d0, 1.004d0, 3.622d0, 12.16d0, 45.87d0, 254.4d0 /) + + call cpu_time(start_4eInt(iType)) +! call Compute4eInt(debug,iType,nShell,ExpS, & +! ExpS,KG,DG,ExpG, & +! CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & +! np4eInt(iType),nSigp4eInt(iType),nc4eInt(iType),nSigc4eInt(iType)) + call cpu_time(end_4eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive f14.f23/r12 integrals = ',np4eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive f14.f23/r12 integrals = ',nSigp4eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted f14.f23/r12 integrals = ',nc4eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted f14.f23/r12 integrals = ',nSigc4eInt(iType) + + write(*,*) + + t_4eInt(iType) = end_4eInt(iType) - start_4eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_4eInt(iType),' seconds' + write(*,*) + + deallocate(DG,ExpG) + + endif + +!------------------------------------------------------------------------ +! Compute four-electron integrals: Type 2 => trident C12 S13 S14 +!------------------------------------------------------------------------ + + if(do4eInt(2)) then + + iType = 2 + KG = 6 + DG = (/ 0.3144d0, 0.3037d0, 0.1681d0, 0.09811d0, 0.06024d0, 0.03726d0 /) + ExpG = (/ 0.2209d0, 1.004d0, 3.622d0, 12.16d0, 45.87d0, 254.4d0 /) + + call cpu_time(start_4eInt(iType)) +! call Compute4eInt(debug,iType,nShell,ExpS, & +! ExpS,KG,DG,ExpG, & +! CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & +! np4eInt(iType),nSigp4eInt(iType),nc4eInt(iType),nSigc4eInt(iType)) + call cpu_time(end_4eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive f13.f14/r12 integrals = ',np4eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive f13.f14/r12 integrals = ',nSigp4eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted f13.f14/r12 integrals = ',nc4eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted f13.f14/r12 integrals = ',nSigc4eInt(iType) + + write(*,*) + + t_4eInt(iType) = end_4eInt(iType) - start_4eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_4eInt(iType),' seconds' + write(*,*) + + deallocate(DG,ExpG) + + endif + +!------------------------------------------------------------------------ +! Compute four-electron integrals: Type 3 => chain C12 S13 S34 +!------------------------------------------------------------------------ + + if(do4eInt(3)) then + + iType = 3 + KG = 6 + allocate(DG(1:KG),ExpG(1:KG)) + DG = (/ 0.3144d0, 0.3037d0, 0.1681d0, 0.09811d0, 0.06024d0, 0.03726d0 /) + ExpG = (/ 0.2209d0, 1.004d0, 3.622d0, 12.16d0, 45.87d0, 254.4d0 /) + + call cpu_time(start_4eInt(iType)) +! call Compute4eInt(debug,iType,nShell, & +! ExpS,KG,DG,ExpG, & +! CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & +! np4eInt(iType),nSigp4eInt(iType),nc4eInt(iType),nSigc4eInt(iType)) + call cpu_time(end_4eInt(iType)) + + write(*,'(A65,1X,I9)') 'Total number of primitive f13.f34/r12 integrals = ',np4eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant primitive f13.f34/r12 integrals = ',nSigp4eInt(iType) + + write(*,'(A65,1X,I9)') 'Total number of contracted f13.f34/r12 integrals = ',nc4eInt(iType) + write(*,'(A65,1X,I9)') 'Number of significant contracted f13.f34/r12 integrals = ',nSigc4eInt(iType) + + write(*,*) + + t_4eInt(iType) = end_4eInt(iType) - start_4eInt(iType) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time = ',t_4eInt(iType),' seconds' + write(*,*) + + deallocate(DG,ExpG) + + endif +!------------------------------------------------------------------------ +! End of IntPak +!------------------------------------------------------------------------ +end program IntPak diff --git a/src/IntPak/KinInt.f90 b/src/IntPak/KinInt.f90 new file mode 100644 index 0000000..e7394e8 --- /dev/null +++ b/src/IntPak/KinInt.f90 @@ -0,0 +1,76 @@ +subroutine KinInt(npKin,nSigpKin,ExpA,CenterA,AngMomA,ExpB,CenterB,AngMomB,pKin) + +! Compute one-electron kinetic integrals + + implicit none + +! Input variables + + double precision,intent(in) :: ExpA,ExpB + double precision,intent(in) :: CenterA(3),CenterB(3) + integer,intent(in) :: AngMomA(3),AngMomB(3) + + +! Local variables + + double precision :: ExpAi,ExpBi + double precision :: ExpP,ExpPi + double precision :: CenterP(3),CenterAB(3),CenterPA(3) + double precision :: NormABSq + double precision :: GAB + double precision :: HRROv,RRKin + + integer :: i + double precision :: pi + double precision :: start_RR,finish_RR,t_RR + double precision :: s(3),k(3) + +! Output variables + + integer,intent(inout) :: npKin,nSigpKin + double precision,intent(out) :: pKin + + pi = 4d0*atan(1d0) + +! Pre-computed shell quantities + + ExpAi = 1d0/ExpA + ExpBi = 1d0/ExpB + +! Pre-computed quantities for shell-pair AB + + ExpP = ExpA + ExpB + ExpPi = 1d0/ExpP + + NormABSq = 0d0 + Do i=1,3 + CenterP(i) = (ExpA*CenterA(i) + ExpB*CenterB(i))*ExpPi + CenterPA(i) = CenterP(i) - CenterA(i) + CenterAB(i) = CenterA(i) - CenterB(i) + NormABSq = NormABSq + CenterAB(i)**2 + Enddo + + GAB = (pi*ExpPi)**(1.5d0)*exp(-NormABSq/(ExpAi+ExpBi)) + +!------------------------------------------------------------------------ +! Launch reccurence relations! +!------------------------------------------------------------------------ + call cpu_time(start_RR) +! Loop over cartesian directions + Do i=1,3 + s(i) = HRROv(AngMomA(i),AngMomB(i),ExpPi,CenterAB(i),CenterPA(i)) + k(i) = RRKin(AngMomA(i),AngMomB(i),ExpA,ExpB,ExpPi,CenterAB(i),CenterPA(i)) + Enddo + call cpu_time(finish_RR) + + pKin = k(1)*s(2)*s(3) + s(1)*k(2)*s(3) + s(1)*s(2)*k(3) + pKin = GAB*pKin + t_RR = finish_RR - start_RR + +! Print result + npKin = npKin + 1 + if(abs(pKin) > 1d-15) then + nSigpKin = nSigpKin + 1 + endif + +end subroutine KinInt diff --git a/src/IntPak/Makefile b/src/IntPak/Makefile new file mode 100644 index 0000000..432854f --- /dev/null +++ b/src/IntPak/Makefile @@ -0,0 +1,29 @@ +IDIR =../../include +LDIR =../../lib +BDIR =../../bin +ODIR = obj +SDIR =. +FC = gfortran +FFLAGS = -Wall -O3 -I$(IDIR) +DFLAGS = -g -msse4.2 -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation -Wreal-q-constant + + +LIBS = $(LDIR)/*.a $(LDIR)/slatec/src/static/libslatec.a + + +SRC = $(wildcard *.f90) + +OBJ = $(patsubst %.f90,$(ODIR)/%.o,$(SRC)) + + +$(ODIR)/%.o: %.f90 + $(FC) -c -o $@ $< $(FFLAGS) + +$(BDIR)/IntPak: $(OBJ) + $(FC) -o $@ $^ $(FFLAGS) $(LIBS) + +debug: $(OBJ) + $(FC) -o $(BDIR)/$@ $^ $(FFLAGS) $(LIBS) $(DFLAGS) + +clean: + rm -f $(ODIR)/*.o $(BDIR)/IntPak $(BDIR)/debug diff --git a/src/IntPak/NormCoeff.f90 b/src/IntPak/NormCoeff.f90 new file mode 100644 index 0000000..9e6cabf --- /dev/null +++ b/src/IntPak/NormCoeff.f90 @@ -0,0 +1,29 @@ +function NormCoeff(alpha,a) + + implicit none + +! Input variables + + double precision,intent(in) :: alpha + integer,intent(in) :: a(3) + +! local variable + double precision :: pi,dfa(3),dfac + integer :: atot + +! Output variable + double precision NormCoeff + + pi = 4d0*atan(1d0) + atot = a(1) + a(2) + a(3) + + dfa(1) = dfac(2*a(1))/(2d0**a(1)*dfac(a(1))) + dfa(2) = dfac(2*a(2))/(2d0**a(2)*dfac(a(2))) + dfa(3) = dfac(2*a(3))/(2d0**a(3)*dfac(a(3))) + + + NormCoeff = (2d0*alpha/pi)**(3d0/2d0)*(4d0*alpha)**atot + NormCoeff = NormCoeff/(dfa(1)*dfa(2)*dfa(3)) + NormCoeff = sqrt(NormCoeff) + +end function NormCoeff diff --git a/src/IntPak/NucInt.f90 b/src/IntPak/NucInt.f90 new file mode 100644 index 0000000..36e678a --- /dev/null +++ b/src/IntPak/NucInt.f90 @@ -0,0 +1,114 @@ +subroutine NucInt(debug,npNuc,nSigpNuc, & + ExpA,CenterA,AngMomA, & + ExpB,CenterB,AngMomB, & + CenterC, & + pNuc) + +! Compute recursively the primitive one-electron nuclear attraction integrals + + implicit none + +! Input variables + + logical,intent(in) :: debug + double precision,intent(in) :: ExpA,ExpB + double precision,intent(in) :: CenterA(3),CenterB(3),CenterC(3) + integer,intent(in) :: AngMomA(3),AngMomB(3) + +! Local variables + + double precision :: ExpAi,ExpBi + integer :: TotAngMomA,TotAngMomB + double precision :: ExpP,ExpPi + double precision :: CenterP(3),CenterAB(3),CenterPA(3),CenterPC(3) + double precision :: NormABSq,NormPCSq + double precision :: G + double precision,allocatable :: Om(:) + double precision :: HRRNuc + double precision :: Gab + + double precision :: pi + integer :: i,maxm + double precision :: start_Om,finish_Om,start_RR,finish_RR,t_Om,t_RR + +! Output variables + + integer,intent(inout) :: npNuc,nSigpNuc + double precision,intent(out) :: pNuc + + pi = 4d0*atan(1d0) + +! Pre-computed shell quantities + + ExpAi = 1d0/ExpA + ExpBi = 1d0/ExpB + +! Pre-computed quantities for shell-pair AB + + ExpP = ExpA + ExpB + ExpPi = 1d0/ExpP + + NormABSq = 0d0 + NormPCSq = 0d0 + do i=1,3 + CenterP(i) = (ExpA*CenterA(i) + ExpB*CenterB(i))*ExpPi + CenterAB(i) = CenterA(i) - CenterB(i) + CenterPA(i) = CenterP(i) - CenterA(i) + CenterPC(i) = CenterP(i) - CenterC(i) + NormABSq = NormABSq + CenterAB(i)**2 + NormPCSq = NormPCSq + CenterPC(i)**2 + enddo + + G = (pi*ExpPi)**(1.5d0)*exp(-NormABSq/(ExpAi+ExpBi)) + +! Total angular momemtum + + TotAngMomA = AngMomA(1) + AngMomA(2) + AngMomA(3) + TotAngMomB = AngMomB(1) + AngMomB(2) + AngMomB(3) + + maxm = TotAngMomA + TotAngMomB + +! Pre-compute (0|V|0)^m + + allocate(Om(0:maxm)) + call cpu_time(start_Om) + call CalcOmNuc(maxm,ExpPi,NormPCSq,Om) + call cpu_time(finish_Om) + +! Print (0|V|0)^m + + if(debug) then + write(*,*) '(0|V|0)^m' + do i=0,maxm + write(*,*) i,Om(i) + enddo + write(*,*) + endif + +!------------------------------------------------------------------------ +! Launch reccurence relations! +!------------------------------------------------------------------------ + call cpu_time(start_RR) + Gab = HRRNuc(AngMomA,AngMomB,maxm,Om,ExpPi,CenterAB,CenterPA,CenterPC) + call cpu_time(finish_RR) + +! Timings + + t_Om = finish_Om - start_Om + t_RR = finish_RR - start_RR + +! Print result + + pNuc = G*Gab + + npNuc = npNuc + 1 + if(abs(pNuc) > 1d-15) then + nSigpNuc = nSigpNuc + 1 +! write(*,'(A10,1X,F16.10,1X,I6,1X,I6)') '[a|V|b] = ',pNuc + endif + +! Deallocate arrays + + deallocate(Om) + +end subroutine NucInt diff --git a/src/IntPak/OvInt.f90 b/src/IntPak/OvInt.f90 new file mode 100644 index 0000000..2426440 --- /dev/null +++ b/src/IntPak/OvInt.f90 @@ -0,0 +1,74 @@ +subroutine OvInt(npOv,nSigpOv,ExpA,CenterA,AngMomA,ExpB,CenterB,AngMomB,pOv) + +! Compute one-electron overlap integrals + + implicit none + +! Input variables + + double precision,intent(in) :: ExpA,ExpB + double precision,intent(in) :: CenterA(3),CenterB(3) + integer,intent(in) :: AngMomA(3),AngMomB(3) + + +! Local variables + + double precision :: ExpAi,ExpBi + double precision :: ExpP,ExpPi + double precision :: CenterP(3),CenterAB(3),CenterPA(3) + double precision :: NormABSq + double precision :: G + double precision :: HRROv + + integer :: i + double precision :: pi + double precision :: start_RR,finish_RR,t_RR + double precision :: Gab(3) + +! Output variables + + integer,intent(inout) :: npOv,nSigpOv + double precision,intent(out) :: pOv + + pi = 4d0*atan(1d0) + +! Pre-computed shell quantities + + ExpAi = 1d0/ExpA + ExpBi = 1d0/ExpB + +! Pre-computed quantities for shell-pair AB + + ExpP = ExpA + ExpB + ExpPi = 1d0/ExpP + + NormABSq = 0d0 + Do i=1,3 + CenterP(i) = (ExpA*CenterA(i) + ExpB*CenterB(i))*ExpPi + CenterPA(i) = CenterP(i) - CenterA(i) + CenterAB(i) = CenterA(i) - CenterB(i) + NormABSq = NormABSq + CenterAB(i)**2 + Enddo + + G = (pi*ExpPi)**(1.5d0)*exp(-NormABSq/(ExpAi+ExpBi)) + +!------------------------------------------------------------------------ +! Launch reccurence relations! +!------------------------------------------------------------------------ + call cpu_time(start_RR) +! Loop over cartesian directions + Do i=1,3 + Gab(i) = HRROv(AngMomA(i),AngMomB(i),ExpPi,CenterAB(i),CenterPA(i)) + Enddo + call cpu_time(finish_RR) + + pOv = G*Gab(1)*Gab(2)*Gab(3) + t_RR = finish_RR - start_RR + +! Print result + npOv = npOv + 1 + if(abs(pOv) > 1d-15) then + nSigpOv = nSigpOv + 1 + endif + +end subroutine OvInt diff --git a/src/IntPak/RRKin.f90 b/src/IntPak/RRKin.f90 new file mode 100644 index 0000000..30993f2 --- /dev/null +++ b/src/IntPak/RRKin.f90 @@ -0,0 +1,29 @@ +function RRKin(AngMomA,AngMomB,ExpA,ExpB,ExpPi,CenterAB,CenterPA) & + result(Gab) + +! Recurrence relation for one-electron kinetic integrals + + implicit none + +! Input variables + integer,intent(in) :: AngMomA,AngMomB + double precision,intent(in) :: ExpA,ExpB,ExpPi + double precision,intent(in) :: CenterAB,CenterPA + +! Local variables + double precision :: HRROv + double precision :: a,b,s1,s2,s3,s4 + double precision :: Gab + + a = dble(AngMomA) + b = dble(AngMomB) + + s1 = HRROv(AngMomA-1,AngMomB-1,ExpPi,CenterAB,CenterPA) + s2 = HRROv(AngMomA+1,AngMomB-1,ExpPi,CenterAB,CenterPA) + s3 = HRROv(AngMomA-1,AngMomB+1,ExpPi,CenterAB,CenterPA) + s4 = HRROv(AngMomA+1,AngMomB+1,ExpPi,CenterAB,CenterPA) + + Gab = 0.5d0*a*b*s1 - ExpA*b*s2 - a*ExpB*s3 + 2d0*ExpA*ExpB*s4 + + +end function RRKin diff --git a/src/IntPak/ReadBasis.f90 b/src/IntPak/ReadBasis.f90 new file mode 100644 index 0000000..9a1db2a --- /dev/null +++ b/src/IntPak/ReadBasis.f90 @@ -0,0 +1,176 @@ +subroutine ReadBasis(NAtoms,XYZAtoms,nShell,CenterShell, & + TotAngMomShell,KShell,DShell,ExpShell) + +! Read basis set information + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: NAtoms + double precision,intent(in) :: XYZAtoms(NAtoms,3) + +! Local variables + + integer :: nShAt,iAt + integer :: i,j,k + character :: shelltype + +! Output variables + + integer,intent(out) :: nShell + double precision,intent(out) :: CenterShell(maxShell,3) + integer,intent(out) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(out) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +!------------------------------------------------------------------------ +! Primary basis set information +!------------------------------------------------------------------------ + +! Open file with basis set specification + + open(unit=2,file='input/basis') + +! Read basis information + + write(*,'(A28)') 'Gaussian basis set' + write(*,'(A28)') '------------------' + + nShell = 0 + do i=1,NAtoms + read(2,*) iAt,nShAt + write(*,'(A28,1X,I16)') 'Atom n. ',iAt + write(*,'(A28,1X,I16)') 'number of shells ',nShAt + write(*,'(A28)') '------------------' + +! Basis function centers + + do j=1,nShAt + nShell = nShell + 1 + do k=1,3 + CenterShell(nShell,k) = XYZAtoms(iAt,k) + enddo + +! Shell type and contraction degree + + read(2,*) shelltype,KShell(nShell) + if(shelltype == "S") then + TotAngMomShell(nShell) = 0 + write(*,'(A28,1X,I16)') 's-type shell with K = ',KShell(nShell) + elseif(shelltype == "P") then + TotAngMomShell(nShell) = 1 + write(*,'(A28,1X,I16)') 'p-type shell with K = ',KShell(nShell) + elseif(shelltype == "D") then + TotAngMomShell(nShell) = 2 + write(*,'(A28,1X,I16)') 'd-type shell with K = ',KShell(nShell) + elseif(shelltype == "F") then + TotAngMomShell(nShell) = 3 + write(*,'(A28,1X,I16)') 'f-type shell with K = ',KShell(nShell) + elseif(shelltype == "G") then + TotAngMomShell(nShell) = 4 + write(*,'(A28,1X,I16)') 'g-type shell with K = ',KShell(nShell) + elseif(shelltype == "H") then + TotAngMomShell(nShell) = 5 + write(*,'(A28,1X,I16)') 'h-type shell with K = ',KShell(nShell) + elseif(shelltype == "I") then + TotAngMomShell(nShell) = 6 + write(*,'(A28,1X,I16)') 'i-type shell with K = ',KShell(nShell) + endif + +! Read exponents and contraction coefficients + + write(*,'(A28,1X,A16,A16)') '','Exponents','Contraction' + do k=1,Kshell(nShell) + read(2,*) ExpShell(nShell,k),DShell(nShell,k) + write(*,'(A28,1X,F16.10,F16.10)') '',ExpShell(nShell,k),DShell(nShell,k) + enddo + enddo + write(*,'(A28)') '------------------' + enddo + +! Total number of shells + + write(*,'(A28,1X,I16)') 'Number of shells in OBS',nShell + write(*,'(A28)') '------------------' + write(*,*) + +! Close file with basis set specification + + close(unit=2) + +!------------------------------------------------------------------------ +! Auxiliary basis set information +!------------------------------------------------------------------------ + +! Open file with auxilairy basis specification + + open(unit=3,file='input/auxbasis') + +! Read basis information + + write(*,'(A28)') 'Auxiliary basis set' + write(*,'(A28)') '-------------------' + + do i=1,NAtoms + read(3,*) iAt,nShAt + write(*,'(A28,1X,I16)') 'Atom n. ',iAt + write(*,'(A28,1X,I16)') 'number of shells ',nShAt + write(*,'(A28)') '------------------' + +! Basis function centers + + do j=1,nShAt + nShell = nShell + 1 + do k=1,3 + CenterShell(nShell,k) = XYZAtoms(iAt,k) + enddo + +! Shell type and contraction degree + + read(3,*) shelltype,KShell(nShell) + if(shelltype == "S") then + TotAngMomShell(nShell) = 0 + write(*,'(A28,1X,I16)') 's-type shell with K = ',KShell(nShell) + elseif(shelltype == "P") then + TotAngMomShell(nShell) = 1 + write(*,'(A28,1X,I16)') 'p-type shell with K = ',KShell(nShell) + elseif(shelltype == "D") then + TotAngMomShell(nShell) = 2 + write(*,'(A28,1X,I16)') 'd-type shell with K = ',KShell(nShell) + elseif(shelltype == "F") then + TotAngMomShell(nShell) = 3 + write(*,'(A28,1X,I16)') 'f-type shell with K = ',KShell(nShell) + elseif(shelltype == "G") then + TotAngMomShell(nShell) = 4 + write(*,'(A28,1X,I16)') 'g-type shell with K = ',KShell(nShell) + elseif(shelltype == "H") then + TotAngMomShell(nShell) = 5 + write(*,'(A28,1X,I16)') 'h-type shell with K = ',KShell(nShell) + elseif(shelltype == "I") then + TotAngMomShell(nShell) = 6 + write(*,'(A28,1X,I16)') 'i-type shell with K = ',KShell(nShell) + endif + +! Read exponents and contraction coefficients + + write(*,'(A28,1X,A16,A16)') '','Exponents','Contraction' + do k=1,Kshell(nShell) + read(3,*) ExpShell(nShell,k),DShell(nShell,k) + write(*,'(A28,1X,F16.10,F16.10)') '',ExpShell(nShell,k),DShell(nShell,k) + enddo + enddo + write(*,'(A28)') '------------------' + enddo + +! Total number of shells + + write(*,'(A28,1X,I16)') 'Number of shells in ABS',nShell + write(*,'(A28)') '------------------' + write(*,*) + +! Close file with basis set specification + + close(unit=3) + +end subroutine ReadBasis diff --git a/src/IntPak/ReadGeminal.f90 b/src/IntPak/ReadGeminal.f90 new file mode 100644 index 0000000..fcd2c70 --- /dev/null +++ b/src/IntPak/ReadGeminal.f90 @@ -0,0 +1,25 @@ +subroutine ReadGeminal(ExpS) + +! Read the geminal information + + implicit none + +! Input variables + double precision,intent(out) :: ExpS + +! Open file with geometry specification + open(unit=4,file='input/geminal') + +! Read exponent of Slater geminal + read(4,*) ExpS + + + write(*,'(A28)') '------------------' + write(*,'(A28,1X,F16.10)') 'Slater geminal exponent',ExpS + write(*,'(A28)') '------------------' + write(*,*) + +! Close file with geminal information + close(unit=4) + +end subroutine ReadGeminal diff --git a/src/IntPak/ReadGeometry.f90 b/src/IntPak/ReadGeometry.f90 new file mode 100644 index 0000000..8f51671 --- /dev/null +++ b/src/IntPak/ReadGeometry.f90 @@ -0,0 +1,40 @@ +subroutine ReadGeometry(NAtoms,ZNuc,XYZAtoms) + +! Read molecular geometry + + implicit none + +! Input variables + integer,intent(in) :: NAtoms + double precision,intent(out) :: ZNuc(NAtoms),XYZAtoms(NAtoms,3) + +! Local variables + integer :: i + +! Open file with geometry specification + open(unit=1,file='input/molecule') + +! Read number of atoms + read(1,*) + read(1,*) + read(1,*) + + do i=1,NAtoms + read(1,*) ZNuc(i),XYZAtoms(i,1),XYZAtoms(i,2),XYZAtoms(i,3) + enddo + +! Print geometry + write(*,'(A28)') 'Molecular geometry' + write(*,'(A28)') '------------------' + do i=1,NAtoms + write(*,'(A28,1X,I16)') 'Atom n. ',i + write(*,'(A28,1X,F16.10)') 'Z = ',ZNuc(i) + write(*,'(A28,1X,F16.10,F16.10,F16.10)') 'Atom coordinates:',XYZAtoms(i,1),XYZAtoms(i,2),XYZAtoms(i,3) + enddo + write(*,'(A28)') '------------------' + write(*,*) + +! Close file with geometry specification + close(unit=1) + +end subroutine ReadGeometry diff --git a/src/IntPak/ReadNAtoms.f90 b/src/IntPak/ReadNAtoms.f90 new file mode 100644 index 0000000..9f78096 --- /dev/null +++ b/src/IntPak/ReadNAtoms.f90 @@ -0,0 +1,20 @@ +subroutine ReadNAtoms(NAtoms) + +! Read number of atoms + + implicit none + +! Input variables + integer,intent(out) :: NAtoms + +! Open file with geometry specification + open(unit=1,file='input/molecule') + +! Read number of atoms + read(1,*) + read(1,*) NAtoms + +! Close file with geometry specification + close(unit=1) + +end subroutine ReadNAtoms diff --git a/src/IntPak/S2eInt.f90 b/src/IntPak/S2eInt.f90 new file mode 100644 index 0000000..833677d --- /dev/null +++ b/src/IntPak/S2eInt.f90 @@ -0,0 +1,70 @@ +subroutine S2eInt(debug,iType,np2eInt,nSigp2eInt, & + ExpS,KG,DG,ExpG, & + ExpBra,CenterBra,AngMomBra, & + ExpKet,CenterKet,AngMomKet, & + p2eInt) + +! Perform contraction over the operator for two-electron integrals + + implicit none + include 'parameters.h' + + +! Input variables + + logical,intent(in) :: debug + integer,intent(in) :: iType + double precision,intent(in) :: ExpS + integer,intent(in) :: KG + double precision,intent(in) :: DG(KG),ExpG(KG) + double precision,intent(in) :: ExpBra(2),ExpKet(2) + double precision,intent(in) :: CenterBra(2,3),CenterKet(2,3) + integer,intent(in) :: AngMomBra(2,3),AngMomKet(2,3) + +! Local variables + + double precision :: ExpSG + double precision :: G2eInt,GF12Int + + integer :: k + +! Output variables + + integer,intent(out) :: np2eInt,nSigp2eInt + double precision :: p2eInt + + p2eInt = 0d0 + +! Gaussian geminal + + if(iType == 2) then + do k=1,KG + ExpSG = ExpG(k)*ExpS**2 + p2eInt = p2eInt & + + DG(k)*GF12Int(ExpSG, & + ExpBra(1),CenterBra(1,1:3),AngMomBra(1,1:3), & + ExpKet(1),CenterKet(1,1:3),AngMomKet(1,1:3), & + ExpBra(2),CenterBra(2,1:3),AngMomBra(2,1:3), & + ExpKet(2),CenterKet(2,1:3),AngMomKet(2,1:3)) + enddo + else + do k=1,KG + ExpSG = ExpG(k)*ExpS**2 + p2eInt = p2eInt & + + DG(k)*G2eInt(debug,iType, & + ExpSG, & + ExpBra,CenterBra,AngMomBra, & + ExpKet,CenterKet,AngMomKet) + enddo + endif + +! Print result + + np2eInt = np2eInt + 1 + + if(abs(p2eInt) > 1d-15) then + nSigp2eInt = nSigp2eInt + 1 + if(.false.) write(*,'(A15,1X,F16.10)') '[a1a2|b1b2] = ',p2eInt + endif + +end subroutine S2eInt diff --git a/src/IntPak/S3eInt.f90 b/src/IntPak/S3eInt.f90 new file mode 100644 index 0000000..faccdaf --- /dev/null +++ b/src/IntPak/S3eInt.f90 @@ -0,0 +1,58 @@ +subroutine S3eInt(debug,iType,np3eInt,nSigp3eInt, & + ExpS,KG,DG,ExpG, & + ExpBra,CenterBra,AngMomBra, & + ExpKet,CenterKet,AngMomKet, & + p3eInt) + +! Perform contraction over the operators for three-electron integrals + + implicit none + include 'parameters.h' + + +! Input variables + + logical,intent(in) :: debug + integer,intent(in) :: iType + double precision,intent(in) :: ExpS + integer,intent(in) :: KG + double precision,intent(in) :: DG(KG),ExpG(KG) + double precision,intent(in) :: ExpBra(3),ExpKet(3) + double precision,intent(in) :: CenterBra(3,3),CenterKet(3,3) + integer,intent(in) :: AngMomBra(3,3),AngMomKet(3,3) + +! Local variables + + double precision :: ExpSG13,ExpSG23 + double precision :: G3eInt + + integer :: k,l + +! Output variables + + integer,intent(out) :: np3eInt,nSigp3eInt + double precision :: p3eInt + + p3eInt = 0d0 + do k=1,KG + do l=1,KG + ExpSG13 = ExpG(k)*ExpS**2 + ExpSG23 = ExpG(l)*ExpS**2 + p3eInt = p3eInt & + + DG(k)*DG(l)*G3eInt(debug,iType, & + ExpSG13,ExpSG23, & + ExpBra,CenterBra,AngMomBra, & + ExpKet,CenterKet,AngMomKet) + enddo + enddo + +! Print result + + np3eInt = np3eInt + 1 + + if(abs(p3eInt) > 1d-15) then + nSigp3eInt = nSigp3eInt + 1 + if(.false.) write(*,'(A15,1X,F16.10)') '[a1a2a3|b1b2b3] = ',p3eInt + endif + +end subroutine S3eInt diff --git a/src/IntPak/VRR2e.f90 b/src/IntPak/VRR2e.f90 new file mode 100644 index 0000000..0dde145 --- /dev/null +++ b/src/IntPak/VRR2e.f90 @@ -0,0 +1,130 @@ +recursive function VRR2e(m,AngMomBra,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) & + result(a1a2) + +! Compute two-electron integrals over Gaussian geminals + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: m + integer,intent(in) :: AngMomBra(2,3) + integer,intent(in) :: maxm + double precision,intent(in) :: Om(0:maxm),ExpZi(2),ExpY(2,2) + double precision,intent(in) :: CenterZA(2,3),CenterY(2,2,3) + +! Local variables + + logical :: NegAngMomBra(2) + integer :: TotAngMomBra(2) + integer :: a1m(2,3),a2m(2,3) + integer :: a1mm(2,3),a2mm(2,3) + integer :: a1m2m(2,3) + double precision :: fZ(2) + integer :: i,j,xyz + +! Output variables + + double precision :: a1a2 + + do i=1,2 + NegAngMomBra(i) = AngMomBra(i,1) < 0 .or. AngMomBra(i,2) < 0 .or. AngMomBra(i,3) < 0 + TotAngMomBra(i) = AngMomBra(i,1) + AngMomBra(i,2) + AngMomBra(i,3) + enddo + + fZ(1) = ExpY(1,2)*ExpZi(1) + fZ(2) = ExpY(1,2)*ExpZi(2) + +!------------------------------------------------------------------------ +! Termination condition +!------------------------------------------------------------------------ +! if(NegAngMomBra(1) .or. NegAngMomBra(2)) then +! a1a2 = 0d0 +!------------------------------------------------------------------------ +! Fundamental integral: (00|00)^m +!------------------------------------------------------------------------ +! elseif(TotAngMomBra(1) == 0 .and. TotAngMomBra(2) == 0) then + if(TotAngMomBra(1) == 0 .and. TotAngMomBra(2) == 0) then + a1a2 = Om(m) +!------------------------------------------------------------------------ +! 1st vertical recurrence relation (4 terms): (a+0|00)^m +!------------------------------------------------------------------------ + elseif(TotAngMomBra(2) == 0) then + do i=1,2 + do j=1,3 + a1m(i,j) = AngMomBra(i,j) + a1mm(i,j) = AngMomBra(i,j) + enddo + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomBra(1,1) > 0) then + xyz = 1 + elseif(AngMomBra(1,2) > 0) then + xyz = 2 + elseif(AngMomBra(1,3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in VRR2e!' + endif +! End loop over cartesian directions + a1m(1,xyz) = a1m(1,xyz) - 1 + a1mm(1,xyz) = a1mm(1,xyz) - 2 + if(AngMomBra(1,xyz) <= 0) then + a1a2 = 0d0 + elseif(AngMomBra(1,xyz) == 1) then + a1a2 = CenterZA(1,xyz)*VRR2e(m,a1m,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) & + - fZ(1)*CenterY(1,2,xyz)*VRR2e(m+1,a1m,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) + else + a1a2 = CenterZA(1,xyz)*VRR2e(m,a1m,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) & + - fZ(1)*CenterY(1,2,xyz)*VRR2e(m+1,a1m,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) & + + 0.5d0*dble(AngMomBra(1,xyz)-1)*ExpZi(1)*( & + VRR2e(m,a1mm,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) & + - fZ(1)*VRR2e(m+1,a1mm,maxm,Om,ExpZi,ExpY,CenterZA,CenterY)) + endif +!------------------------------------------------------------------------ +! 2nd vertical recurrence relation (5 terms): (a0|c+0)^m +!------------------------------------------------------------------------ + else + do i=1,2 + do j=1,3 + a2m(i,j) = AngMomBra(i,j) + a2mm(i,j) = AngMomBra(i,j) + a1m2m(i,j) = AngMomBra(i,j) + enddo + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomBra(2,1) > 0) then + xyz = 1 + elseif(AngMomBra(2,2) > 0) then + xyz = 2 + elseif(AngMomBra(2,3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in VRR2e!' + endif +! End loop over cartesian directions + a2m(2,xyz) = a2m(2,xyz) - 1 + a2mm(2,xyz) = a2mm(2,xyz) - 2 + a1m2m(1,xyz) = a1m2m(1,xyz) - 1 + a1m2m(2,xyz) = a1m2m(2,xyz) - 1 + if(AngMomBra(2,xyz) <= 0) then + a1a2 = 0d0 + elseif(AngMomBra(2,xyz) == 1) then + a1a2 = CenterZA(2,xyz)*VRR2e(m,a2m,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) & + + fZ(2)*CenterY(1,2,xyz)*VRR2e(m+1,a2m,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) + else + a1a2 = CenterZA(2,xyz)*VRR2e(m,a2m,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) & + + fZ(2)*CenterY(1,2,xyz)*VRR2e(m+1,a2m,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) & + + 0.5d0*dble(AngMomBra(2,xyz)-1)*ExpZi(2)*( & + VRR2e(m,a2mm,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) & + - fZ(2)*VRR2e(m+1,a2mm,maxm,Om,ExpZi,ExpY,CenterZA,CenterY)) + endif + if(AngMomBra(1,xyz) > 0) & + a1a2 = a1a2 & + + 0.5d0*dble(AngMomBra(1,xyz))*fZ(2)*ExpZi(1)*VRR2e(m+1,a1m2m,maxm,Om,ExpZi,ExpY,CenterZA,CenterY) + endif + +end function VRR2e diff --git a/src/IntPak/VRR3e.f90 b/src/IntPak/VRR3e.f90 new file mode 100644 index 0000000..3033bff --- /dev/null +++ b/src/IntPak/VRR3e.f90 @@ -0,0 +1,174 @@ +recursive function VRR3e(m,AngMomBra,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + result(a1a2a3) + +! Vertical recurrence relations for three-electron integrals + + implicit none + include 'parameters.h' + + +! Input variables + + integer,intent(in) :: m + integer,intent(in) :: AngMomBra(3,3) + integer,intent(in) :: maxm + double precision,intent(in) :: Om(0:maxm),ExpZ(3),CenterZA(3,3) + double precision,intent(in) :: DY0(3),DY1(3),D2Y0(3,3),D2Y1(3,3) + +! Local variables + + logical :: NegAngMomBra(3) + integer :: TotAngMomBra(3) + integer :: a1m(3,3),a2m(3,3),a3m(3,3) + integer :: a1mm(3,3),a2mm(3,3),a3mm(3,3) + integer :: a1m2m(3,3),a1m3m(3,3),a2m3m(3,3) + integer :: i,j,xyz + +! Output variables + + double precision :: a1a2a3 + + do i=1,3 + NegAngMomBra(i) = AngMomBra(i,1) < 0 .or. AngMomBra(i,2) < 0 .or. AngMomBra(i,3) < 0 + TotAngMomBra(i) = AngMomBra(i,1) + AngMomBra(i,2) + AngMomBra(i,3) + enddo + +!------------------------------------------------------------------------ +! Termination condition +!------------------------------------------------------------------------ + if(NegAngMomBra(1) .or. NegAngMomBra(2) .or. NegAngMomBra(3)) then + a1a2a3 = 0d0 +!------------------------------------------------------------------------ +! Fundamental integral: (000|000)^m +!------------------------------------------------------------------------ + elseif(TotAngMomBra(1) == 0 .and. TotAngMomBra(2) == 0 .and. TotAngMomBra(3) == 0) then + a1a2a3 = Om(m) +!------------------------------------------------------------------------ +! 1st vertical recurrence relation (4 terms): (a1+00|000)^m +!------------------------------------------------------------------------ + elseif(TotAngMomBra(2) == 0 .and. TotAngMomBra(3) == 0) then + do i=1,3 + do j=1,3 + a1m(i,j) = AngMomBra(i,j) + a1mm(i,j) = AngMomBra(i,j) + enddo + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomBra(1,1) > 0) then + xyz = 1 + elseif(AngMomBra(1,2) > 0) then + xyz = 2 + elseif(AngMomBra(1,3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in VRR3e!' + endif +! End loop over cartesian directions + a1m(1,xyz) = a1m(1,xyz) - 1 + a1mm(1,xyz) = a1mm(1,xyz) - 2 + if(AngMomBra(1,xyz) == 0) then + a1a2a3 = 0d0 + elseif(AngMomBra(1,xyz) == 1) then + a1a2a3 = (CenterZA(1,xyz) - DY0(1))*VRR3e(m, a1m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - (DY1(1) - DY0(1))*VRR3e(m+1,a1m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) + else + a1a2a3 = (CenterZA(1,xyz) - DY0(1))*VRR3e(m, a1m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - (DY1(1) - DY0(1))*VRR3e(m+1,a1m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + + dble(AngMomBra(1,xyz)-1)*(0.5d0/ExpZ(1) - D2Y0(1,1))*VRR3e(m, a1mm,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - dble(AngMomBra(1,xyz)-1)*(D2Y1(1,1) - D2Y0(1,1))*VRR3e(m+1,a1mm,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) + endif +!------------------------------------------------------------------------ +! 2nd vertical recurrence relation (6 terms): (a1a2+0|000)^m +!------------------------------------------------------------------------ + elseif(TotAngMomBra(3) == 0) then + do i=1,3 + do j=1,3 + a2m(i,j) = AngMomBra(i,j) + a2mm(i,j) = AngMomBra(i,j) + a1m2m(i,j) = AngMomBra(i,j) + enddo + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomBra(2,1) > 0) then + xyz = 1 + elseif(AngMomBra(2,2) > 0) then + xyz = 2 + elseif(AngMomBra(2,3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in VRR3e!' + endif +! End loop over cartesian directions + a2m(2,xyz) = a2m(2,xyz) - 1 + a2mm(2,xyz) = a2mm(2,xyz) - 2 + a1m2m(1,xyz) = a1m2m(1,xyz) - 1 + a1m2m(2,xyz) = a1m2m(2,xyz) - 1 + if(AngMomBra(2,xyz) == 0) then + a1a2a3 = 0d0 + elseif(AngMomBra(2,xyz) == 1) then + a1a2a3 = (CenterZA(2,xyz) - DY0(2))*VRR3e(m, a2m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - (DY1(2) - DY0(2))*VRR3e(m+1,a2m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) + else + a1a2a3 = (CenterZA(2,xyz) - DY0(2))*VRR3e(m, a2m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - (DY1(2) - DY0(2))*VRR3e(m+1,a2m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + + dble(AngMomBra(2,xyz)-1)*(0.5d0/ExpZ(2) - D2Y0(2,2))*VRR3e(m, a2mm, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - dble(AngMomBra(2,xyz)-1)*(D2Y1(2,2) - D2Y0(2,2))*VRR3e(m+1,a2mm, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) + endif + if(AngMomBra(1,xyz) > 0) & + a1a2a3 = a1a2a3 & + + dble(AngMomBra(1,xyz))*(-D2Y0(2,1))*VRR3e(m, a1m2m,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - dble(AngMomBra(1,xyz))*(D2Y1(2,1) - D2Y0(2,1))*VRR3e(m+1,a1m2m,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) +!------------------------------------------------------------------------ +! 3rd vertical recurrence relation (8 terms): (a1a2a3+|000)^m +!------------------------------------------------------------------------ + else + do i=1,3 + do j=1,3 + a3m(i,j) = AngMomBra(i,j) + a3mm(i,j) = AngMomBra(i,j) + a1m3m(i,j) = AngMomBra(i,j) + a2m3m(i,j) = AngMomBra(i,j) + enddo + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomBra(3,1) > 0) then + xyz = 1 + elseif(AngMomBra(3,2) > 0) then + xyz = 2 + elseif(AngMomBra(3,3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in VRR3e!' + endif +! End loop over cartesian directions + a3m(3,xyz) = a3m(3,xyz) - 1 + a3mm(3,xyz) = a3mm(3,xyz) - 2 + a1m3m(1,xyz) = a1m3m(1,xyz) - 1 + a1m3m(3,xyz) = a1m3m(3,xyz) - 1 + a2m3m(2,xyz) = a2m3m(2,xyz) - 1 + a2m3m(3,xyz) = a2m3m(3,xyz) - 1 + if(AngMomBra(3,xyz) == 0) then + a1a2a3 = 0d0 + elseif(AngMomBra(3,xyz) == 1) then + a1a2a3 = (CenterZA(3,xyz) - DY0(3))*VRR3e(m, a3m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - (DY1(3) - DY0(3))*VRR3e(m+1,a3m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) + else + a1a2a3 = (CenterZA(3,xyz) - DY0(3))*VRR3e(m, a3m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - (DY1(3) - DY0(3))*VRR3e(m+1,a3m, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + + dble(AngMomBra(3,xyz)-1)*(0.5d0/ExpZ(3) - D2Y0(3,3))*VRR3e(m, a3mm, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - dble(AngMomBra(3,xyz)-1)*(D2Y1(3,3) - D2Y0(3,3))*VRR3e(m+1,a3mm, maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) + endif + if(dble(AngMomBra(1,xyz)) > 0) & + a1a2a3 = a1a2a3 & + + dble(AngMomBra(1,xyz))*(-D2Y0(3,1))*VRR3e(m, a1m3m,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - dble(AngMomBra(1,xyz))*(D2Y1(3,1) - D2Y0(3,1))*VRR3e(m+1,a1m3m,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) + if(dble(AngMomBra(2,xyz)) > 0) & + a1a2a3 = a1a2a3 & + + dble(AngMomBra(2,xyz))*(-D2Y0(3,2))*VRR3e(m, a2m3m,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) & + - dble(AngMomBra(2,xyz))*(D2Y1(3,2) - D2Y0(3,2))*VRR3e(m+1,a2m3m,maxm,Om,ExpZ,CenterZA,DY0,DY1,D2Y0,D2Y1) + endif + +end function VRR3e diff --git a/src/IntPak/VRRF12.f90 b/src/IntPak/VRRF12.f90 new file mode 100644 index 0000000..0537cf9 --- /dev/null +++ b/src/IntPak/VRRF12.f90 @@ -0,0 +1,36 @@ +recursive function VRRF12(AngMomA,AngMomC,fG,gP,gG,gQ,ExpPGQi,CenterPQSq,CenterRA,CenterRC) & + result(Gac) + +! Compute two-electron integrals over Gaussian geminals + + implicit none + +! Input variables + + integer,intent(in) :: AngMomA,AngMomC + double precision,intent(in) :: ExpPGQi + double precision,intent(in) :: fG,gP,gG,gQ + double precision,intent(in) :: CenterPQSq,CenterRA,CenterRC + +! Output variables + + double precision :: Gac + + if(AngMomA < 0 .or. AngMomC < 0) then + Gac = 0d0 + else + if(AngMomA == 0 .and. AngMomC == 0) then + Gac = sqrt(fG)*exp(-CenterPQSq/ExpPGQi) + else + If(AngMomC == 0) then + Gac = CenterRA*VRRF12(AngMomA-1,AngMomC,fG,gP,gG,gQ,ExpPGQi,CenterPQSq,CenterRA,CenterRC) & + + dble(AngMomA-1)*gP*VRRF12(AngMomA-2,AngMomC,fG,gP,gG,gQ,ExpPGQi,CenterPQSq,CenterRA,CenterRC) + else + Gac = CenterRC*VRRF12(AngMomA,AngMomC-1,fG,gP,gG,gQ,ExpPGQi,CenterPQSq,CenterRA,CenterRC) & + + dble(AngMomA)*gG*VRRF12(AngMomA-1,AngMomC-1,fG,gP,gG,gQ,ExpPGQi,CenterPQSq,CenterRA,CenterRC) & + + dble(AngMomC-1)*gQ*VRRF12(AngMomA,AngMomC-2,fG,gP,gG,gQ,ExpPGQi,CenterPQSq,CenterRA,CenterRC) + endIf + endIf + endIf + +end function VRRF12 diff --git a/src/IntPak/VRRNuc.f90 b/src/IntPak/VRRNuc.f90 new file mode 100644 index 0000000..82bd454 --- /dev/null +++ b/src/IntPak/VRRNuc.f90 @@ -0,0 +1,76 @@ +recursive function VRRNuc(m,AngMomA,maxm,Om,ExpPi,CenterAB,CenterPA,CenterPC) & + result(Ga) + +! Compute two-electron integrals over Gaussian geminals + + implicit none + +! Input variables + + integer,intent(in) :: m + integer,intent(in) :: AngMomA(3) + integer,intent(in) :: maxm + double precision,intent(in) :: Om(0:maxm) + double precision,intent(in) :: ExpPi + double precision,intent(in) :: CenterAB(3),CenterPA(3),CenterPC(3) + +! Local variables + + logical :: NegAngMomA + integer :: TotAngMomA + integer :: xyz,am(3),amm(3) + integer :: i + +! Output variables + + double precision :: Ga + + NegAngMomA = AngMomA(1) < 0 .or. AngMomA(2) < 0 .or. AngMomA(3) < 0 + TotAngMomA = AngMomA(1) + AngMomA(2) + AngMomA(3) + +!------------------------------------------------------------------------ +! Termination condition +!------------------------------------------------------------------------ + + if(NegAngMomA) then + + Ga = 0d0 + + else +!------------------------------------------------------------------------ +! Fundamental integral: (0|0)^m +!------------------------------------------------------------------------ + if(TotAngMomA == 0) then + + Ga = Om(m) + + else +!------------------------------------------------------------------------ +! Vertical recurrence relation (4 terms): (a+|0)^m +!------------------------------------------------------------------------ + do i=1,3 + am(i) = AngMomA(i) + amm(i) = AngMomA(i) + enddo +! Loop over cartesian directions + xyz = 0 + if (AngMomA(1) > 0) then + xyz = 1 + elseif(AngMomA(2) > 0) then + xyz = 2 + elseif(AngMomA(3) > 0) then + xyz = 3 + else + write(*,*) 'xyz = 0 in VRRNuc!' + endif +! End loop over cartesian directions + am(xyz) = am(xyz) - 1 + amm(xyz) = amm(xyz) - 2 + Ga = CenterPA(xyz)*VRRNuc(m,am,maxm,Om,ExpPi,CenterAB,CenterPA,CenterPC) & + + 0.5d0*dble(am(xyz))*ExpPi*VRRNuc(m,amm,maxm,Om,ExpPi,CenterAB,CenterPA,CenterPC) & + - CenterPC(xyz)*ExpPi*VRRNuc(m+1,am,maxm,Om,ExpPi,CenterAB,CenterPA,CenterPC) & + - 0.5d0*dble(am(xyz))*ExpPi**2*VRRNuc(m+1,amm,maxm,Om,ExpPi,CenterAB,CenterPA,CenterPC) + endif + endif + +end function VRRNuc diff --git a/src/IntPak/VRROv.f90 b/src/IntPak/VRROv.f90 new file mode 100644 index 0000000..0041318 --- /dev/null +++ b/src/IntPak/VRROv.f90 @@ -0,0 +1,28 @@ +recursive function VRROv(AngMomA,ExpPi,CenterPA) & + result(Ga) + +! Compute two-electron integrals over Gaussian geminals + + implicit none + +! Input variables + + integer,intent(in) :: AngMomA + double precision,intent(in) :: ExpPi + double precision,intent(in) :: CenterPA + +! Output variables + + double precision :: Ga + + if(AngMomA < 0) then + Ga = 0d0 + else + if(AngMomA == 0) then + Ga = 1d0 + else + Ga = CenterPA*VRROv(AngMomA-1,ExpPi,CenterPA) + 0.5d0*dble(AngMomA-1)*ExpPi*VRROv(AngMomA-2,ExpPi,CenterPA) + endif + endif + +end function VRROv diff --git a/src/IntPak/obj/CalcBoysF.o b/src/IntPak/obj/CalcBoysF.o new file mode 100644 index 0000000..e9354b5 Binary files /dev/null and b/src/IntPak/obj/CalcBoysF.o differ diff --git a/src/IntPak/obj/CalcNBasis.o b/src/IntPak/obj/CalcNBasis.o new file mode 100644 index 0000000..493ed81 Binary files /dev/null and b/src/IntPak/obj/CalcNBasis.o differ diff --git a/src/IntPak/obj/CalcOm.o b/src/IntPak/obj/CalcOm.o new file mode 100644 index 0000000..59072d8 Binary files /dev/null and b/src/IntPak/obj/CalcOm.o differ diff --git a/src/IntPak/obj/CalcOm3e.o b/src/IntPak/obj/CalcOm3e.o new file mode 100644 index 0000000..06099fb Binary files /dev/null and b/src/IntPak/obj/CalcOm3e.o differ diff --git a/src/IntPak/obj/CalcOmERI.o b/src/IntPak/obj/CalcOmERI.o new file mode 100644 index 0000000..7bd9fc7 Binary files /dev/null and b/src/IntPak/obj/CalcOmERI.o differ diff --git a/src/IntPak/obj/CalcOmErf.o b/src/IntPak/obj/CalcOmErf.o new file mode 100644 index 0000000..036ee51 Binary files /dev/null and b/src/IntPak/obj/CalcOmErf.o differ diff --git a/src/IntPak/obj/CalcOmNuc.o b/src/IntPak/obj/CalcOmNuc.o new file mode 100644 index 0000000..342f73d Binary files /dev/null and b/src/IntPak/obj/CalcOmNuc.o differ diff --git a/src/IntPak/obj/CalcOmYuk.o b/src/IntPak/obj/CalcOmYuk.o new file mode 100644 index 0000000..96cca68 Binary files /dev/null and b/src/IntPak/obj/CalcOmYuk.o differ diff --git a/src/IntPak/obj/Compute2eInt.o b/src/IntPak/obj/Compute2eInt.o new file mode 100644 index 0000000..1b207ec Binary files /dev/null and b/src/IntPak/obj/Compute2eInt.o differ diff --git a/src/IntPak/obj/Compute3eInt.o b/src/IntPak/obj/Compute3eInt.o new file mode 100644 index 0000000..d3dee1d Binary files /dev/null and b/src/IntPak/obj/Compute3eInt.o differ diff --git a/src/IntPak/obj/Compute4eInt.o b/src/IntPak/obj/Compute4eInt.o new file mode 100644 index 0000000..32a04b6 Binary files /dev/null and b/src/IntPak/obj/Compute4eInt.o differ diff --git a/src/IntPak/obj/ComputeKin.o b/src/IntPak/obj/ComputeKin.o new file mode 100644 index 0000000..57d9f43 Binary files /dev/null and b/src/IntPak/obj/ComputeKin.o differ diff --git a/src/IntPak/obj/ComputeNuc.o b/src/IntPak/obj/ComputeNuc.o new file mode 100644 index 0000000..0e38a42 Binary files /dev/null and b/src/IntPak/obj/ComputeNuc.o differ diff --git a/src/IntPak/obj/ComputeOv.o b/src/IntPak/obj/ComputeOv.o new file mode 100644 index 0000000..0d87d8f Binary files /dev/null and b/src/IntPak/obj/ComputeOv.o differ diff --git a/src/IntPak/obj/FormVRR3e.o b/src/IntPak/obj/FormVRR3e.o new file mode 100644 index 0000000..0b20925 Binary files /dev/null and b/src/IntPak/obj/FormVRR3e.o differ diff --git a/src/IntPak/obj/G2eInt.o b/src/IntPak/obj/G2eInt.o new file mode 100644 index 0000000..dac9610 Binary files /dev/null and b/src/IntPak/obj/G2eInt.o differ diff --git a/src/IntPak/obj/G3eInt.o b/src/IntPak/obj/G3eInt.o new file mode 100644 index 0000000..e7d2695 Binary files /dev/null and b/src/IntPak/obj/G3eInt.o differ diff --git a/src/IntPak/obj/GF12Int.o b/src/IntPak/obj/GF12Int.o new file mode 100644 index 0000000..d1b1caa Binary files /dev/null and b/src/IntPak/obj/GF12Int.o differ diff --git a/src/IntPak/obj/GenerateShell.o b/src/IntPak/obj/GenerateShell.o new file mode 100644 index 0000000..b3685b1 Binary files /dev/null and b/src/IntPak/obj/GenerateShell.o differ diff --git a/src/IntPak/obj/HRR2e.o b/src/IntPak/obj/HRR2e.o new file mode 100644 index 0000000..d344d80 Binary files /dev/null and b/src/IntPak/obj/HRR2e.o differ diff --git a/src/IntPak/obj/HRR3e.o b/src/IntPak/obj/HRR3e.o new file mode 100644 index 0000000..7de757f Binary files /dev/null and b/src/IntPak/obj/HRR3e.o differ diff --git a/src/IntPak/obj/HRRF12.o b/src/IntPak/obj/HRRF12.o new file mode 100644 index 0000000..8b0bccc Binary files /dev/null and b/src/IntPak/obj/HRRF12.o differ diff --git a/src/IntPak/obj/HRRNuc.o b/src/IntPak/obj/HRRNuc.o new file mode 100644 index 0000000..80d4888 Binary files /dev/null and b/src/IntPak/obj/HRRNuc.o differ diff --git a/src/IntPak/obj/HRROv.o b/src/IntPak/obj/HRROv.o new file mode 100644 index 0000000..516457f Binary files /dev/null and b/src/IntPak/obj/HRROv.o differ diff --git a/src/IntPak/obj/IntPak.o b/src/IntPak/obj/IntPak.o new file mode 100644 index 0000000..6b9c6b9 Binary files /dev/null and b/src/IntPak/obj/IntPak.o differ diff --git a/src/IntPak/obj/KinInt.o b/src/IntPak/obj/KinInt.o new file mode 100644 index 0000000..da5f77d Binary files /dev/null and b/src/IntPak/obj/KinInt.o differ diff --git a/src/IntPak/obj/NormCoeff.o b/src/IntPak/obj/NormCoeff.o new file mode 100644 index 0000000..5c0e45d Binary files /dev/null and b/src/IntPak/obj/NormCoeff.o differ diff --git a/src/IntPak/obj/NucInt.o b/src/IntPak/obj/NucInt.o new file mode 100644 index 0000000..3aae4f9 Binary files /dev/null and b/src/IntPak/obj/NucInt.o differ diff --git a/src/IntPak/obj/OvInt.o b/src/IntPak/obj/OvInt.o new file mode 100644 index 0000000..fd8aef7 Binary files /dev/null and b/src/IntPak/obj/OvInt.o differ diff --git a/src/IntPak/obj/RRKin.o b/src/IntPak/obj/RRKin.o new file mode 100644 index 0000000..86aa7c6 Binary files /dev/null and b/src/IntPak/obj/RRKin.o differ diff --git a/src/IntPak/obj/ReadBasis.o b/src/IntPak/obj/ReadBasis.o new file mode 100644 index 0000000..1c00ade Binary files /dev/null and b/src/IntPak/obj/ReadBasis.o differ diff --git a/src/IntPak/obj/ReadGeminal.o b/src/IntPak/obj/ReadGeminal.o new file mode 100644 index 0000000..3b9e0db Binary files /dev/null and b/src/IntPak/obj/ReadGeminal.o differ diff --git a/src/IntPak/obj/ReadGeometry.o b/src/IntPak/obj/ReadGeometry.o new file mode 100644 index 0000000..69cb453 Binary files /dev/null and b/src/IntPak/obj/ReadGeometry.o differ diff --git a/src/IntPak/obj/ReadNAtoms.o b/src/IntPak/obj/ReadNAtoms.o new file mode 100644 index 0000000..c7d5cad Binary files /dev/null and b/src/IntPak/obj/ReadNAtoms.o differ diff --git a/src/IntPak/obj/S2eInt.o b/src/IntPak/obj/S2eInt.o new file mode 100644 index 0000000..5323856 Binary files /dev/null and b/src/IntPak/obj/S2eInt.o differ diff --git a/src/IntPak/obj/S3eInt.o b/src/IntPak/obj/S3eInt.o new file mode 100644 index 0000000..55ba55f Binary files /dev/null and b/src/IntPak/obj/S3eInt.o differ diff --git a/src/IntPak/obj/VRR2e.o b/src/IntPak/obj/VRR2e.o new file mode 100644 index 0000000..8f546b3 Binary files /dev/null and b/src/IntPak/obj/VRR2e.o differ diff --git a/src/IntPak/obj/VRR3e.o b/src/IntPak/obj/VRR3e.o new file mode 100644 index 0000000..1793ed5 Binary files /dev/null and b/src/IntPak/obj/VRR3e.o differ diff --git a/src/IntPak/obj/VRRF12.o b/src/IntPak/obj/VRRF12.o new file mode 100644 index 0000000..a4e1966 Binary files /dev/null and b/src/IntPak/obj/VRRF12.o differ diff --git a/src/IntPak/obj/VRRNuc.o b/src/IntPak/obj/VRRNuc.o new file mode 100644 index 0000000..7d01565 Binary files /dev/null and b/src/IntPak/obj/VRRNuc.o differ diff --git a/src/IntPak/obj/VRROv.o b/src/IntPak/obj/VRROv.o new file mode 100644 index 0000000..9d06af7 Binary files /dev/null and b/src/IntPak/obj/VRROv.o differ diff --git a/src/IntPak/obj/utils.o b/src/IntPak/obj/utils.o new file mode 100644 index 0000000..ccef40c Binary files /dev/null and b/src/IntPak/obj/utils.o differ diff --git a/src/IntPak/utils.f90 b/src/IntPak/utils.f90 new file mode 100644 index 0000000..17d2103 --- /dev/null +++ b/src/IntPak/utils.f90 @@ -0,0 +1,385 @@ +!------------------------------------------------------------------------ + +function KroneckerDelta(i,j) result(delta) + +! Kronecker Delta + + implicit none + +! Input variables + + integer,intent(in) :: i,j + + +! Output variables + + integer :: delta + + if(i == j) then + delta = 1 + else + delta = 0 + endif + +end function KroneckerDelta + +!------------------------------------------------------------------------ + +subroutine matout(m,n,A) + +! Print the MxN array A + + implicit none + + integer,parameter :: ncol = 5 + double precision,parameter :: small = 1d-10 + integer,intent(in) :: m,n + double precision,intent(in) :: A(m,n) + double precision :: B(ncol) + integer :: ilower,iupper,num,i,j + + do ilower=1,n,ncol + iupper = min(ilower + ncol - 1,n) + num = iupper - ilower + 1 + write(*,'(3X,10(7X,I6))') (j,j=ilower,iupper) + do i=1,m + do j=ilower,iupper + B(j-ilower+1) = A(i,j) + enddo + do j=1,num + if(abs(B(j)) < small) B(j) = 0d0 + enddo + write(*,'(I7,10F15.8)') i,(B(j),j=1,num) + enddo + enddo + +end subroutine matout + +!------------------------------------------------------------------------ + +subroutine CalcTrAB(n,A,B,Tr) + +! Calculate the trace of the square matrix A.B + + implicit none + +! Input variables + + integer,intent(in) :: n + double precision,intent(in) :: A(n,n),B(n,n) + +! Local variables + + integer :: i,j + +! Output variables + + double precision,intent(out) :: Tr + + Tr = 0d0 + do i=1,n + do j=1,n + Tr = Tr + A(i,j)*B(j,i) + enddo + enddo + +end subroutine CalcTrAB + +!------------------------------------------------------------------------ + +function EpsilonSwitch(i,j) result(delta) + +! Epsilon function + + implicit none + +! Input variables + + integer,intent(in) :: i,j + integer :: delta + + if(i <= j) then + delta = 1 + else + delta = -1 + endif + +end function EpsilonSwitch + +!------------------------------------------------------------------------ + +function KappaCross(i,j,k) result(kappa) + +! kappa(i,j,k) = eps(i,j) delta(i,k) - eps(k,i) delta(i,j) + + implicit none + +! Input variables + + integer,intent(in) :: i,j,k + +! Local variables + + integer :: EpsilonSwitch,KroneckerDelta + double precision :: kappa + + kappa = dble(EpsilonSwitch(i,j)*KroneckerDelta(i,k) - EpsilonSwitch(k,i)*KroneckerDelta(i,j)) + +end function KappaCross + +!------------------------------------------------------------------------ + +subroutine CalcInv3(a,det) + +! Calculate the inverse and the determinant of a 3x3 matrix + + implicit none + + double precision,intent(inout) :: a(3,3) + double precision, intent(inout) :: det + double precision :: b(3,3) + integer :: i,j + + det = a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2)) & + - a(1,2)*(a(2,1)*a(3,3)-a(2,3)*a(3,1)) & + + a(1,3)*(a(2,1)*a(3,2)-a(2,2)*a(3,1)) + + do i=1,3 + b(i,1) = a(i,1) + b(i,2) = a(i,2) + b(i,3) = a(i,3) + enddo + + a(1,1) = b(2,2)*b(3,3) - b(2,3)*b(3,2) + a(2,1) = b(2,3)*b(3,1) - b(2,1)*b(3,3) + a(3,1) = b(2,1)*b(3,2) - b(2,2)*b(3,1) + + a(1,2) = b(1,3)*b(3,2) - b(1,2)*b(3,3) + a(2,2) = b(1,1)*b(3,3) - b(1,3)*b(3,1) + a(3,2) = b(1,2)*b(3,1) - b(1,1)*b(3,2) + + a(1,3) = b(1,2)*b(2,3) - b(1,3)*b(2,2) + a(2,3) = b(1,3)*b(2,1) - b(1,1)*b(2,3) + a(3,3) = b(1,1)*b(2,2) - b(1,2)*b(2,1) + + do i=1,3 + do j=1,3 + a(i,j) = a(i,j)/det + enddo + enddo + +end subroutine CalcInv3 + +!------------------------------------------------------------------------ + +subroutine CalcInv4(a,det) + + implicit none + + double precision,intent(inout) :: a(4,4) + double precision,intent(inout) :: det + double precision :: b(4,4) + integer :: i,j + + det = a(1,1)*(a(2,2)*(a(3,3)*a(4,4)-a(3,4)*a(4,3)) & + -a(2,3)*(a(3,2)*a(4,4)-a(3,4)*a(4,2)) & + +a(2,4)*(a(3,2)*a(4,3)-a(3,3)*a(4,2))) & + - a(1,2)*(a(2,1)*(a(3,3)*a(4,4)-a(3,4)*a(4,3)) & + -a(2,3)*(a(3,1)*a(4,4)-a(3,4)*a(4,1)) & + +a(2,4)*(a(3,1)*a(4,3)-a(3,3)*a(4,1))) & + + a(1,3)*(a(2,1)*(a(3,2)*a(4,4)-a(3,4)*a(4,2)) & + -a(2,2)*(a(3,1)*a(4,4)-a(3,4)*a(4,1)) & + +a(2,4)*(a(3,1)*a(4,2)-a(3,2)*a(4,1))) & + - a(1,4)*(a(2,1)*(a(3,2)*a(4,3)-a(3,3)*a(4,2)) & + -a(2,2)*(a(3,1)*a(4,3)-a(3,3)*a(4,1)) & + +a(2,3)*(a(3,1)*a(4,2)-a(3,2)*a(4,1))) + do i=1,4 + b(1,i) = a(1,i) + b(2,i) = a(2,i) + b(3,i) = a(3,i) + b(4,i) = a(4,i) + enddo + + a(1,1) = b(2,2)*(b(3,3)*b(4,4)-b(3,4)*b(4,3))-b(2,3)*(b(3,2)*b(4,4)-b(3,4)*b(4,2))+b(2,4)*(b(3,2)*b(4,3)-b(3,3)*b(4,2)) + a(2,1) = -b(2,1)*(b(3,3)*b(4,4)-b(3,4)*b(4,3))+b(2,3)*(b(3,1)*b(4,4)-b(3,4)*b(4,1))-b(2,4)*(b(3,1)*b(4,3)-b(3,3)*b(4,1)) + a(3,1) = b(2,1)*(b(3,2)*b(4,4)-b(3,4)*b(4,2))-b(2,2)*(b(3,1)*b(4,4)-b(3,4)*b(4,1))+b(2,4)*(b(3,1)*b(4,2)-b(3,2)*b(4,1)) + a(4,1) = -b(2,1)*(b(3,2)*b(4,3)-b(3,3)*b(4,2))+b(2,2)*(b(3,1)*b(4,3)-b(3,3)*b(4,1))-b(2,3)*(b(3,1)*b(4,2)-b(3,2)*b(4,1)) + + a(1,2) = -b(1,2)*(b(3,3)*b(4,4)-b(3,4)*b(4,3))+b(1,3)*(b(3,2)*b(4,4)-b(3,4)*b(4,2))-b(1,4)*(b(3,2)*b(4,3)-b(3,3)*b(4,2)) + a(2,2) = b(1,1)*(b(3,3)*b(4,4)-b(3,4)*b(4,3))-b(1,3)*(b(3,1)*b(4,4)-b(3,4)*b(4,1))+b(1,4)*(b(3,1)*b(4,3)-b(3,3)*b(4,1)) + a(3,2) = -b(1,1)*(b(3,2)*b(4,4)-b(3,4)*b(4,2))+b(1,2)*(b(3,1)*b(4,4)-b(3,4)*b(4,1))-b(1,4)*(b(3,1)*b(4,2)-b(3,2)*b(4,1)) + a(4,2) = b(1,1)*(b(3,2)*b(4,3)-b(3,3)*b(4,2))-b(1,2)*(b(3,1)*b(4,3)-b(3,3)*b(4,1))+b(1,3)*(b(3,1)*b(4,2)-b(3,2)*b(4,1)) + + a(1,3) = b(1,2)*(b(2,3)*b(4,4)-b(2,4)*b(4,3))-b(1,3)*(b(2,2)*b(4,4)-b(2,4)*b(4,2))+b(1,4)*(b(2,2)*b(4,3)-b(2,3)*b(4,2)) + a(2,3) = -b(1,1)*(b(2,3)*b(4,4)-b(2,4)*b(4,3))+b(1,3)*(b(2,1)*b(4,4)-b(2,4)*b(4,1))-b(1,4)*(b(2,1)*b(4,3)-b(2,3)*b(4,1)) + a(3,3) = b(1,1)*(b(2,2)*b(4,4)-b(2,4)*b(4,2))-b(1,2)*(b(2,1)*b(4,4)-b(2,4)*b(4,1))+b(1,4)*(b(2,1)*b(4,2)-b(2,2)*b(4,1)) + a(4,3) = -b(1,1)*(b(2,2)*b(4,3)-b(2,3)*b(4,2))+b(1,2)*(b(2,1)*b(4,3)-b(2,3)*b(4,1))-b(1,3)*(b(2,1)*b(4,2)-b(2,2)*b(4,1)) + + a(1,4) = -b(1,2)*(b(2,3)*b(3,4)-b(2,4)*b(3,3))+b(1,3)*(b(2,2)*b(3,4)-b(2,4)*b(3,2))-b(1,4)*(b(2,2)*b(3,3)-b(2,3)*b(3,2)) + a(2,4) = b(1,1)*(b(2,3)*b(3,4)-b(2,4)*b(3,3))-b(1,3)*(b(2,1)*b(3,4)-b(2,4)*b(3,1))+b(1,4)*(b(2,1)*b(3,3)-b(2,3)*b(3,1)) + a(3,4) = -b(1,1)*(b(2,2)*b(3,4)-b(2,4)*b(3,2))+b(1,2)*(b(2,1)*b(3,4)-b(2,4)*b(3,1))-b(1,4)*(b(2,1)*b(3,2)-b(2,2)*b(3,1)) + a(4,4) = b(1,1)*(b(2,2)*b(3,3)-b(2,3)*b(3,2))-b(1,2)*(b(2,1)*b(3,3)-b(2,3)*b(3,1))+b(1,3)*(b(2,1)*b(3,2)-b(2,2)*b(3,1)) + + do i=1,4 + do j=1,4 + a(i,j) = a(i,j)/det + enddo + enddo + +end subroutine CalcInv4 + + +!double precision function binom(i,j) +! implicit none +! integer,intent(in) :: i,j +! double precision :: logfact +! integer, save :: ifirst +! double precision, save :: memo(0:15,0:15) +! integer :: k,l +! if (ifirst == 0) then +! ifirst = 1 +! do k=0,15 +! do l=0,15 +! memo(k,l) = dexp( logfact(k)-logfact(l)-logfact(k-l) ) +! enddo +! enddo +! endif +! if ( (i<=15).and.(j<=15) ) then +! binom = memo(i,j) +! else +! binom = dexp( logfact(i)-logfact(j)-logfact(i-j) ) +! endif +!end +! +!double precision function fact(n) +! implicit none +! integer :: n +! double precision, save :: memo(1:100) +! integer, save :: memomax = 1 +! +! if (n<=memomax) then +! if (n<2) then +! fact = 1.d0 +! else +! fact = memo(n) +! endif +! return +! endif +! +! integer :: i +! memo(1) = 1.d0 +! do i=memomax+1,min(n,100) +! memo(i) = memo(i-1)*dble(i) +! enddo +! memomax = min(n,100) +! double precision :: logfact +! fact = dexp(logfact(n)) +!end function +! +!double precision function logfact(n) +! implicit none +! integer :: n +! double precision, save :: memo(1:100) +! integer, save :: memomax = 1 +! +! if (n<=memomax) then +! if (n<2) then +! logfact = 0.d0 +! else +! logfact = memo(n) +! endif +! return +! endif +! +! integer :: i +! memo(1) = 0.d0 +! do i=memomax+1,min(n,100) +! memo(i) = memo(i-1)+dlog(dble(i)) +! enddo +! memomax = min(n,100) +! logfact = memo(memomax) +! do i=101,n +! logfact += dlog(dble(i)) +! enddo +!end function +! +!double precision function dble_fact(n) +! implicit none +! integer :: n +! double precision :: dble_fact_even, dble_fact_odd +! +! dble_fact = 1.d0 +! +! if(n.lt.0) return +! +! if(iand(n,1).eq.0)then +! dble_fact = dble_fact_even(n) +! else +! dble_fact= dble_fact_odd(n) +! endif +! +!end function +! +!double precision function dble_fact_even(n) result(fact2) +! implicit none +! integer :: n,k +! double precision, save :: memo(0:100) +! integer, save :: memomax = 0 +! double precision :: prod +! +! +! if (n <= memomax) then +! if (n < 2) then +! fact2 = 1.d0 +! else +! fact2 = memo(n) +! endif +! return +! endif +! +! integer :: i +! memo(0)=1.d0 +! memo(1)=1.d0 +! do i=memomax+2,min(n,100),2 +! memo(i) = memo(i-2)* dble(i) +! enddo +! memomax = min(n,100) +! fact2 = memo(memomax) +! +! if (n > 100) then +! double precision :: dble_logfact +! fact2 = dexp(dble_logfact(n)) +! endif +! +!end function +! +!double precision function dble_fact_odd(n) result(fact2) +! implicit none +! integer :: n +! double precision, save :: memo(1:100) +! integer, save :: memomax = 1 +! +! if (n<=memomax) then +! if (n<3) then +! fact2 = 1.d0 +! else +! fact2 = memo(n) +! endif +! return +! endif +! +! integer :: i +! memo(1) = 1.d0 +! do i=memomax+2,min(n,99),2 +! memo(i) = memo(i-2)* dble(i) +! enddo +! memomax = min(n,99) +! fact2 = memo(memomax) +! +! if (n > 99) then +! double precision :: dble_logfact +! fact2 = dexp(dble_logfact(n)) +! endif +! +!end function + diff --git a/src/MCQC/.DS_Store b/src/MCQC/.DS_Store new file mode 100644 index 0000000..5008ddf Binary files /dev/null and b/src/MCQC/.DS_Store differ diff --git a/src/MCQC/.InitWeight.f90 (Pierre-Francois Loos's conflicted copy 2017-10-25).swp b/src/MCQC/.InitWeight.f90 (Pierre-Francois Loos's conflicted copy 2017-10-25).swp new file mode 100644 index 0000000..7825d92 Binary files /dev/null and b/src/MCQC/.InitWeight.f90 (Pierre-Francois Loos's conflicted copy 2017-10-25).swp differ diff --git a/src/MCQC/.MCQC.f90 (Pierre-Francois Loos's conflicted copy 2017-10-27).swp b/src/MCQC/.MCQC.f90 (Pierre-Francois Loos's conflicted copy 2017-10-27).swp new file mode 100644 index 0000000..3aaf389 Binary files /dev/null and b/src/MCQC/.MCQC.f90 (Pierre-Francois Loos's conflicted copy 2017-10-27).swp differ diff --git a/src/MCQC/.MCQC.f90 (Pierre-Francois Loos's conflicted copy 2017-11-28).swp b/src/MCQC/.MCQC.f90 (Pierre-Francois Loos's conflicted copy 2017-11-28).swp new file mode 100644 index 0000000..191f423 Binary files /dev/null and b/src/MCQC/.MCQC.f90 (Pierre-Francois Loos's conflicted copy 2017-11-28).swp differ diff --git a/src/MCQC/ADC.f90 b/src/MCQC/ADC.f90 new file mode 100644 index 0000000..fb04c21 --- /dev/null +++ b/src/MCQC/ADC.f90 @@ -0,0 +1,48 @@ +subroutine ADC(singlet_manifold,triplet_manifold,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,e,ERI) + +! ADC main routine + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: singlet_manifold,triplet_manifold + integer,intent(in) :: maxSCF + double precision,intent(in) :: thresh + integer,intent(in) :: max_diis + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: ispin + + +! Hello world + + write(*,*) + write(*,*)'**********************' + write(*,*)'| ADC(n) module |' + write(*,*)'**********************' + write(*,*) + +! ADC(2) calculation for singlet manifold + + if(singlet_manifold) then + + ispin = 1 + call ADC2(ispin,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,e,ERI) + + endif + +! ADC(2) calculation for triplet manifold + + if(triplet_manifold) then + + ispin = 2 + call ADC2(ispin,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,e,ERI) + + endif + +end subroutine ADC diff --git a/src/MCQC/ADC2.f90 b/src/MCQC/ADC2.f90 new file mode 100644 index 0000000..85d5469 --- /dev/null +++ b/src/MCQC/ADC2.f90 @@ -0,0 +1,359 @@ +subroutine ADC2(ispin,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,e,ERI) + +! Compute ADC(2) excitation energies: see Schirmer, Cederbaum & Walter, PRA, 28 (1983) 1237 + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: ispin + integer,intent(in) :: maxSCF + double precision,intent(in) :: thresh + integer,intent(in) :: max_diis + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: nH,nP,nHH,nPP,nSCF,n_diis + double precision :: Conv + double precision,external :: Kronecker_delta + double precision,allocatable :: B_ADC(:,:),X_ADC(:,:),e_ADC(:),SigInf(:,:),G_ADC(:,:) + double precision,allocatable :: db_ERI(:,:,:,:),eOld(:),error_diis(:,:),e_diis(:,:) + + integer :: i,j,k,l + integer :: a,b,c,d + integer :: p,q,r,s + integer :: nADC,iADC,jADC + + +! Hello world + + write(*,*) + write(*,*)'***********************************' + write(*,*)'| 2nd-order ADC calculation |' + write(*,*)'***********************************' + write(*,*) + +! Number of holes + + nH = nO - nC + nHH = nH*(nH+1)/2 + +! Number of particles + + nP = nV - nR + nPP = nP*(nP+1)/2 + + write(*,*) 'Total states: ',nH+nP + write(*,*) 'Hole states: ',nH + write(*,*) 'Particle states: ',nP + +! Size of ADC(2) matrices + + nADC = nH + nP + nH*nPP + nHH*nP + write(*,'(1X,A25,I3,A6,I6)') 'Size of ADC(2) matrices: ',nADC,' x ',nADC + +! Memory allocation + + allocate(db_ERI(nBas,nBas,nBas,nBas),error_diis(nBas,max_diis),e_diis(nBas,max_diis),eOld(nADC), & + B_ADC(nADC,nADC),X_ADC(nADC,nADC),e_ADC(nADC),G_ADC(nADC,nADC),SigInf(nADC,nADC)) + +! Create double-bar MO integrals + + call antisymmetrize_ERI(ispin,nBas,ERI,db_ERI) + +! Initialization + + Conv = 1d0 + nSCF = 0 + n_diis = 0 + e_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + SigInf(:,:) = 0d0 + eOld(:) = 0d0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ +! +! | e + SigInf (U^I)^t (U^II)^t | +! | | +! B = | U^I K^I + C^I 0 | +! | | +! | U^II 0 K^II + C^II | +! +! + + do while(Conv > thresh .and. nSCF < maxSCF) + + ! + ! Build ADC(2) B matrix -- Eq. (38b) -- + ! + + write(*,'(1X,A7,1X,I4)') 'Cycle: ',nSCF + + ! + ! Diagonal part: static self-energy and epsilon + ! + + B_ADC(:,:) = 0d0 + B_ADC(nC+1:nV,nC+1:nV) = SigInf(nC+1:nV,nC+1:nV) + + jADC = 0 + + do p=nC+1,nV + + jADC = jADC + 1 + B_ADC(jADC,jADC) = e(p) + + enddo + + ! + ! U matrices -- Eq. (40a) -- + ! + + do p=nC+1,nV + + iADC = p - nC + jADC = nH + nP + + ! U^I: 2p-1h -- Eqs. (40a) and (41a) -- + + do i=nC+1,nO + do a=nO+1,nV-nR + do b=a,nV-nR + + jADC = jADC + 1 + B_ADC(iADC,jADC) = db_ERI(p,i,a,b) + + enddo + enddo + enddo + + ! U^II: 2h-1p -- Eqs. (40a) and (41b) -- + + do i=nC+1,nO + do j=i,nO + do a=nO+1,nV-nR + + jADC = jADC + 1 + B_ADC(iADC,jADC) = db_ERI(p,a,i,j) + + enddo + enddo + enddo + + enddo + + ! + ! K matrices -- Eq. (40b) -- + ! + + ! K^I: 2p-1h -- Eqs. (40b) and (41a) -- + + jADC = nH + nP + + do i=nC+1,nO + do a=nO+1,nV-nR + do b=a,nV-nR + + jADC = jADC + 1 + B_ADC(jADC,jADC) = e(a) + e(b) - e(i) + + enddo + enddo + enddo + + ! K^II: 2h-1p -- Eqs. (40b) and (41b) -- + + do i=nC+1,nO + do j=i,nO + do a=nO+1,nV + + jADC = jADC + 1 + B_ADC(jADC,jADC) = e(i) + e(j) - e(a) + + enddo + enddo + enddo + + ! + ! C matrices -- Eq. (42c) + ! + + ! C^I: 2p-1h-TDA -- Eqs. (42a) and (42c) -- + + iADC = nH + nP + + do i=nC+1,nO + do a=nO+1,nV-nR + do b=a,nV-nR + + iADC = iADC + 1 + jADC = nH + nP + + do j=nC+1,nO + do c=nO+1,nV + do d=c,nV-nR + + jADC = jADC + 1 + B_ADC(iADC,jADC) = B_ADC(iADC,jADC) & + + db_ERI(a,b,c,d)*Kronecker_delta(i,j) & + - db_ERI(j,b,i,d)*Kronecker_delta(a,c) & + - db_ERI(j,a,i,c)*Kronecker_delta(b,d) & + + db_ERI(b,a,c,d)*Kronecker_delta(i,j) & + - db_ERI(j,a,i,d)*Kronecker_delta(b,c) & + - db_ERI(j,b,i,c)*Kronecker_delta(a,d) + + enddo + enddo + enddo + + enddo + enddo + enddo + + ! C^II: 2p-1h-TDA -- Eqs. (42b) and (42c) -- + + iADC = nH + nP + nH * nPP + + do i=nC+1,nO + do j=i,nO + do a=nO+1,nV-nR + + iADC = iADC + 1 + jADC = nH + nP + nH*nPP + + do k=nC+1,nO + do l=k,nO + do b=nO+1,nV-nR + + jADC = jADC + 1 + B_ADC(iADC,jADC) = B_ADC(iADC,jADC) & + - db_ERI(i,j,k,l)*Kronecker_delta(a,b) & + + db_ERI(b,j,a,l)*Kronecker_delta(i,k) & + + db_ERI(b,i,a,k)*Kronecker_delta(j,l) & + - db_ERI(j,i,k,l)*Kronecker_delta(a,b) & + + db_ERI(b,i,a,l)*Kronecker_delta(j,k) & + + db_ERI(b,j,a,k)*Kronecker_delta(i,l) + + enddo + enddo + enddo + + enddo + enddo + enddo + + ! Fold B onto itself + + do iADC=1,nADC + do jADC=iADC+1,nADC + + B_ADC(jADC,iADC) = B_ADC(iADC,jADC) + + enddo + enddo + + ! Diagonalize B to obtain X and E -- Eq. (38a) -- + + X_ADC(:,:) = B_ADC(:,:) + call diagonalize_matrix(nADC,X_ADC,e_ADC) + + ! print results + + + write(*,*) '=================================' + write(*,*) 'ADC(2) excitation energies (eV)' + + do iADC=1,nADC + + if(NORM2(X_ADC(1:nH+nP,iADC)) > 0.1d0 ) & + write(*,'(2(2X,F12.6))') e_ADC(iADC)*HaToeV,NORM2(X_ADC(1:nH+nP,iADC)) + + enddo + + write(*,*) '=================================' + + ! Convergence criteria + + Conv = maxval(abs(e_ADC - eOld)) + + ! Store result for next iteration + + eOld(:) = e_ADC(:) + + ! Compute W -- Eq (11) -- + + SigInf(:,:) = 0d0 + + do i=nC+1,nO + do p=nC+1,nV-nR + do q=nC+1,nV-nR + + SigInf(p,q) = SigInf(p,q) - db_ERI(p,i,q,i) + + enddo + enddo + enddo + + ! Compute the one-particle Greeen function -- Eq. (28) -- + + G_ADC(:,:) = 0d0 + + do iADC=1,nADC + + if(e_ADC(iADC) > 0d0 ) cycle + + do p=nC+1,nV-nR + do q=nC+1,nV-nR + + G_ADC(p,q) = G_ADC(p,q) + X_ADC(p,iADC)*X_ADC(q,iADC) + + enddo + enddo + + enddo + + ! Compute static self-energy for next iteration -- Eq. (25) -- + + do p=nC+1,nV-nR + do q=nC+1,nV-nR + do r=nC+1,nV-nR + do s=nC+1,nV-nR + + SigInf(p,q) = SigInf(p,q) + db_ERI(p,r,q,s)*G_ADC(r,s) + + enddo + enddo + enddo + enddo + + ! Print results + +! call print_ADC2(nBas,nO,nSCF,Conv,e,eADC) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + endif + +end subroutine ADC2 diff --git a/src/MCQC/AO_values.f90 b/src/MCQC/AO_values.f90 new file mode 100644 index 0000000..f57124d --- /dev/null +++ b/src/MCQC/AO_values.f90 @@ -0,0 +1,108 @@ +subroutine AO_values(doDrift,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,r,AO,dAO) + +! Compute values of the AOs and their derivatives (if required) + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: doDrift + integer,intent(in) :: nBas,nShell,nWalk + double precision,intent(in) :: CenterShell(maxShell,3) + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + double precision,intent(in) :: r(nWalk,2,3) + +! Local variables + + integer :: atot,nShellFunction,a(3) + integer,allocatable :: ShellFunction(:,:) + double precision :: rASq,xA,yA,zA,NormCoeff,prim + + integer :: iSh,iShF,iK,iW,iEl,iBas,ixyz + +! Output variables + + double precision,intent(out) :: AO(nWalk,2,nBas),dAO(nWalk,2,3,nBas) + +! Initialization + + AO = 0d0 + if(doDrift) dAO = 0d0 + iBas = 0 + +!------------------------------------------------------------------------ +! Loops over shells +!------------------------------------------------------------------------ + do iSh=1,nShell + + atot = TotAngMomShell(iSh) + nShellFunction = (atot*atot + 3*atot + 2)/2 + allocate(ShellFunction(1:nShellFunction,1:3)) + call generate_shell(atot,nShellFunction,ShellFunction) + + do iShF=1,nShellFunction + + iBas = iBas + 1 + a(1) = ShellFunction(iShF,1) + a(2) = ShellFunction(iShF,2) + a(3) = ShellFunction(iShF,3) + + do iW=1,nWalk + do iEl=1,2 + + xA = r(iW,iEl,1) - CenterShell(iSh,1) + yA = r(iW,iEl,2) - CenterShell(iSh,2) + zA = r(iW,iEl,3) - CenterShell(iSh,3) + +! Calculate distance for exponential + + rASq = xA**2 + yA**2 + zA**2 + +!------------------------------------------------------------------------ +! Loops over contraction degrees +!------------------------------------------------------------------------- + do iK=1,KShell(iSh) + +! Calculate the exponential part + prim = DShell(iSh,iK)*NormCoeff(ExpShell(iSh,iK),a)*exp(-ExpShell(iSh,iK)*rASq) + AO(iW,iEl,iBas) = AO(iW,iEl,iBas) + prim + + if(doDrift) then + prim = -2d0*ExpShell(iSh,iK)*prim + do ixyz=1,3 + dAO(iW,iEl,ixyz,iBas) = dAO(iW,iEl,ixyz,iBas) + prim + enddo + endif + + enddo + + if(doDrift) then + + dAO(iW,iEl,1,iBas) = xA**(a(1)+1)*yA**a(2)*zA**a(3)*dAO(iW,iEl,1,iBas) + if(a(1) > 0) dAO(iW,iEl,1,iBas) = dAO(iW,iEl,1,iBas) + dble(a(1))*xA**(a(1)-1)*yA**a(2)*zA**a(3)*AO(iW,iEl,iBas) + + dAO(iW,iEl,2,iBas) = xA**a(1)*yA**(a(2)+1)*zA**a(3)*dAO(iW,iEl,2,iBas) + if(a(2) > 0) dAO(iW,iEl,2,iBas) = dAO(iW,iEl,2,iBas) + dble(a(2))*xA**a(1)*yA**(a(2)-1)*zA**a(3)*AO(iW,iEl,iBas) + + dAO(iW,iEl,3,iBas) = xA**a(1)*yA**a(2)*zA**(a(3)+1)*dAO(iW,iEl,3,iBas) + if(a(3) > 0) dAO(iW,iEl,3,iBas) = dAO(iW,iEl,3,iBas) + dble(a(3))*xA**a(1)*yA**a(2)*zA**(a(3)-1)*AO(iW,iEl,iBas) + + endif + +! Calculate polynmial part + + AO(iW,iEl,iBas) = xA**a(1)*yA**a(2)*zA**a(3)*AO(iW,iEl,iBas) + + enddo + enddo + + enddo + deallocate(ShellFunction) + enddo +!------------------------------------------------------------------------ +! End loops over shells +!------------------------------------------------------------------------ + +end subroutine AO_values diff --git a/src/MCQC/AOtoMO_integral_transform.f90 b/src/MCQC/AOtoMO_integral_transform.f90 new file mode 100644 index 0000000..27bd89d --- /dev/null +++ b/src/MCQC/AOtoMO_integral_transform.f90 @@ -0,0 +1,77 @@ +subroutine AOtoMO_integral_transform(nBas,c,ERI_AO_basis,ERI_MO_basis) + +! AO to MO transformation of two-electron integrals +! Semi-direct O(N^5) algorithm + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: ERI_AO_basis(nBas,nBas,nBas,nBas),c(nBas,nBas) + +! Local variables + + double precision,allocatable :: scr(:,:,:,:) + integer :: mu,nu,la,si,i,j,k,l + +! Output variables + + double precision,intent(out) :: ERI_MO_basis(nBas,nBas,nBas,nBas) + +! Memory allocation + allocate(scr(nBas,nBas,nBas,nBas)) + + scr = 0d0 + do l=1,nBas + do si=1,nBas + do la=1,nBas + do nu=1,nBas + do mu=1,nBas + scr(mu,nu,la,l) = scr(mu,nu,la,l) + ERI_AO_basis(mu,nu,la,si)*c(si,l) + enddo + enddo + enddo + enddo + enddo + + do l=1,nBas + do la=1,nBas + do nu=1,nBas + do i=1,nBas + ERI_MO_basis(i,nu,la,l) = 0d0 + do mu=1,nBas + ERI_MO_basis(i,nu,la,l) = ERI_MO_basis(i,nu,la,l) + c(mu,i)*scr(mu,nu,la,l) + enddo + enddo + enddo + enddo + enddo + + scr = 0d0 + do l=1,nBas + do k=1,nBas + do la=1,nBas + do nu=1,nBas + do i=1,nBas + scr(i,nu,k,l) = scr(i,nu,k,l) + ERI_MO_basis(i,nu,la,l)*c(la,k) + enddo + enddo + enddo + enddo + enddo + + do l=1,nBas + do k=1,nBas + do j=1,nBas + do i=1,nBas + ERI_MO_basis(i,j,k,l) = 0d0 + do nu=1,nBas + ERI_MO_basis(i,j,k,l) = ERI_MO_basis(i,j,k,l) + c(nu,j)*scr(i,nu,k,l) + enddo + enddo + enddo + enddo + enddo + +end subroutine AOtoMO_integral_transform diff --git a/src/MCQC/AOtoMO_oooa.f90 b/src/MCQC/AOtoMO_oooa.f90 new file mode 100644 index 0000000..fc474e0 --- /dev/null +++ b/src/MCQC/AOtoMO_oooa.f90 @@ -0,0 +1,85 @@ +subroutine AOtoMO_oooa(nBas,nO,nA,cO,cA,O,ooOoa) + +! AO to MO transformation of two-electron integrals for the block oooa +! Semi-direct O(N^5) algorithm + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nO,nA + double precision,intent(in) :: cO(nBas,nO),cA(nBas,nA),O(nBas,nBas,nBas,nBas) + +! Local variables + + double precision,allocatable :: scr1(:,:,:,:),scr2(:,:,:,:) + integer :: mu,nu,la,si,i,j,k,x + +! Output variables + + double precision,intent(out) :: ooOoa(nO,nO,nO,nA) + +! Memory allocation + allocate(scr1(nBas,nBas,nBas,nBas),scr2(nBas,nBas,nBas,nBas)) + + write(*,*) + write(*,'(A42)') '----------------------------------------' + write(*,'(A42)') ' AO to MO transformation for oooa block ' + write(*,'(A42)') '----------------------------------------' + write(*,*) + + scr1 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + do x=1,nA + scr1(mu,nu,la,x) = scr1(mu,nu,la,x) + O(mu,nu,la,si)*cA(si,x) + enddo + enddo + enddo + enddo + enddo + + scr2 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do i=1,nO + do x=1,nA + scr2(i,nu,la,x) = scr2(i,nu,la,x) + cO(mu,i)*scr1(mu,nu,la,x) + enddo + enddo + enddo + enddo + enddo + + scr1 = 0d0 + do nu=1,nBas + do la=1,nBas + do i=1,nO + do k=1,nO + do x=1,nA + scr1(i,nu,k,x) = scr1(i,nu,k,x) + scr2(i,nu,la,x)*cO(la,k) + enddo + enddo + enddo + enddo + enddo + + ooOoa = 0d0 + do nu=1,nBas + do i=1,nO + do j=1,nO + do k=1,nO + do x=1,nA + ooOoa(i,j,k,x) = ooOoa(i,j,k,x) + cO(nu,j)*scr1(i,nu,k,x) + enddo + enddo + enddo + enddo + enddo + + deallocate(scr1,scr2) + +end subroutine AOtoMO_oooa diff --git a/src/MCQC/AOtoMO_oooo.f90 b/src/MCQC/AOtoMO_oooo.f90 new file mode 100644 index 0000000..d9ebe47 --- /dev/null +++ b/src/MCQC/AOtoMO_oooo.f90 @@ -0,0 +1,85 @@ +subroutine AOtoMO_oooo(nBas,nO,cO,O,ooOoo) + +! AO to MO transformation of two-electron integrals for the block oooo +! Semi-direct O(N^5) algorithm + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: cO(nBas,nO),O(nBas,nBas,nBas,nBas) + +! Local variables + + double precision,allocatable :: scr1(:,:,:,:),scr2(:,:,:,:) + integer :: mu,nu,la,si,i,j,k,l + +! Output variables + + double precision,intent(out) :: ooOoo(nO,nO,nO,nO) + +! Memory allocation + allocate(scr1(nBas,nBas,nBas,nBas),scr2(nBas,nBas,nBas,nBas)) + + write(*,*) + write(*,'(A42)') '----------------------------------------' + write(*,'(A42)') ' AO to MO transformation for oooo block ' + write(*,'(A42)') '----------------------------------------' + write(*,*) + + scr1 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + do l=1,nO + scr1(mu,nu,la,l) = scr1(mu,nu,la,l) + O(mu,nu,la,si)*cO(si,l) + enddo + enddo + enddo + enddo + enddo + + scr2 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do i=1,nO + do l=1,nO + scr2(i,nu,la,l) = scr2(i,nu,la,l) + cO(mu,i)*scr1(mu,nu,la,l) + enddo + enddo + enddo + enddo + enddo + + scr1 = 0d0 + do nu=1,nBas + do la=1,nBas + do i=1,nO + do k=1,nO + do l=1,nO + scr1(i,nu,k,l) = scr1(i,nu,k,l) + scr2(i,nu,la,l)*cO(la,k) + enddo + enddo + enddo + enddo + enddo + + ooOoo = 0d0 + do nu=1,nBas + do i=1,nO + do j=1,nO + do k=1,nO + do l=1,nO + ooOoo(i,j,k,l) = ooOoo(i,j,k,l) + cO(nu,j)*scr1(i,nu,k,l) + enddo + enddo + enddo + enddo + enddo + + deallocate(scr1,scr2) + +end subroutine AOtoMO_oooo diff --git a/src/MCQC/AOtoMO_oovv.f90 b/src/MCQC/AOtoMO_oovv.f90 new file mode 100644 index 0000000..05365c1 --- /dev/null +++ b/src/MCQC/AOtoMO_oovv.f90 @@ -0,0 +1,77 @@ +subroutine AOtoMO_oovv(nBas,nO,nV,cO,cV,O,ooOvv) + +! AO to MO transformation of two-electron integrals for the block oovv +! Semi-direct O(N^5) algorithm + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nO,nV + double precision,intent(in) :: cO(nBas,nO),cV(nBas,nV),O(nBas,nBas,nBas,nBas) + +! Local variables + + double precision,allocatable :: scr1(:,:,:,:),scr2(:,:,:,:) + integer :: mu,nu,la,si,i,j,a,b + +! Output variables + + double precision,intent(out) :: ooOvv(nO,nO,nV,nV) + +! Memory allocation + allocate(scr1(nBas,nBas,nBas,nBas),scr2(nBas,nBas,nBas,nBas)) + + scr1 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + do b=1,nV + scr1(mu,nu,la,b) = scr1(mu,nu,la,b) + O(mu,nu,la,si)*cV(si,b) + enddo + enddo + enddo + enddo + enddo + + scr2 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do i=1,nO + do b=1,nV + scr2(i,nu,la,b) = scr2(i,nu,la,b) + cO(mu,i)*scr1(mu,nu,la,b) + enddo + enddo + enddo + enddo + enddo + + scr1 = 0d0 + do nu=1,nBas + do la=1,nBas + do i=1,nO + do a=1,nV + do b=1,nV + scr1(i,nu,a,b) = scr1(i,nu,a,b) + scr2(i,nu,la,b)*cV(la,a) + enddo + enddo + enddo + enddo + enddo + + ooOvv = 0d0 + do nu=1,nBas + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + ooOvv(i,j,a,b) = ooOvv(i,j,a,b) + cO(nu,j)*scr1(i,nu,a,b) + enddo + enddo + enddo + enddo + enddo + +end subroutine AOtoMO_oovv diff --git a/src/MCQC/AOtoMO_transform.f90 b/src/MCQC/AOtoMO_transform.f90 new file mode 100644 index 0000000..7919084 --- /dev/null +++ b/src/MCQC/AOtoMO_transform.f90 @@ -0,0 +1,18 @@ +subroutine AOtoMO_transform(nBas,c,A) + +! Perform AO to MO transformation of a matrix A for given coefficients c + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas) + +! Output variables + + double precision,intent(inout):: A(nBas,nBas) + + A = matmul(transpose(c),matmul(A,c)) + +end subroutine AOtoMO_transform diff --git a/src/MCQC/Bethe_Salpeter_A_matrix.f90 b/src/MCQC/Bethe_Salpeter_A_matrix.f90 new file mode 100644 index 0000000..26f02d7 --- /dev/null +++ b/src/MCQC/Bethe_Salpeter_A_matrix.f90 @@ -0,0 +1,44 @@ +subroutine Bethe_Salpeter_A_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,A_lr) + +! Compute the extra term for Bethe-Salpeter equation for linear response + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: Omega(nS),rho(nBas,nBas,nS) + +! Local variables + + double precision :: chi + integer :: i,j,a,b,ia,jb,kc + +! Output variables + + double precision,intent(out) :: A_lr(nS,nS) + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + chi = 0d0 + do kc=1,nS + chi = chi + rho(i,j,kc)*rho(a,b,kc)/Omega(kc) + enddo + + A_lr(ia,jb) = A_lr(ia,jb) - ERI(i,a,j,b) + 4d0*chi + + enddo + enddo + enddo + enddo + +end subroutine Bethe_Salpeter_A_matrix diff --git a/src/MCQC/Bethe_Salpeter_B_matrix.f90 b/src/MCQC/Bethe_Salpeter_B_matrix.f90 new file mode 100644 index 0000000..903e974 --- /dev/null +++ b/src/MCQC/Bethe_Salpeter_B_matrix.f90 @@ -0,0 +1,44 @@ +subroutine Bethe_Salpeter_B_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,B_lr) + +! Compute the extra term for Bethe-Salpeter equation for linear response + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: Omega(nS),rho(nBas,nBas,nS) + +! Local variables + + double precision :: chi + integer :: i,j,a,b,ia,jb,kc + +! Output variables + + double precision,intent(out) :: B_lr(nS,nS) + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + chi = 0d0 + do kc=1,nS + chi = chi + rho(i,b,kc)*rho(a,j,kc)/Omega(kc) + enddo + + B_lr(ia,jb) = B_lr(ia,jb) - ERI(i,a,b,j) + 4d0*chi + + enddo + enddo + enddo + enddo + +end subroutine Bethe_Salpeter_B_matrix diff --git a/src/MCQC/CIS.f90 b/src/MCQC/CIS.f90 new file mode 100644 index 0000000..66142f5 --- /dev/null +++ b/src/MCQC/CIS.f90 @@ -0,0 +1,85 @@ +subroutine CIS(singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ERI,eHF) + +! Perform configuration interaction single calculation` + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),eHF(nBas) + +! Local variables + + logical :: dRPA + logical :: dump_matrix = .false. + logical :: dump_trans = .false. + integer :: ispin + double precision,allocatable :: A(:,:),Omega(:) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Configuration Interaction Singles |' + write(*,*)'************************************************' + write(*,*) + +! Switch on exchange for CIS + + dRPA = .false. + +! Memory allocation + + allocate(A(nS,nS),Omega(nS)) + +! Compute CIS matrix + + if(singlet_manifold) then + + ispin = 1 + call linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,eHF,ERI,A) + + if(dump_matrix) then + print*,'CIS matrix (singlet state)' + call matout(nS,nS,A) + write(*,*) + endif + + call diagonalize_matrix(nS,A,Omega) + call print_excitation('CIS ',ispin,nS,Omega) + + if(dump_trans) then + print*,'Singlet CIS transition vectors' + call matout(nS,nS,A) + write(*,*) + endif + + endif + + if(triplet_manifold) then + + ispin = 2 + call linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,eHF,ERI,A) + + if(dump_matrix) then + print*,'CIS matrix (triplet state)' + call matout(nS,nS,A) + write(*,*) + endif + + call diagonalize_matrix(nS,A,Omega) + call print_excitation('CIS ',ispin,nS,Omega) + + if(dump_trans) then + print*,'Triplet CIS transition vectors' + call matout(nS,nS,A) + write(*,*) + endif + + endif + +end subroutine CIS diff --git a/src/MCQC/Coulomb_matrix_AO_basis.f90 b/src/MCQC/Coulomb_matrix_AO_basis.f90 new file mode 100644 index 0000000..eaf6a3e --- /dev/null +++ b/src/MCQC/Coulomb_matrix_AO_basis.f90 @@ -0,0 +1,34 @@ +subroutine Coulomb_matrix_AO_basis(nBas,P,G,J) + +! Compute Coulomb matrix in the AO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: G(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: mu,nu,la,si + +! Output variables + + double precision,intent(out) :: J(nBas,nBas) + + J = 0d0 + do si=1,nBas + do nu=1,nBas + do la=1,nBas + do mu=1,nBas + J(mu,nu) = J(mu,nu) + P(la,si)*G(mu,la,nu,si) + enddo + enddo + enddo + enddo + + +end subroutine Coulomb_matrix_AO_basis diff --git a/src/MCQC/Coulomb_matrix_MO_basis.f90 b/src/MCQC/Coulomb_matrix_MO_basis.f90 new file mode 100644 index 0000000..1fea11e --- /dev/null +++ b/src/MCQC/Coulomb_matrix_MO_basis.f90 @@ -0,0 +1,26 @@ +subroutine Coulomb_matrix_MO_basis(nBas,c,P,G,J) + +! Compute Coulomb matrix in the MO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas),P(nBas,nBas) + double precision,intent(in) :: G(nBas,nBas,nBas,nBas) + +! Output variables + + double precision,intent(out) :: J(nBas,nBas) + +! Compute Hartree Hamiltonian in the AO basis + + call Coulomb_matrix_AO_basis(nBas,P,G,J) + +! Transform Coulomb matrix in the MO basis + + J = matmul(transpose(c),matmul(J,c)) + +end subroutine Coulomb_matrix_MO_basis diff --git a/src/MCQC/DIIS_extrapolation.f90 b/src/MCQC/DIIS_extrapolation.f90 new file mode 100644 index 0000000..4fb89dc --- /dev/null +++ b/src/MCQC/DIIS_extrapolation.f90 @@ -0,0 +1,61 @@ +subroutine DIIS_extrapolation(n_err,n_e,n_diis,error,e,error_in,e_inout) + +! Perform DIIS extrapolation + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: n_err,n_e + double precision,intent(in) :: error_in(n_err),error(n_err,n_diis),e(n_e,n_diis) + +! Local variables + + double precision :: rcond + double precision,allocatable :: A(:,:),b(:),w(:) + +! Output variables + + integer,intent(inout) :: n_diis + double precision,intent(inout):: e_inout(n_e) + +! Memory allocaiton + + allocate(A(n_diis+1,n_diis+1),b(n_diis+1),w(n_diis+1)) + +! Update DIIS "history" + + call prepend(n_err,n_diis,error,error_in) + call prepend(n_e,n_diis,e,e_inout) + +! Build A matrix + + A(1:n_diis,1:n_diis) = matmul(transpose(error),error) + + A(1:n_diis,n_diis+1) = -1d0 + A(n_diis+1,1:n_diis) = -1d0 + A(n_diis+1,n_diis+1) = +0d0 + +! Build x matrix + + b(1:n_diis) = +0d0 + b(n_diis+1) = -1d0 + +! Solve linear system + + call linear_solve(n_diis+1,A,b,w,rcond) + +! Extrapolate + + if(rcond > 1d-14) then + + e_inout(:) = matmul(w(1:n_diis),transpose(e(:,1:n_diis))) + + else + + n_diis = 0 + + endif +end subroutine DIIS_extrapolation diff --git a/src/MCQC/G0W0.f90 b/src/MCQC/G0W0.f90 new file mode 100644 index 0000000..47f7db5 --- /dev/null +++ b/src/MCQC/G0W0.f90 @@ -0,0 +1,132 @@ +subroutine G0W0(COHSEX,SOSEX,BSE,TDA,singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,Hc,P,ERI_AO_basis,ERI_MO_basis,cHF,eHF,eG0W0) + +! Perform G0W0 calculation + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: COHSEX,SOSEX,BSE,TDA,singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ENuc,ERHF + double precision,intent(in) :: cHF(nBas,nBas),eHF(nBas),Hc(nBas,nBas),P(nBas,nBas) + double precision,intent(in) :: ERI_AO_basis(nBas,nBas,nBas,nBas),ERI_MO_basis(nBas,nBas,nBas,nBas) + +! Local variables + + logical :: dRPA + integer :: ispin + double precision :: EcRPA + double precision,allocatable :: H(:,:),SigmaC(:),Z(:) + double precision,allocatable :: Omega(:,:),XpY(:,:,:),rho(:,:,:,:),rhox(:,:,:,:) + +! Output variables + + double precision :: eG0W0(nBas) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| One-shot G0W0 calculation |' + write(*,*)'************************************************' + write(*,*) + +! SOSEX correction + + if(SOSEX) write(*,*) 'SOSEX correction activated!' + write(*,*) + +! Switch off exchange for G0W0 + + dRPA = .true. + +! Spin manifold + + ispin = 1 + +! Memory allocation + + allocate(H(nBas,nBas),SigmaC(nBas),Z(nBas), & + Omega(nS,nspin),XpY(nS,nS,nspin), & + rho(nBas,nBas,nS,nspin),rhox(nBas,nBas,nS,nspin)) + +! Compute Hartree Hamiltonian in the MO basis + + call Hartree_matrix_MO_basis(nBas,cHF,P,Hc,ERI_AO_basis,H) + +! Compute linear response + + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,eHF,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + +! Compute correlation part of the self-energy + + call excitation_density(nBas,nC,nO,nR,nS,cHF,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + if(SOSEX) call excitation_density_SOSEX(nBas,nC,nO,nR,nS,cHF,ERI_AO_basis,XpY(:,:,ispin),rhox(:,:,:,ispin)) + + call self_energy_correlation_diag(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,eHF, & + Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),SigmaC) + +! COHSEX static approximation + + if(COHSEX) then + + Z(:) = 1d0 + + else + + call renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,eHF,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),Z) + + endif + +! Solve the quasi-particle equation + + eG0W0(:) = eHF(:) + Z(:)*SigmaC(:) + +! Dump results + + call print_excitation('RPA ',ispin,nS,Omega(:,ispin)) + call print_G0W0(nBas,nO,eHF,ENuc,ERHF,SigmaC,Z,eG0W0,EcRPA) + +! Plot stuff + + call plot_GW(nBas,nC,nO,nV,nR,nS,eHF,eG0W0,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin)) + +! Perform BSE calculation + + if(BSE) then + + ! Singlet manifold + + if(singlet_manifold) then + + ispin = 1 + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,eG0W0,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + ! Triplet manifold + + if(triplet_manifold) then + + ispin = 2 + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,eHF,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call excitation_density(nBas,nC,nO,nR,nS,cHF,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,eG0W0,ERI_MO_basis, & + rho(:,:,:,1),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + endif + + +end subroutine G0W0 diff --git a/src/MCQC/GF2.f90 b/src/MCQC/GF2.f90 new file mode 100644 index 0000000..6eab83c --- /dev/null +++ b/src/MCQC/GF2.f90 @@ -0,0 +1,131 @@ +subroutine GF2(maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,V,e0) + +! Perform second-order Green function calculation in diagonal approximation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF + double precision,intent(in) :: thresh + integer,intent(in) :: max_diis + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e0(nBas),V(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: nSCF,n_diis + double precision :: eps,Conv + double precision,allocatable :: eGF2(:),eOld(:),Bpp(:,:,:),error_diis(:,:),e_diis(:,:) + + integer :: i,j,a,b,p,q + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Second-order Green function calculation |' + write(*,*)'************************************************' + write(*,*) + +! Memory allocation + + allocate(Bpp(nBas,nBas,2),eGF2(nBas),eOld(nBas), & + error_diis(nBas,max_diis),e_diis(nBas,max_diis)) + +! Initialization + + Conv = 1d0 + nSCF = 0 + n_diis = 0 + e_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + eGF2(:) = e0(:) + eOld(:) = e0(:) + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF < maxSCF) + + ! Frequency-dependent second-order contribution + + Bpp(:,:,:) = 0d0 + + do p=nC+1,nBas-nR + do q=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + + eps = eGF2(p) + e0(a) - e0(i) - e0(j) + + Bpp(p,q,1) = Bpp(p,q,1) & + + (2d0*V(p,a,i,j) - V(p,a,j,i))*V(q,a,i,j)/eps + + enddo + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do q=nC+1,nBas-nR + do i=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = eGF2(p) + e0(i) - e0(a) - e0(b) + + Bpp(p,q,2) = Bpp(p,q,2) & + + (2d0*V(p,i,a,b) - V(p,i,b,a))*V(q,i,a,b)/eps + + enddo + enddo + enddo + enddo + enddo + + print*,'Sig2 in GF2' + call matout(nBas,nBas,Bpp(:,:,1) + Bpp(:,:,2)) + +! eGF2(:) = e0(:) & +! + Bpp(:,1) + Bpp(:,2) + + Conv = maxval(abs(eGF2 - eOld)) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBas,nBas,n_diis,error_diis,e_diis,eGF2-eOld,eGF2) + + eOld = eGF2 + + ! Print results + + call print_GF2(nBas,nO,nSCF,Conv,e0,eGF2) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + endif + +end subroutine GF2 diff --git a/src/MCQC/GF2_diag.f90 b/src/MCQC/GF2_diag.f90 new file mode 100644 index 0000000..219a38c --- /dev/null +++ b/src/MCQC/GF2_diag.f90 @@ -0,0 +1,124 @@ +subroutine GF2_diag(maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,V,e0) + +! Perform second-order Green function calculation in diagonal approximation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF + double precision,intent(in) :: thresh + integer,intent(in) :: max_diis + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e0(nBas),V(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: nSCF,n_diis + double precision :: eps,Conv + double precision,allocatable :: eGF2(:),eOld(:),Bpp(:,:),error_diis(:,:),e_diis(:,:) + + integer :: i,j,a,b,p + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Second-order Green function calculation |' + write(*,*)'************************************************' + write(*,*) + +! Memory allocation + + allocate(Bpp(nBas,2),eGF2(nBas),eOld(nBas), & + error_diis(nBas,max_diis),e_diis(nBas,max_diis)) + +! Initialization + + Conv = 1d0 + nSCF = 0 + n_diis = 0 + e_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + eGF2(:) = e0(:) + eOld(:) = e0(:) + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF < maxSCF) + + ! Frequency-dependent second-order contribution + + Bpp(:,:) = 0d0 + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + + eps = eGF2(p) + e0(a) - e0(i) - e0(j) + + Bpp(p,1) = Bpp(p,1) & + + (2d0*V(p,a,i,j) - V(p,a,j,i))*V(p,a,i,j)/eps + + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = eGF2(p) + e0(i) - e0(a) - e0(b) + + Bpp(p,2) = Bpp(p,2) & + + (2d0*V(p,i,a,b) - V(p,i,b,a))*V(p,i,a,b)/eps + + enddo + enddo + enddo + enddo + + eGF2(:) = e0(:) & + + Bpp(:,1) + Bpp(:,2) + + Conv = maxval(abs(eGF2 - eOld)) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBas,nBas,n_diis,error_diis,e_diis,eGF2-eOld,eGF2) + + eOld = eGF2 + + ! Print results + + call print_GF2(nBas,nO,nSCF,Conv,e0,eGF2) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + endif + +end subroutine GF2_diag diff --git a/src/MCQC/GF3_diag.f90 b/src/MCQC/GF3_diag.f90 new file mode 100644 index 0000000..b6fbfd6 --- /dev/null +++ b/src/MCQC/GF3_diag.f90 @@ -0,0 +1,488 @@ + subroutine GF3_diag(maxSCF,thresh,max_diis,renormalization,nBas,nC,nO,nV,nR,V,e0) + +! Perform third-order Green function calculation in diagonal approximation + + implicit none + include 'parameters.h' + +! Input variables + + double precision,intent(in) :: thresh + integer,intent(in) :: maxSCF,max_diis,renormalization + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e0(nBas),V(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: nSCF,n_diis + double precision :: eps,eps1,eps2,Conv + double precision,allocatable :: Sig2(:),SigInf(:),Sig3(:),eGF3(:),eOld(:) + double precision,allocatable :: App(:,:),Bpp(:,:),Cpp(:,:),Dpp(:,:) + double precision,allocatable :: Z(:),X2h1p(:),X1h2p(:),Sig2h1p(:),Sig1h2p(:) + double precision,allocatable :: error_diis(:,:),e_diis(:,:) + + integer :: i,j,k,l,a,b,c,d,p + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Third-order Green function calculation |' + write(*,*)'************************************************' + write(*,*) + +! Memory allocation + + allocate(eGF3(nBas),eOld(nBas), & + Sig2(nBas),SigInf(nBas),Sig3(nBas), & + App(nBas,6),Bpp(nBas,2),Cpp(nBas,6),Dpp(nBas,6), & + Z(nBas),X2h1p(nBas),X1h2p(nBas),Sig2h1p(nBas),Sig1h2p(nBas), & + error_diis(nBas,max_diis),e_diis(nBas,max_diis)) + +!------------------------------------------------------------------------ +! Compute third-order frequency-independent contribution +!------------------------------------------------------------------------ + + App(:,:) = 0d0 + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = e0(j) + e0(i) - e0(a) - e0(b) + eps2 = e0(k) + e0(i) - e0(a) - e0(b) + + App(p,1) = App(p,1) & + - (2d0*V(p,k,p,j) - V(p,k,j,p))*(2d0*V(j,i,a,b) - V(j,i,b,a))*V(a,b,k,i)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = e0(j) + e0(i) - e0(a) - e0(b) + eps2 = e0(j) + e0(i) - e0(a) - e0(c) + + App(p,2) = App(p,2) & + + (2d0*V(p,c,p,b) - V(p,c,b,p))*(2d0*V(j,i,a,b) - V(j,i,b,a))*V(j,i,c,a)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = e0(j) + e0(i) - e0(a) - e0(b) + eps2 = e0(j) - e0(c) + + App(p,3) = App(p,3) & + + (2d0*V(p,c,p,j) - V(p,c,j,p))*(2d0*V(j,i,a,b) - V(j,i,b,a))*V(a,b,c,i)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + App(:,4) = App(:,3) + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = e0(j) + e0(i) - e0(a) - e0(b) + eps2 = e0(k) - e0(b) + + App(p,5) = App(p,5) & + - (2d0*V(p,b,p,k) - V(p,b,k,p))*(2d0*V(j,i,a,b) - V(j,i,b,a))*V(i,j,k,a)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + App(:,6) = App(:,5) + +! Frequency-independent part of the third-order self-energy + + SigInf(:) = App(:,1) + App(:,2) + App(:,3) + App(:,4) + App(:,5) + App(:,6) + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + + nSCF = 0 + n_diis = 0 + Conv = 1d0 + Sig2(:) = 0d0 + Sig3(:) = 0d0 + e_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + eGF3(:) = e0(:) + eOld(:) = e0(:) + + do while(Conv > thresh .and. nSCF < maxSCF) + + ! Frequency-dependent second-order contribution + + Bpp(:,:) = 0d0 + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + + eps = eGF3(p) + e0(a) - e0(i) - e0(j) + + Bpp(p,1) = Bpp(p,1) & + + (2d0*V(p,a,i,j) - V(p,a,j,i))*V(p,a,i,j)/eps + + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = eGF3(p) + e0(i) - e0(a) - e0(b) + + Bpp(p,2) = Bpp(p,2) & + + (2d0*V(p,i,a,b) - V(p,i,b,a))*V(p,i,a,b)/eps + + enddo + enddo + enddo + enddo + + ! Total second-order Green function + + Sig2(:) = Bpp(:,1) + Bpp(:,2) + + ! Frequency-dependent third-order contribution: "C" terms + + Cpp(:,:) = 0d0 + + do p=nC+1,nBas-nR + do i=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + do d=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(i) - e0(a) - e0(b) + eps2 = eGF3(p) + e0(i) - e0(c) - e0(d) + + Cpp(p,1) = Cpp(p,1) & + + (2d0*V(p,i,a,b) - V(p,i,b,a))*V(a,b,c,d)*V(p,i,c,d)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(i) - e0(a) - e0(b) + eps2 = e0(j) + e0(k) - e0(a) - e0(b) + + Cpp(p,2) = Cpp(p,2) & + + (2d0*V(p,i,a,b) - V(p,i,b,a))*V(a,b,j,k)*V(p,i,j,k)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + Cpp(:,3) = Cpp(:,2) + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(a) - e0(i) - e0(j) + eps2 = e0(i) + e0(j) - e0(b) - e0(c) + + Cpp(p,4) = Cpp(p,4) & + + (2d0*V(p,a,i,j) - V(p,a,j,i))*V(i,j,b,c)*V(p,a,b,c)/(eps1*eps2) + enddo + enddo + enddo + enddo + enddo + enddo + + Cpp(:,5) = Cpp(:,4) + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do l=nC+1,nO + do a=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(a) - e0(i) - e0(j) + eps2 = eGF3(p) + e0(a) - e0(k) - e0(l) + + Cpp(p,6) = Cpp(p,6) & + - (2d0*V(p,a,k,l) - V(p,a,l,k))*V(k,l,i,j)*V(p,a,i,j)/(eps1*eps2) + enddo + enddo + enddo + enddo + enddo + enddo + + ! Frequency-dependent third-order contribution: "D" terms + + Dpp(:,:) = 0d0 + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(i) - e0(a) - e0(b) + eps2 = eGF3(p) + e0(j) - e0(b) - e0(c) + + Dpp(p,1) = Dpp(p,1) & + + V(p,i,a,b)*(V(a,j,i,c)*( V(p,j,c,b) - 2d0*V(p,j,b,c)) & + + V(a,j,c,i)*( V(p,j,b,c) - 2d0*V(p,j,c,b)))/(eps1*eps2) + + Dpp(p,1) = Dpp(p,1) & + + V(p,i,b,a)*(V(a,j,i,c)*(4d0*V(p,j,b,c) - 2d0*V(p,j,c,b)) & + + V(a,j,c,i)*( V(p,j,c,b) - 2d0*V(p,j,b,c)))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(i) - e0(a) - e0(c) + eps2 = e0(i) + e0(j) - e0(a) - e0(b) + + Dpp(p,2) = Dpp(p,2) & + + V(p,i,c,a)*(V(a,b,i,j)*(4d0*V(p,b,c,j) - 2d0*V(p,b,j,c)) & + + V(a,b,j,i)*( V(p,b,j,c) - 2d0*V(p,b,c,j)))/(eps1*eps2) + + Dpp(p,2) = Dpp(p,2) & + + V(p,i,a,c)*(V(a,b,i,j)*( V(p,b,j,c) - 2d0*V(p,b,c,j)) & + + V(a,b,j,i)*( V(p,b,c,j) - 2d0*V(p,b,j,c)))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + Dpp(:,3) = Dpp(:,2) + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(a) - e0(j) - e0(k) + eps2 = e0(i) + e0(j) - e0(a) - e0(b) + + Dpp(p,4) = Dpp(p,4) & + + V(p,a,k,j)*(V(j,i,a,b)*(4d0*V(p,i,k,b) - 2d0*V(p,i,b,k)) & + + V(j,i,b,a)*( V(p,i,b,k) - 2d0*V(p,i,k,b)))/(eps1*eps2) + + Dpp(p,4) = Dpp(p,4) & + + V(p,a,j,k)*(V(j,i,a,b)*( V(p,i,b,k) - 2d0*V(p,i,k,b)) & + + V(j,i,b,a)*( V(p,i,k,b) - 2d0*V(p,i,b,k)))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + Dpp(:,5) = Dpp(:,4) + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(a) - e0(i) - e0(k) + eps2 = eGF3(p) + e0(b) - e0(j) - e0(k) + + Dpp(p,6) = Dpp(p,6) & + - V(p,a,k,i)*(V(i,b,a,j)*(4d0*V(p,b,k,j) - 2d0*V(p,b,j,k)) & + + V(i,b,j,a)*( V(p,b,j,k) - 2d0*V(p,b,k,j)))/(eps1*eps2) + + Dpp(p,6) = Dpp(p,6) & + - V(p,a,i,k)*(V(i,b,a,j)*( V(p,b,j,k) - 2d0*V(p,b,k,j)) & + + V(i,b,j,a)*( V(p,b,k,j) - 2d0*V(p,b,j,k)))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + +! Compute renormalization factor (if required) + + Z(:) = 1d0 + + if(renormalization == 0) then + + Sig3(:) = SigInf(:) & + + Cpp(:,1) + Cpp(:,2) + Cpp(:,3) + Cpp(:,4) + Cpp(:,5) + Cpp(:,6) & + + Dpp(:,1) + Dpp(:,2) + Dpp(:,3) + Dpp(:,4) + Dpp(:,5) + Dpp(:,6) + + elseif(renormalization == 1) then + + Sig3(:) = SigInf(:) & + + Cpp(:,1) + Cpp(:,2) + Cpp(:,3) + Cpp(:,4) + Cpp(:,5) + Cpp(:,6) & + + Dpp(:,1) + Dpp(:,2) + Dpp(:,3) + Dpp(:,4) + Dpp(:,5) + Dpp(:,6) + + Z(:) = Cpp(:,2) + Cpp(:,3) + Cpp(:,4) + Cpp(:,5) & + + Dpp(:,2) + Dpp(:,3) + Dpp(:,4) + Dpp(:,5) + + Z(nC+1:nBas-nR) = Z(nC+1:nBas-nR)/Sig2(nC+1:nBas-nR) + Z(:) = 1d0/(1d0 - Z(:)) + + Sig3(:) = Z(:)*Sig3(:) + + elseif(renormalization == 2) then + + Sig2h1p(:) = Cpp(:,4) + Cpp(:,5) + Cpp(:,6) + Dpp(:,4) + Dpp(:,5) + Dpp(:,6) + Sig1h2p(:) = Cpp(:,1) + Cpp(:,2) + Cpp(:,3) + Dpp(:,1) + Dpp(:,2) + Dpp(:,3) + + X2h1p(:) = Cpp(:,4) + Cpp(:,5) + Dpp(:,4) + Dpp(:,5) + X1h2p(:) = Cpp(:,2) + Cpp(:,3) + Dpp(:,2) + Dpp(:,3) + + X2h1p(nC+1:nBas-nR) = X2h1p(nC+1:nBas-nR)/Bpp(nC+1:nBas-nR,1) + X1h2p(nC+1:nBas-nR) = X1h2p(nC+1:nBas-nR)/Bpp(nC+1:nBas-nR,2) + + Sig3(:) = SigInf(:) + & + + 1d0/(1d0 - X2h1p(:))*Sig2h1p(:) & + + 1d0/(1d0 - X1h2p(:))*Sig1h2p(:) + + elseif(renormalization == 3) then + + Sig3(:) = SigInf(:) & + + Cpp(:,1) + Cpp(:,2) + Cpp(:,3) + Cpp(:,4) + Cpp(:,5) + Cpp(:,6) & + + Dpp(:,1) + Dpp(:,2) + Dpp(:,3) + Dpp(:,4) + Dpp(:,5) + Dpp(:,6) + + Sig2h1p(:) = Cpp(:,4) + Cpp(:,5) + Cpp(:,6) + Dpp(:,4) + Dpp(:,5) + Dpp(:,6) + Sig1h2p(:) = Cpp(:,1) + Cpp(:,2) + Cpp(:,3) + Dpp(:,1) + Dpp(:,2) + Dpp(:,3) + + X2h1p(:) = Cpp(:,4) + Cpp(:,5) + Dpp(:,4) + Dpp(:,5) + X1h2p(:) = Cpp(:,2) + Cpp(:,3) + Dpp(:,2) + Dpp(:,3) + + X2h1p(nC+1:nBas-nR) = X2h1p(nC+1:nBas-nR)/Bpp(nC+1:nBas-nR,1) + X1h2p(nC+1:nBas-nR) = X1h2p(nC+1:nBas-nR)/Bpp(nC+1:nBas-nR,2) + + Z(:) = X2h1p(:)*Sig2h1p(:) + X1h2p(:)*Sig1h2p(:) + Z(nC+1:nBas-nR) = Z(nC+1:nBas-nR)/(Sig3(nC+1:nBas-nR) - SigInf(nC+1:nBas-nR)) + Z(:) = 1d0/(1d0 - Z(:)) + + Sig3(:) = Z(:)*Sig3(:) + + endif + + ! Total third-order Green function + + eGF3(:) = e0(:) + Sig2(:) + Sig3(:) + + ! Convergence criteria + + Conv = maxval(abs(eGF3 - eOld)) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBas,nBas,n_diis,error_diis,e_diis,eGF3-eOld,eGF3) + + ! Store result for next iteration + + eOld(:) = eGF3(:) + + ! Print results + + call print_GF3(nBas,nO,nSCF,Conv,e0,Z,eGF3) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + endif + +end subroutine GF3_diag diff --git a/src/MCQC/Green_function.f90 b/src/MCQC/Green_function.f90 new file mode 100644 index 0000000..9feb5a3 --- /dev/null +++ b/src/MCQC/Green_function.f90 @@ -0,0 +1,65 @@ +subroutine Green_function(nBas,nO,nV,nWalk,nWP,cO,cV,eO_Quad,eV_Quad,AO, & + o1MO,o2MO,v1MO,v2MO,o11,o12,o21,o22,v11,v12,v21,v22) + +! Calculate the Green functions + + implicit none + + include 'parameters.h' + include 'quadrature.h' + +! Input variables + + integer,intent(in) :: nBas,nO,nV,nWalk,nWP + double precision,intent(in) :: AO(nWalk,2,nBas),cO(nBas,nO),cV(nBas,nV), & + eO_Quad(nQuad,nO),eV_Quad(nQuad,nV) + +! Local variables + + integer :: kW,lW,klW,i,a,q + double precision :: o1MO(nWalk,nO),o2MO(nWalk,nO),v1MO(nWalk,nV),v2MO(nWalk,nV) + +! Output variables + + double precision,intent(out) :: o11(nQuad,nWP),o12(nQuad,nWP),o21(nQuad,nWP),o22(nQuad,nWP) + double precision,intent(out) :: v11(nQuad,nWP),v12(nQuad,nWP),v21(nQuad,nWP),v22(nQuad,nWP) + +! Calculate occupied and virtual MOs + + o1MO = matmul(AO(:,1,:),cO) + o2MO = matmul(AO(:,2,:),cO) + v1MO = matmul(AO(:,1,:),cV) + v2MO = matmul(AO(:,2,:),cV) + +! Compute occupied Green functions + o11 = 0d0 + o12 = 0d0 + o21 = 0d0 + o22 = 0d0 + v11 = 0d0 + v12 = 0d0 + v21 = 0d0 + v22 = 0d0 + + do q=1,nQuad + klW = 0 + do kW=1,nWalk-1 + do lW=kW+1,nWalk + klW = klW + 1 + do i=1,nO + o11(q,klW) = o11(q,klW) + o1MO(kW,i)*o1MO(lW,i)*eO_Quad(q,i) + o12(q,klW) = o12(q,klW) + o1MO(kW,i)*o2MO(lW,i)*eO_Quad(q,i) + o21(q,klW) = o21(q,klW) + o2MO(kW,i)*o1MO(lW,i)*eO_Quad(q,i) + o22(q,klW) = o22(q,klW) + o2MO(kW,i)*o2MO(lW,i)*eO_Quad(q,i) + enddo + do a=1,nV + v11(q,klW) = v11(q,klW) + v1MO(kW,a)*v1MO(lW,a)*eV_Quad(q,a) + v12(q,klW) = v12(q,klW) + v1MO(kW,a)*v2MO(lW,a)*eV_Quad(q,a) + v21(q,klW) = v21(q,klW) + v2MO(kW,a)*v1MO(lW,a)*eV_Quad(q,a) + v22(q,klW) = v22(q,klW) + v2MO(kW,a)*v2MO(lW,a)*eV_Quad(q,a) + enddo + enddo + enddo + enddo + +end subroutine Green_function diff --git a/src/MCQC/Hartree_matrix_AO_basis.f90 b/src/MCQC/Hartree_matrix_AO_basis.f90 new file mode 100644 index 0000000..3ee7368 --- /dev/null +++ b/src/MCQC/Hartree_matrix_AO_basis.f90 @@ -0,0 +1,33 @@ +subroutine Hartree_matrix_AO_basis(nBas,P,Hc,G,H) + +! Compute Hartree matrix in the AO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas),G(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: mu,nu,la,si + +! Output variables + + double precision,intent(out) :: H(nBas,nBas) + + H = Hc + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + H(mu,nu) = H(mu,nu) + P(la,si)*G(mu,la,nu,si) + enddo + enddo + enddo + enddo + +end subroutine Hartree_matrix_AO_basis diff --git a/src/MCQC/Hartree_matrix_MO_basis.f90 b/src/MCQC/Hartree_matrix_MO_basis.f90 new file mode 100644 index 0000000..6cf85bd --- /dev/null +++ b/src/MCQC/Hartree_matrix_MO_basis.f90 @@ -0,0 +1,26 @@ +subroutine Hartree_matrix_MO_basis(nBas,c,P,Hc,G,H) + +! Compute Hartree matrix in the MO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas),P(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas),G(nBas,nBas,nBas,nBas) + +! Output variables + + double precision,intent(out) :: H(nBas,nBas) + +! Compute Hartree matrix in the AO basis + + call Hartree_matrix_AO_basis(nBas,P,Hc,G,H) + +! Transform Hartree matrix in the MO basis + + H = matmul(transpose(c),matmul(H,c)) + +end subroutine Hartree_matrix_MO_basis diff --git a/src/MCQC/MCMP2.f90 b/src/MCQC/MCMP2.f90 new file mode 100644 index 0000000..3851d25 --- /dev/null +++ b/src/MCQC/MCMP2.f90 @@ -0,0 +1,344 @@ + subroutine MCMP2(doDrift,nBas,nC,nO,nV,c,e,EcMP2, & + nMC,nEq,nWalk,dt,nPrint, & + nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + Norm, & + EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) + +! Perform Monte Carlo MP2 calculation + + implicit none + + include 'parameters.h' + include 'quadrature.h' + +! Input variables + + logical,intent(in) :: doDrift + integer,intent(in) :: nBas,nC,nO,nV,nMC,nEq,nWalk,nPrint + double precision,intent(inout):: dt + double precision,intent(in) :: EcMP2(3) + double precision,intent(in) :: c(nBas,nBas),e(nBas) + + integer,intent(in) :: nShell + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: CenterShell(maxShell,3),DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + logical :: AcPh,EqPh,Accept,dump + double precision :: start_Eq,end_Eq,t_Eq,start_Ac,end_Ac,t_Ac + integer :: nWP + double precision :: Norm,NormSq,nData,tau + double precision,allocatable :: chi1(:,:,:),chi2(:,:,:),eta(:) + + double precision,allocatable :: cO(:,:),cV(:,:),eO(:),eV(:),P(:,:),eO_Quad(:,:),eV_Quad(:,:) + double precision,allocatable :: r(:,:,:), r12(:), gAO(:,:,:), g(:,:), w(:) + double precision,allocatable :: rp(:,:,:),r12p(:),gAOp(:,:,:), gp(:,:),wp(:) + double precision,allocatable :: o1MO(:,:),o2MO(:,:),v1MO(:,:),v2MO(:,:) + double precision,allocatable :: o11(:,:),o12(:,:),o21(:,:),o22(:,:) + double precision,allocatable :: v11(:,:),v12(:,:),v21(:,:),v22(:,:) + double precision,allocatable :: fd_Quad(:,:),fx_Quad(:,:),fd(:),fx(:),fdx(:) + + double precision,allocatable :: dgAO(:,:,:,:),dg(:,:,:),dgAOp(:,:,:,:),dgp(:,:,:) + double precision,allocatable :: F(:,:,:),Fp(:,:,:),T(:),Tp(:) + + double precision :: acceptance,D + double precision :: eloc_MP2(3),mean_MP2(3),variance_MP2(3) + + integer :: iW,kW,lW,klW,iMC,q + +! Output variables + + double precision,intent(out) :: EcMCMP2(3),Err_EcMCMP2(3),Var_EcMCMP2(3) + +! Number of distinct walker pairs + + nWP = nWalk*(nWalk-1)/2 + +! Diffusion coefficient + + D = 0.5d0 + +! Do diffusion-drift moves? + + if(doDrift) then + + write(*,*) + write(*,*) '*** Diffusion-drift algorithm ***' + write(*,*) + + else + + write(*,*) + write(*,*) '*** Diffusion-only algorithm ***' + write(*,*) + + endif + +! Print results + + dump = .true. + if(dump) open(unit=13,file='results/data') + +!------------------------------------------------------------------------ +! Memory allocation +!------------------------------------------------------------------------ + allocate(cO(nBas,nO),cV(nBas,nV),eO(nO),eV(nV), & + eO_Quad(nQuad,nO),eV_Quad(nQuad,nV), & + P(nBas,nBas),r(nWalk,2,3),rp(nWalk,2,3), & + chi1(nWalk,2,3),chi2(nWalk,2,3),eta(nWalk), & + r12(nWalk),r12p(nWalk),w(nWalk),wp(nWalk), & + g(nWalk,2),gp(nWalk,2),gAO(nWalk,2,nBas),gAOp(nWalk,2,nBas), & + dg(nWalk,2,3),dgp(nWalk,2,3),dgAO(nWalk,2,3,nBas),dgAOp(nWalk,2,3,nBas), & + o1MO(nWalk,nO),v1MO(nWalk,nV),o2MO(nWalk,nO),v2MO(nWalk,nV), & + o11(nQuad,nWP),v11(nQuad,nWP),o12(nQuad,nWP),v12(nQuad,nWP), & + o21(nQuad,nWP),v21(nQuad,nWP),o22(nQuad,nWP),v22(nQuad,nWP), & + fd_Quad(nQuad,nWP),fd(nWP),fx_Quad(nQuad,nWP),fx(nWP),fdx(nWP), & + T(nWalk),Tp(nWalk),F(nWalk,2,3),Fp(nWalk,2,3)) + +! Split MOs into occupied and virtual sets + + eO(1:nO) = e(nC+1:nC+nO) + eV(1:nV) = e(nC+nO+1:nBas) + + do q=1,nQuad + tau = 1d0/rQuad(q) + eO_Quad(q,1:nO) = exp(+eO(1:nO)*(tau-1d0))*sqrt(tau) + eV_Quad(q,1:nV) = exp(-eV(1:nV)*(tau-1d0))*sqrt(tau) + enddo + + cO(1:nBas,1:nO) = c(1:nBas,nC+1:nC+nO) + cV(1:nBas,1:nV) = c(1:nBas,nC+nO+1:nBas) + +! Compute norm of the trial wave function + + call norm_trial(nBas,nO,cO,P,Norm,NormSq) + +!------------------------------------------------------------------------ +! Initialize MC-MP2 calculation +!------------------------------------------------------------------------ + +! Initialize electron coordinates + + call random_number(r) + r = 2d0*r - 1d0 + +! Compute initial interelectronic distances + + call rij(nWalk,r,r12) + +! Compute initial AO values and their derivatives (if required) + + call AO_values(doDrift,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,r,gAO,dgAO) + +! Compute initial weight function + + call density(doDrift,nBas,nWalk,P,gAO,dgAO,g,dg) + +! Compute initial weights + + w(1:nWalk) = g(1:nWalk,1)*g(1:nWalk,2)/r12(1:nWalk) + +! Compute initial quantum force + + if(doDrift) call drift(nWalk,r,r12,g,dg,F) + +! Equilibration or Accumulation? + + AcPh = .false. + EqPh = .true. + +! Initialization + + nData = 0d0 + acceptance = 0d0 + + mean_MP2 = 0d0 + variance_MP2 = 0d0 + + T = 1d0 + Tp = 1d0 + +!------------------------------------------------------------------------ +! Start main Monte Carlo loop +!------------------------------------------------------------------------ + call cpu_time(start_Eq) + + do iMC=1,nEq+nMC + +! Timings + + if(iMC == nEq + 1) then + AcPh = .true. + EqPh = .false. + write(*,*) 'Time step value at the end of equilibration: dt = ',dt + write(*,*) + call cpu_time(end_Eq) + t_Eq = end_Eq - start_Eq + write(*,*) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for equilibration = ',t_Eq,' seconds' + write(*,*) + call cpu_time(start_Ac) + endif + +! Optimize time step to reach 50% acceptance + + if(EqPh .and. mod(iMC,100) == 0) call optimize_timestep(nWalk,iMC,acceptance,dt) + +! Move electrons + + call random_number(chi1) + call random_number(chi2) + +! Diffusion + + rp(:,:,:) = r(:,:,:) + sqrt(2d0*D*dt)*sqrt(-2d0*log(chi1(:,:,:)))*cos(2d0*pi*chi2(:,:,:)) + +! Drift + + if(doDrift) rp(:,:,:) = rp(:,:,:) + D*dt*F(:,:,:) + +! Compute new interelectronic distances + + call rij(nWalk,rp,r12p) + +! Compute new AO values and their derivatives (if required) + + call AO_values(doDrift,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,rp,gAOp,dgAOp) + + call Density(doDrift,nBas,nWalk,P,gAOp,dgAOp,gp,dgp) + +! Compute new weights + + wp(1:nWalk) = gp(1:nWalk,1)*gp(1:nWalk,2)/r12p(1:nWalk) + +! Compute new quantum force and transition probability + + if(doDrift) then + + call Drift(nWalk,rp,r12p,gp,dgp,Fp) + call transition_probability(nWalk,dt,D,r,rp,F,Fp,T,Tp) + + endif + +! Move for walkers + + call random_number(eta) + + do iW=1,nWalk + + Accept = (wp(iW)*Tp(iW))/(w(iW)*T(iW)) > eta(iW) + + if(Accept) then + + acceptance = acceptance + 1d0 + + r(iW,1:2,1:3) = rp(iW,1:2,1:3) + gAO(iW,1:2,1:nBas) = gAOp(iW,1:2,1:nBas) + r12(iW) = r12p(iW) + w(iW) = wp(iW) + + if(doDrift) F(iW,1:2,1:3) = Fp(iW,1:2,1:3) + + endif + + enddo + +! Accumulation phase + + if(AcPh) then + + nData = nData + 1d0 + +! Calculate Green functions + + call Green_function(nBas,nO,nV,nWalk,nWP,cO,cV,eO_Quad,eV_Quad,gAO, & + o1MO,o2MO,v1MO,v2MO,o11,o12,o21,o22,v11,v12,v21,v22) + +! Compute local energy + + fd_Quad = o11*o22*v11*v22 + o12*o21*v12*v21 + fx_Quad = o11*o22*v12*v21 + o12*o21*v11*v22 + + fd = matmul(wQuad,fd_Quad) + fx = matmul(wQuad,fx_Quad) + + eloc_MP2 = 0d0 + klW = 0 + do kW=1,nWalk-1 + do lW=kW+1,nWalk + klW = klW + 1 + eloc_MP2(2) = eloc_MP2(2) + fd(klW)/(r12(kW)*r12(lW)*w(kW)*w(lW)) + eloc_MP2(3) = eloc_MP2(3) + fx(klW)/(r12(kW)*r12(lW)*w(kW)*w(lW)) + enddo + enddo + + eloc_MP2(2) = -2d0*eloc_MP2(2)/dble(2*nWP) + eloc_MP2(3) = eloc_MP2(3)/dble(2*nWP) + + fdx = -2d0*fd + fx + eloc_MP2(1) = eloc_MP2(2) + eloc_MP2(3) + +! Accumulate results + + mean_MP2 = mean_MP2 + eloc_MP2 + variance_MP2 = variance_MP2 + eloc_MP2*eloc_MP2 + +! Print results + + if(mod(iMC,nPrint) == 0) then + + call compute_error(nData,mean_MP2,variance_MP2,Err_EcMCMP2) + EcMCMP2 = mean_MP2/nData + Var_EcMCMP2 = variance_MP2/nData + EcMCMP2 = Norm*EcMCMP2 + Var_EcMCMP2 = Norm*Var_EcMCMP2 + Err_EcMCMP2 = Norm*Err_EcMCMP2 + + write(*,*) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,I15)') 'Number of data points ','|',int(nData) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10I15)') 'acceptance ','|',int(100*acceptance/dble(nWalk*iMC)) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'MP2 correlation energy Total ','|',EcMCMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',EcMCMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',EcMCMP2(3) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'Statistical error Total ','|',Err_EcMCMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',Err_EcMCMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',Err_EcMCMP2(3) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'Variance Total ','|',Var_EcMCMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',Var_EcMCMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',Var_EcMCMP2(3) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'Dev. wrt deterministic Total ','|',EcMCMP2(1) - EcMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',EcMCMP2(2) - EcMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',EcMCMP2(3) - EcMP2(3) + write(*,*)'-------------------------------------------------------' + + if(dump) write(13,*) int(nData),EcMCMP2(1),Err_EcMCMP2(1) + + endif + + endif + +!------------------------------------------------------------------------ +! End main Monte Carlo loop +!------------------------------------------------------------------------ + enddo + +! Timing + + call cpu_time(end_Ac) + t_Ac = end_Ac - start_Ac + write(*,*) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for accumulation = ',t_Ac,' seconds' + write(*,*) + +! Close files + + if(dump) close(unit=13) + +end subroutine MCMP2 diff --git a/src/MCQC/MCMP2.f90.x b/src/MCQC/MCMP2.f90.x new file mode 100644 index 0000000..3d11fe0 --- /dev/null +++ b/src/MCQC/MCMP2.f90.x @@ -0,0 +1,446 @@ + subroutine MCMP2(varmin,doDrift,nBas,nEl,nC,nO,nV,c,e,EcMP2, & + nMC,nEq,nWalk,dt,nPrint, & + nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + TrialType,Norm,cTrial,gradient,hessian, & + EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) + +! Perform Monte Carlo MP2 calculation + + implicit none + + include 'parameters.h' + include 'quadrature.h' + +! Input variables + + logical,intent(in) :: varmin,doDrift + integer,intent(in) :: nBas,nEl,nC,nO,nV,nMC,nEq,nWalk,nPrint + double precision,intent(inout):: dt + double precision,intent(in) :: EcMP2(3) + double precision,intent(in) :: c(nBas,nBas),e(nBas) + + integer,intent(in) :: nShell + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: CenterShell(maxShell,3),DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + logical :: AcPh,EqPh,Accept,dump + double precision :: start_Eq,end_Eq,t_Eq,start_Ac,end_Ac,t_Ac + integer :: nWP + double precision :: Norm,NormSq,nData,tau + double precision,allocatable :: chi1(:,:,:),chi2(:,:,:),eta(:) + + double precision,allocatable :: cO(:,:),cV(:,:),eO(:),eV(:),P(:,:),eO_Quad(:,:),eV_Quad(:,:) + double precision,allocatable :: r(:,:,:), r12(:), gAO(:,:,:), g(:,:), w(:) + double precision,allocatable :: rp(:,:,:),r12p(:),gAOp(:,:,:), gp(:,:),wp(:) + double precision,allocatable :: o1MO(:,:),o2MO(:,:),v1MO(:,:),v2MO(:,:) + double precision,allocatable :: o11(:,:),o12(:,:),o21(:,:),o22(:,:) + double precision,allocatable :: v11(:,:),v12(:,:),v21(:,:),v22(:,:) + double precision,allocatable :: fd_Quad(:,:),fx_Quad(:,:),fd(:),fx(:),fdx(:) + + double precision,allocatable :: dgAO(:,:,:,:),dg(:,:,:),dgAOp(:,:,:,:),dgp(:,:,:) + double precision,allocatable :: F(:,:,:),Fp(:,:,:),T(:),Tp(:) + + double precision :: acceptance,D + double precision :: eloc_MP2(3),mean_MP2(3),variance_MP2(3) + + integer :: iW,kW,lW,klW,iMC,i,a,q,iTr,jTr + + double precision :: el,del + double precision,allocatable :: psiTr(:,:),dw(:,:),deloc(:),edeloc(:),mean_de(:),mean_ede(:),mean_dede(:,:) + double precision,allocatable :: dwdw(:),mean_dw(:) + +! Output variables + + double precision,intent(out) :: EcMCMP2(3),Err_EcMCMP2(3),Var_EcMCMP2(3) + + integer,intent(in) :: TrialType + double precision,intent(inout):: cTrial(nBas),gradient(nBas),hessian(nBas,nBas) + +! Number of distinct walker pairs + + nWP = nWalk*(nWalk-1)/2 + +! Diffusion coefficient + + D = 0.5d0 + +! Do diffusion-drift moves? + + write(*,*) + if(doDrift) then + write(*,*) '*** Diffusion-drift algorithm ***' + else + write(*,*) '*** Diffusion-only algorithm ***' + endif + write(*,*) + +! Print results + + dump = .true. + if(dump) open(unit=13,file='results/data') + +! Variance minimization + + if(varmin) then + open(unit=14,file='results/varmin') + endif + +!------------------------------------------------------------------------ +! Memory allocation +!------------------------------------------------------------------------ + allocate(cO(nBas,nO),cV(nBas,nV),eO(nO),eV(nV), & + eO_Quad(nQuad,nO),eV_Quad(nQuad,nV), & + P(nBas,nBas),r(nWalk,2,3),rp(nWalk,2,3), & + chi1(nWalk,2,3),chi2(nWalk,2,3),eta(nWalk), & + r12(nWalk),r12p(nWalk),w(nWalk),wp(nWalk), & + g(nWalk,2),gp(nWalk,2),gAO(nWalk,2,nBas),gAOp(nWalk,2,nBas), & + dg(nWalk,2,3),dgp(nWalk,2,3),dgAO(nWalk,2,3,nBas),dgAOp(nWalk,2,3,nBas), & + o1MO(nWalk,nO),v1MO(nWalk,nV),o2MO(nWalk,nO),v2MO(nWalk,nV), & + o11(nQuad,nWP),v11(nQuad,nWP),o12(nQuad,nWP),v12(nQuad,nWP), & + o21(nQuad,nWP),v21(nQuad,nWP),o22(nQuad,nWP),v22(nQuad,nWP), & + fd_Quad(nQuad,nWP),fd(nWP),fx_Quad(nQuad,nWP),fx(nWP),fdx(nWP), & + T(nWalk),Tp(nWalk),F(nWalk,2,3),Fp(nWalk,2,3)) + + allocate(psiTr(nWalk,2),dw(nWalk,nBas),deloc(nBas),edeloc(nBas), & + mean_de(nBas),mean_ede(nBas),mean_dede(nBas,nBas)) + allocate(dwdw(nBas),mean_dw(nBas)) + +! Split MOs into occupied and virtual sets + + eO(1:nO) = e(nC+1:nC+nO) + eV(1:nV) = e(nC+nO+1:nBas) + + do q=1,nQuad + tau = 1d0/rQuad(q) + do i=1,nO + eO_Quad(q,i) = exp(+eO(i)*(tau-1d0))*sqrt(tau) + enddo + do a=1,nV + eV_Quad(q,a) = exp(-eV(a)*(tau-1d0))*sqrt(tau) + enddo + enddo + + cO(1:nBas,1:nO) = c(1:nBas,nC+1:nC+nO) + cV(1:nBas,1:nV) = c(1:nBas,nC+nO+1:nBas) + +! Compute norm of the trial wave function + + if(TrialType == 0) then + + call NormTrial(TrialType,nBas,nO,cO,P,Norm,NormSq) + + elseif(TrialType == 1) then + + call NormTrial(TrialType,nBas,1,cTrial,P,Norm,NormSq) + + endif + +!------------------------------------------------------------------------ +! Initialize MC-MP2 calculation +!------------------------------------------------------------------------ + +! Initialize electron coordinates + + call random_number(r) + r = 2d0*r - 1d0 + +! Compute initial interelectronic distances + + call rij(nWalk,r,r12) + +! Compute initial AO values and their derivatives (if required) + + call AO_values(doDrift,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,r,gAO,dgAO) + +! Compute initial weight function + + call Density(doDrift,nBas,nWalk,P,gAO,dgAO,g,dg) + +! Compute initial weights + + w(1:nWalk) = g(1:nWalk,1)*g(1:nWalk,2)/r12(1:nWalk) + +! Compute initial quantum force + + if(doDrift) call Drift(nWalk,r,r12,g,dg,F) + +! Equilibration or Accumulation? + + AcPh = .false. + EqPh = .true. + +! Initialization + + nData = 0d0 + acceptance = 0d0 + + mean_MP2 = 0d0 + variance_MP2 = 0d0 + + if(varmin) then + + mean_de = 0d0 + mean_ede = 0d0 + mean_dede = 0d0 +! mean_dw = 0d0 + + endif + + T = 1d0 + Tp = 1d0 + +!------------------------------------------------------------------------ +! Start main Monte Carlo loop +!------------------------------------------------------------------------ + call cpu_time(start_Eq) + + do iMC=1,nEq+nMC + +! Timings + + if(iMC == nEq + 1) then + AcPh = .true. + EqPh = .false. + write(*,*) 'Time step value at the end of equilibration: dt = ',dt + write(*,*) + call cpu_time(end_Eq) + t_Eq = end_Eq - start_Eq + write(*,*) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for equilibration = ',t_Eq,' seconds' + write(*,*) + call cpu_time(start_Ac) + endif + +! Optimize time step to reach 50% acceptance + + if(EqPh .and. mod(iMC,100) == 0) call optimize_timestep(nWalk,iMC,acceptance,dt) + +! Move electrons + + call random_number(chi1) + call random_number(chi2) + +! Diffusion + + rp = r + sqrt(2d0*D*dt)*sqrt(-2d0*log(chi1))*cos(2d0*pi*chi2) + +! Drift + + if(doDrift) rp = rp + D*dt*F + +! Compute new interelectronic distances + + call rij(nWalk,rp,r12p) + +! Compute new AO values and their derivatives (if required) + + call AO_values(doDrift,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,rp,gAOp,dgAOp) + + call Density(doDrift,nBas,nWalk,P,gAOp,dgAOp,gp,dgp) + +! Compute new weights + + wp(1:nWalk) = gp(1:nWalk,1)*gp(1:nWalk,2)/r12p(1:nWalk) + +! Compute new quantum force and transition probability + + if(doDrift) then + + call Drift(nWalk,rp,r12p,gp,dgp,Fp) + call transition_probability(nWalk,dt,D,r,rp,F,Fp,T,Tp) + + endif + +! Move for walkers + + call random_number(eta) + + do iW=1,nWalk + + Accept = (wp(iW)*Tp(iW))/(w(iW)*T(iW)) > eta(iW) + + if(Accept) then + + acceptance = acceptance + 1d0 + + r(iW,1:2,1:3) = rp(iW,1:2,1:3) + gAO(iW,1:2,1:nBas) = gAOp(iW,1:2,1:nBas) + r12(iW) = r12p(iW) + w(iW) = wp(iW) + + if(doDrift) F(iW,1:2,1:3) = Fp(iW,1:2,1:3) + + endif + + enddo + +! Accumulation phase + + if(AcPh) then + + nData = nData + 1d0 + +! Calculate Green functions + + call Green_function(nBas,nO,nV,nWalk,nWP,cO,cV,eO_Quad,eV_Quad,gAO, & + o1MO,o2MO,v1MO,v2MO,o11,o12,o21,o22,v11,v12,v21,v22) + +! Compute local energy + + fd_Quad = o11*o22*v11*v22 + o12*o21*v12*v21 + fx_Quad = o11*o22*v12*v21 + o12*o21*v11*v22 + + fd = matmul(wQuad,fd_Quad) + fx = matmul(wQuad,fx_Quad) + + eloc_MP2 = 0d0 + klW = 0 + do kW=1,nWalk-1 + do lW=kW+1,nWalk + klW = klW + 1 + eloc_MP2(2) = eloc_MP2(2) + fd(klW)/(r12(kW)*r12(lW)*w(kW)*w(lW)) + eloc_MP2(3) = eloc_MP2(3) + fx(klW)/(r12(kW)*r12(lW)*w(kW)*w(lW)) + enddo + enddo + + eloc_MP2(2) = -2d0*eloc_MP2(2)/dble(2*nWP) + eloc_MP2(3) = eloc_MP2(3)/dble(2*nWP) + + fdx = -2d0*fd + fx + eloc_MP2(1) = eloc_MP2(2) + eloc_MP2(3) + +! Accumulate results + + mean_MP2 = mean_MP2 + eloc_MP2 + variance_MP2 = variance_MP2 + eloc_MP2*eloc_MP2 + +! Accumulation for variane minimization + + if(varmin) then + + psiTr = 0d0 + do iTr=1,nBas + psiTr(:,:) = psiTr(:,:) + cTrial(iTr)*gAO(:,:,iTr) + enddo + + do iW=1,nWalk + do iTr=1,nBas + dw(iW,iTr) = gAO(iW,1,iTr)/psiTr(iW,1) + gAO(iW,2,iTr)/psiTr(iW,2) + enddo + enddo + + deloc = 0d0 + edeloc = 0d0 + dwdw = 0d0 + do iTr=1,nBas + klW = 0 + do kW=1,nWalk-1 + do lW=kW+1,nWalk + klW = klW + 1 + el = fdx(klW)/(r12(kW)*r12(lW)*w(kW)*w(lW)) + del = dw(kW,iTr) + dw(lW,iTr) + deloc(iTr) = deloc(iTr) + del*el + edeloc(iTr) = edeloc(iTr) + del*el*el + dwdw(iTr) = dwdw(iTr) + del + enddo + enddo + enddo + + deloc = -2d0*deloc/dble(2*nWP) + edeloc = -2d0*edeloc/dble(2*nWP) + dwdw = 2d0*dwdw/dble(2*nWP) + mean_de(:) = mean_de(:) + deloc(:) + mean_ede(:) = mean_ede(:) + edeloc(:) + mean_dw(:) = mean_dw(:) + dwdw(:) + + do iTr=1,nBas + do jTr=1,nBas + mean_dede(iTr,jTr) = mean_dede(iTr,jTr) + deloc(iTr)*deloc(jTr) + enddo + enddo + + endif + +! Print results + + if(mod(iMC,nPrint) == 0) then + + ecMCMP2 = mean_MP2/nData + Var_EcMCMP2 = variance_MP2/nData + call CalcError(nData,EcMCMP2,Var_EcMCMP2,Err_EcMCMP2) + EcMCMP2 = Norm*EcMCMP2 + Var_EcMCMP2 = Norm*Var_EcMCMP2 + Err_EcMCMP2 = Norm*Err_EcMCMP2 + + write(*,*) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,I15)') 'Number of data points ','|',int(nData) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10I15)') 'acceptance ','|',int(100*acceptance/dble(nWalk*iMC)) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'MP2 correlation energy Total ','|',EcMCMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',EcMCMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',EcMCMP2(3) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'Statistical error Total ','|',Err_EcMCMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',Err_EcMCMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',Err_EcMCMP2(3) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'Variance Total ','|',Var_EcMCMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',Var_EcMCMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',Var_EcMCMP2(3) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'Dev. wrt deterministic Total ','|',EcMCMP2(1) - EcMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',EcMCMP2(2) - EcMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',EcMCMP2(3) - EcMP2(3) + write(*,*)'-------------------------------------------------------' + + if(dump) write(13,*) int(nData),EcMCMP2(1),Err_EcMCMP2(1) + +! Compute gradient and hessian for variance minimization + + if(varmin) then + + gradient = 2d0*(mean_ede - mean_MP2(1)*mean_de/nData) + + do iTr=1,nBas + do jTr=1,nBas + hessian(iTr,jTr) = 2d0*(mean_dede(iTr,jTr) - mean_de(iTr)*mean_de(jTr)/nData) + enddo + enddo + + gradient = gradient/nData + hessian = hessian/nData + + print*,'gradient' + call matout(nBas,1,gradient) + print*,'hessian' + call matout(nBas,nBas,hessian) + + endif + + endif + + endif + +!------------------------------------------------------------------------ +! End main Monte Carlo loop +!------------------------------------------------------------------------ + enddo + +! Timing + + call cpu_time(end_Ac) + t_Ac = end_Ac - start_Ac + write(*,*) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for accumulation = ',t_Ac,' seconds' + write(*,*) + +! Close files + + if(dump) close(unit=13) + if(varmin) close(unit=14) + +end subroutine MCMP2 diff --git a/src/MCQC/MCQC.f90 b/src/MCQC/MCQC.f90 new file mode 100644 index 0000000..6d94385 --- /dev/null +++ b/src/MCQC/MCQC.f90 @@ -0,0 +1,488 @@ +program MCQC + + implicit none + include 'parameters.h' + + logical :: doHF,doMOM + logical :: doMP2,doMP3,doMP2F12 + logical :: doCIS,doTDHF,doADC + logical :: doGF2,doGF3 + logical :: doG0W0,doevGW,doqsGW + logical :: doMCMP2,doMinMCMP2 + logical :: doeNcusp + integer :: nAt,nBas,nBasCABS,nEl,nC,nO,nV,nR,nS + double precision :: ENuc,ERHF,Norm + double precision :: EcMP2(3),EcMP3,EcMP2F12(3),EcMCMP2(3),Err_EcMCMP2(3),Var_EcMCMP2(3) + + double precision,allocatable :: ZNuc(:),rAt(:,:),cHF(:,:),eHF(:),eG0W0(:),PHF(:,:) + + integer :: nShell + integer,allocatable :: TotAngMomShell(:),KShell(:) + double precision,allocatable :: CenterShell(:,:),DShell(:,:),ExpShell(:,:) + + integer :: TrialType + double precision,allocatable :: cTrial(:),gradient(:),hessian(:,:) + + double precision,allocatable :: S(:,:),T(:,:),V(:,:),Hc(:,:),X(:,:) + double precision,allocatable :: ERI_AO_basis(:,:,:,:),ERI_MO_basis(:,:,:,:) + double precision,allocatable :: F12(:,:,:,:),Yuk(:,:,:,:) + + double precision :: start_HF ,end_HF ,t_HF + double precision :: start_MOM ,end_MOM ,t_MOM + double precision :: start_CIS ,end_CIS ,t_CIS + double precision :: start_TDHF ,end_TDHF ,t_TDHF + double precision :: start_ADC ,end_ADC ,t_ADC + double precision :: start_GF2 ,end_GF2 ,t_GF2 + double precision :: start_GF3 ,end_GF3 ,t_GF3 + double precision :: start_G0W0 ,end_G0W0 ,t_G0W0 + double precision :: start_evGW ,end_evGW ,t_evGW + double precision :: start_qsGW ,end_qsGW ,t_qsGW + double precision :: start_eNcusp ,end_eNcusp ,t_eNcusp + double precision :: start_MP2 ,end_MP2 ,t_MP2 + double precision :: start_MP3 ,end_MP3 ,t_MP3 + double precision :: start_MP2F12 ,end_MP2F12 ,t_MP2F12 + double precision :: start_MCMP2 ,end_MCMP2 ,t_MCMP2 + double precision :: start_MinMCMP2,end_MinMCMP2,t_MinMCMP2 + + integer :: maxSCF_HF,n_diis_HF + double precision :: thresh_HF + logical :: DIIS_HF,guess_type,ortho_type + + logical :: singlet_manifold,triplet_manifold + + integer :: maxSCF_GF,n_diis_GF,renormalization + double precision :: thresh_GF + logical :: DIIS_GF + + integer :: maxSCF_GW,n_diis_GW + double precision :: thresh_GW + logical :: DIIS_GW,COHSEX,SOSEX,BSE,TDA,G0W,GW0,linearize + + integer :: nMC,nEq,nWalk,nPrint,iSeed + double precision :: dt + logical :: doDrift + +! Hello World + + write(*,*) + write(*,*) '********************************' + write(*,*) '* Quack *' + write(*,*) '* __ __ __ *' + write(*,*) '* <(o )___ <(o )___ <(o )___ *' + write(*,*) '* ( ._> / ( ._> / ( ._> / *' + write(*,*) '*|----------------------------|*' + write(*,*) '********************************' + write(*,*) + +! Which calculations do you want to do? + + call read_methods(doHF,doMOM, & + doMP2,doMP3, & + doCIS,doTDHF,doADC, & + doGF2,doGF3, & + doG0W0,doevGW,doqsGW, & + doMCMP2) + +! Read options for methods + + call read_options(maxSCF_HF,thresh_HF,DIIS_HF,n_diis_HF,guess_type,ortho_type, & + singlet_manifold,triplet_manifold, & + maxSCF_GF,thresh_GF,DIIS_GF,n_diis_GF,renormalization, & + maxSCF_GW,thresh_GW,DIIS_GW,n_diis_GW,COHSEX,SOSEX,BSE,TDA,G0W,GW0,linearize, & + nMC,nEq,nWalk,dt,nPrint,iSeed,doDrift) + +! Weird stuff + + doeNCusp = .false. + doMinMCMP2 = .false. + doMP2F12 = .false. + +!------------------------------------------------------------------------ +! Read input information +!------------------------------------------------------------------------ + +! Read number of atoms, number of electrons of the system +! nC = number of core orbitals +! nO = number of occupied orbitals +! nV = number of virtual orbitals (see below) +! nR = number of Rydberg orbitals +! nBas = number of basis functions (see below) +! = nO + nV + + call read_molecule(nAt,nEl,nC,nO,nR) + allocate(ZNuc(nAt),rAt(nAt,3)) + +! Read geometry + + call read_geometry(nAt,ZNuc,rAt,ENuc) + + allocate(CenterShell(maxShell,3),TotAngMomShell(maxShell),KShell(maxShell), & + DShell(maxShell,maxK),ExpShell(maxShell,maxK)) + +!------------------------------------------------------------------------ +! Read basis set information +!------------------------------------------------------------------------ + + call read_basis(nAt,rAt,nBas,nC,nO,nV,nR,nS, & + nShell,TotAngMomShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell) + +!------------------------------------------------------------------------ +! Read auxiliary basis set information +!------------------------------------------------------------------------ + +! call ReadAuxBasis(nAt,rAt,nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell) + +! Compute the number of basis functions + +! call CalcNBasis(nShell,TotAngMomShell,nA) + +! Number of virtual orbitals in complete space + +! nBasCABS = nA - nBas + +!------------------------------------------------------------------------ +! Read one- and two-electron integrals +!------------------------------------------------------------------------ + +! Memory allocation for one- and two-electron integrals + + allocate(cHF(nBas,nBas),eHF(nBas),eG0W0(nBas),PHF(nBas,nBas), & + S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),X(nBas,nBas), & + ERI_AO_basis(nBas,nBas,nBas,nBas),ERI_MO_basis(nBas,nBas,nBas,nBas)) + +! Read integrals + + call read_integrals(nBas,S,T,V,Hc,ERI_AO_basis) + +! Compute orthogonalization matrix + + call orthogonalization_matrix(ortho_type,nBas,S,X) + +!------------------------------------------------------------------------ +! Compute HF energy +!------------------------------------------------------------------------ + + if(doHF) then + + call cpu_time(start_HF) +! call SPHF(maxSCF_HF,thresh_HF,n_diis_HF,guess_type, & +! nBas,nEl,S,T,V,Hc,ERI_AO_basis,X,ENuc,ERHF,cHF,eHF,PHF) + call RHF(maxSCF_HF,thresh_HF,n_diis_HF,guess_type, & + nBas,nO,S,T,V,Hc,ERI_AO_basis,X,ENuc,ERHF,cHF,eHF,PHF) + call cpu_time(end_HF) + + t_HF = end_HF - start_HF + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for HF = ',t_HF,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Maximum overlap method +!------------------------------------------------------------------------ + + if(doMOM) then + + call cpu_time(start_MOM) + call MOM(maxSCF_HF,thresh_HF,n_diis_HF, & + nBas,nO,S,T,V,Hc,ERI_AO_basis,X,ENuc,ERHF,cHF,eHF,PHF) + call cpu_time(end_MOM) + + t_MOM = end_MOM - start_MOM + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MOM = ',t_MOM,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! AO to MO integral transform for post-HF methods +!------------------------------------------------------------------------ + + call AOtoMO_integral_transform(nBas,cHF,ERI_AO_basis,ERI_MO_basis) + +!------------------------------------------------------------------------ +! Compute MP2 energy +!------------------------------------------------------------------------ + + if(doMP2) then + + call cpu_time(start_MP2) +! call SPMP2(nBas,nC,nEl,nBas-nEl,nR,ERI_MO_basis,ENuc,ERHF,eHF,EcMP2) + call MP2(nBas,nC,nO,nV,nR,ERI_MO_basis,ENuc,ERHF,eHF,EcMP2) + call cpu_time(end_MP2) + + t_MP2 = end_MP2 - start_MP2 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP2 = ',t_MP2,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute MP3 energy +!------------------------------------------------------------------------ + + if(doMP3) then + + call cpu_time(start_MP3) + call MP3(nBas,nC,nO,nV,nR,ERI_MO_basis,ERHF,EcMP2(1),eHF,EcMP3) + call cpu_time(end_MP3) + + t_MP3 = end_MP3 - start_MP3 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP3 = ',t_MP3,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute MP2-F12 energy +!------------------------------------------------------------------------ + + if(doMP2F12) then + + call cpu_time(start_MP2F12) +! Memory allocation for one- and two-electron integrals +! allocate(F12(nBas,nBas,nBas,nBas),Yuk(nBas,nBas,nBas,nBas)) +! Read integrals +! call ReadF12Ints(nBas,S,G,F12,Yuk) +! call MP2F12(nBas,nC,nO,nV,nA,G,F12,Yuk,ERHF,EcMP2(1),c,c,EcMP2F12) + call cpu_time(end_MP2F12) + + t_MP2F12 = end_MP2F12 - start_MP2F12 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP2-F12 = ',t_MP2F12,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute CIS excitations +!------------------------------------------------------------------------ + + if(doCIS) then + + call cpu_time(start_CIS) + call CIS(singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ERI_MO_basis,eHF) + call cpu_time(end_CIS) + + t_CIS = end_CIS - start_CIS + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CIS = ',t_CIS,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute TDHF excitations +!------------------------------------------------------------------------ + + if(doTDHF) then + + call cpu_time(start_TDHF) + call TDHF(singlet_manifold,triplet_manifold,nBas,nC,nO,nV,nR,nS,ERI_MO_basis,eHF) +! call SPTDHF(singlet_manifold,triplet_manifold,nBas,nC,nEl,nBas-nEl,nR,nEl*(nBas-nEl),ERI_MO_basis,eHF) + call cpu_time(end_TDHF) + + t_TDHF = end_TDHF - start_TDHF + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for TDHF = ',t_TDHF,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute ADC excitations +!------------------------------------------------------------------------ + + if(doADC) then + + call cpu_time(start_ADC) + call ADC(singlet_manifold,triplet_manifold,maxSCF_GF,thresh_GF,n_diis_GF,nBas,nC,nO,nV,nR,eHF,ERI_MO_basis) + call cpu_time(end_ADC) + + t_ADC = end_ADC - start_ADC + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ADC = ',t_ADC,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute GF2 electronic binding energies +!------------------------------------------------------------------------ + + if(doGF2) then + + call cpu_time(start_GF2) +! call GF2(maxSCF_GF,thresh_GF,n_diis_GF,nBas,nC,nO,nV,nR,ERI_MO_basis,eHF) + call GF2_diag(maxSCF_GF,thresh_GF,n_diis_GF,nBas,nC,nO,nV,nR,ERI_MO_basis,eHF) + call cpu_time(end_GF2) + + t_GF2 = end_GF2 - start_GF2 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF2 = ',t_GF2,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute GF3 electronic binding energies +!------------------------------------------------------------------------ + + if(doGF3) then + + call cpu_time(start_GF3) + call GF3_diag(maxSCF_GF,thresh_GF,n_diis_GF,renormalization,nBas,nC,nO,nV,nR,ERI_MO_basis,eHF) + call cpu_time(end_GF3) + + t_GF3 = end_GF3 - start_GF3 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF3 = ',t_GF3,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Perform G0W0 calculatiom +!------------------------------------------------------------------------ + + eG0W0(:) = eHF(:) + + if(doG0W0) then + + call cpu_time(start_G0W0) + call G0W0(COHSEX,SOSEX,BSE,TDA,singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,Hc,PHF,ERI_AO_basis,ERI_MO_basis,cHF,eHF,eG0W0) + call cpu_time(end_G0W0) + + t_G0W0 = end_G0W0 - start_G0W0 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0W0 = ',t_G0W0,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Perform evGW calculation +!------------------------------------------------------------------------ + + if(doevGW) then + + call cpu_time(start_evGW) + call evGW(maxSCF_GW,thresh_GW,n_diis_GW, & + COHSEX,SOSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold,linearize, & + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,Hc,ERI_AO_basis,ERI_MO_basis,PHF,cHF,eHF,eHF) + call cpu_time(end_evGW) + + t_evGW = end_evGW - start_evGW + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for evGW = ',t_evGW,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Perform qsGW calculation +!------------------------------------------------------------------------ + + if(doqsGW) then + + call cpu_time(start_qsGW) + call qsGW(maxSCF_GW,thresh_GW,n_diis_GW, & + COHSEX,SOSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ENuc,S,X,T,V,Hc,ERI_AO_basis,PHF,cHF,eHF) + call cpu_time(end_qsGW) + + t_qsGW = end_qsGW - start_qsGW + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGW = ',t_qsGW,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute e-N cusp dressing +!------------------------------------------------------------------------ + if(doeNcusp) then + + call cpu_time(start_eNcusp) +! call eNcusp() + call cpu_time(end_eNcusp) + + t_eNcusp = end_eNcusp - start_eNcusp + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for e-N cusp dressing = ',t_eNcusp,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Information for Monte Carlo calculations +!------------------------------------------------------------------------ + + if(doMCMP2 .or. doMinMCMP2) then + +! Print simulation details + + write(*,'(A32)') '----------------------' + write(*,'(A32,1X,I16)') 'Number of Monte Carlo steps',nMC + write(*,'(A32,1X,I16)') 'Number of equilibration steps',nEq + write(*,'(A32,1X,I16)') 'Number of walkers',nWalk + write(*,'(A32,1X,F16.10)') 'Initial time step',dt + write(*,'(A32,1X,I16)') 'Frequency of ouput',nPrint + write(*,'(A32,1X,I16)') 'Seed for random number generator',iSeed + write(*,'(A32)') '----------------------' + write(*,*) + +! Initialize random number generator + + call initialize_random_generator(iSeed) + +!------------------------------------------------------------------------ +! Type of weight function +!------------------------------------------------------------------------ +! TrialType = 0 => HF density +! TrialType = 1 => Custom one-electron function +!------------------------------------------------------------------------ + + TrialType = 0 + allocate(cTrial(nBas),gradient(nBas),hessian(nBas,nBas)) + + endif +!------------------------------------------------------------------------ +! Compute MC-MP2 energy +!------------------------------------------------------------------------ + + if(doMCMP2) then + + call cpu_time(start_MCMP2) + call MCMP2(doDrift,nBas,nC,nO,nV,cHF,eHF,EcMP2, & + nMC,nEq,nWalk,dt,nPrint, & + nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + Norm,EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) +! call MCMP2(.false.,doDrift,nBas,nEl,nC,nO,nV,cHF,eHF,EcMP2, & +! nMC,nEq,nWalk,dt,nPrint, & +! nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & +! TrialType,Norm,cTrial,gradient,hessian, & +! EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) + call cpu_time(end_MCMP2) + + t_MCMP2 = end_MCMP2 - start_MCMP2 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MC-MP2 = ',t_MCMP2,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Minimize MC-MP2 variance +!------------------------------------------------------------------------ + + if(doMinMCMP2) then + + call cpu_time(start_MinMCMP2) +! call MinMCMP2(nBas,nEl,nC,nO,nV,cHF,eHF,EcMP2, & +! nMC,nEq,nWalk,dt,nPrint, & +! nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & +! TrialType,Norm,cTrial,gradient,hessian) + call cpu_time(end_MinMCMP2) + + t_MinMCMP2 = end_MinMCMP2 - start_MinMCMP2 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MC-MP2 variance minimization = ',t_MinMCMP2,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! End of MCQC +!------------------------------------------------------------------------ +end program MCQC diff --git a/src/MCQC/MOM.f90 b/src/MCQC/MOM.f90 new file mode 100644 index 0000000..fda126c --- /dev/null +++ b/src/MCQC/MOM.f90 @@ -0,0 +1,190 @@ +subroutine MOM(maxSCF,thresh,max_diis,nBas,nO,S,T,V,Hc,ERI,X,ENuc,ERHF,c,e,P) + +! Maximum overlap method + + implicit none + +! Input variables + + integer,intent(in) :: maxSCF,max_diis + double precision,intent(in) :: thresh + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: ENuc + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),X(nBas,nBas) + +! Local variables + + integer :: iBas,jBas + integer :: nSCF,nBasSq,n_diis + double precision :: ET,EV,EJ,EK,Conv,Gap + double precision,external :: trace_matrix + double precision,allocatable :: error(:,:),error_diis(:,:),F_diis(:,:) + double precision,allocatable :: J(:,:),K(:,:),cp(:,:),F(:,:),Fp(:,:) + double precision,allocatable :: cG(:,:),ON(:) + +! Output variables + + double precision,intent(inout):: ERHF,c(nBas,nBas),e(nBas),P(nBas,nBas) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Maximum overlap method |' + write(*,*)'************************************************' + write(*,*) + +! Useful quantities + + nBasSq = nBas*nBas + +! Memory allocation + + allocate(J(nBas,nBas),K(nBas,nBas),error(nBas,nBas), & + cp(nBas,nBas),Fp(nBas,nBas),F(nBas,nBas), & + cG(nBas,nBas),ON(nBas), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Set up guess orbitals + + cG(:,:) = c(:,:) + +! Set up occupation numbers + + ON(1:nO) = 1d0 + ON(nO+1:nBas) = 0d0 + +! HOMO-LUMO transition + + ON(nO) = 0d0 + ON(nO+1) = 1d0 + + write(*,*) + write(*,*) ' --- Initial MO occupations --- ' + write(*,*) + call matout(nBas,1,ON) + write(*,*) + +! Compute density matrix + + call density_matrix(nBas,ON,c,P) + +! Initialization + + n_diis = 0 + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + Conv = 1d0 + nSCF = 0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| MOM calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','HF energy','|','Conv','|','HL Gap','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Build Fock matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI,J) + call exchange_matrix_AO_basis(nBas,P,ERI,K) + + F(:,:) = Hc(:,:) + J(:,:) + K(:,:) + +! Check convergence + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + +! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + +! Diagonalize Fock matrix + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + +! MOM overlap + + call MOM_overlap(nBas,nO,S,cG,c,ON) + +! Density matrix + + call density_matrix(nBas,ON,c,P) + +! Compute HF energy + + ERHF = trace_matrix(nBas,matmul(P,Hc)) & + + 0.5d0*trace_matrix(nBas,matmul(P,J)) & + + 0.5d0*trace_matrix(nBas,matmul(P,K)) + +! Compute HOMO-LUMO gap + + if(nBas > nO) then + + Gap = e(nO+1) - e(nO) + + else + + Gap = 0d0 + + endif + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ERHF+ENuc,'|',Conv,'|',Gap,'|' + + enddo + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + + write(*,*) + write(*,*) ' --- Final MO occupations --- ' + write(*,*) + call matout(nBas,1,ON) + write(*,*) + +! Compute HF energy + + ET = trace_matrix(nBas,matmul(P,T)) + EV = trace_matrix(nBas,matmul(P,V)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EK = 0.5d0*trace_matrix(nBas,matmul(P,K)) + ERHF = ET + EV + EJ + EK + + call print_RHF(nBas,nO,e,c,ENuc,ET,EV,EJ,EK,ERHF) + +end subroutine MOM diff --git a/src/MCQC/MOM_overlap.f90 b/src/MCQC/MOM_overlap.f90 new file mode 100644 index 0000000..f4f4c61 --- /dev/null +++ b/src/MCQC/MOM_overlap.f90 @@ -0,0 +1,51 @@ +subroutine MOM_overlap(nBas,nO,S,cG,c,ON) + +! Compute overlap between old and new MO coefficients + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: S(nBas,nBas),cG(nBas,nBas),c(nBas,nBas) + +! Local variables + + integer :: i,j,ploc + double precision,allocatable :: Ov(:,:),pOv(:) + +! Output variables + + double precision,intent(inout):: ON(nBas) + + allocate(Ov(nBas,nBas),pOv(nBas)) + + Ov = matmul(transpose(cG),matmul(S,c)) + + pOv(:) = 0d0 + + do i=1,nBas + do j=1,nBas + pOv(j) = pOv(j) + ON(i)*Ov(i,j)**2 + enddo + enddo + + pOv(:) = sqrt(pOV(:)) + +! print*,'--- MOM overlap ---' +! call matout(nBas,1,pOv) + + ON(:) = 0d0 + + do i=1,nO + ploc = maxloc(pOv,nBas) + ON(ploc) = 1d0 + pOv(ploc) = 0d0 + enddo + +! print*,'--- Occupation numbers ---' +! call matout(nBas,1,ON) + + + +end subroutine MOM_overlap diff --git a/src/MCQC/MOtoAO_transform.f90 b/src/MCQC/MOtoAO_transform.f90 new file mode 100644 index 0000000..b4a8b4f --- /dev/null +++ b/src/MCQC/MOtoAO_transform.f90 @@ -0,0 +1,27 @@ +subroutine MOtoAO_transform(nBas,S,c,A) + +! Perform MO to AO transformation of a matrix A for a given metric S +! and coefficients c + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: S(nBas,nBas),c(nBas,nBas) + +! Local variables + + double precision,allocatable :: Sc(:,:) + +! Output variables + + double precision,intent(inout):: A(nBas,nBas) + +! Memory allocation + allocate(Sc(nBas,nBas)) + + Sc = matmul(S,c) + A = matmul(Sc,matmul(A,transpose(Sc))) + +end subroutine MOtoAO_transform diff --git a/src/MCQC/MP2.f90 b/src/MCQC/MP2.f90 new file mode 100644 index 0000000..8aecf47 --- /dev/null +++ b/src/MCQC/MP2.f90 @@ -0,0 +1,71 @@ +subroutine MP2(nBas,nC,nO,nV,nR,ERI,ENuc,EHF,e,EcMP2) + +! Perform third-order Moller-Plesset calculation + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: ENuc,EHF + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),e(nBas) + +! Local variables + + integer :: i,j,a,b + double precision :: eps,E2a,E2b + +! Output variables + + double precision,intent(out) :: EcMP2(3) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Moller-Plesset second-order calculation |' + write(*,*)'************************************************' + write(*,*) + +! Compute MP2 energy + + E2a = 0d0 + E2b = 0d0 + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = e(i) + e(j) - e(a) - e(b) + +! Secon-order ring diagram + + E2a = E2a + ERI(i,j,a,b)*ERI(i,j,a,b)/eps + +! Second-order exchange + + E2b = E2b + ERI(i,j,a,b)*ERI(i,j,b,a)/eps + + enddo + enddo + enddo + enddo + + EcMP2(2) = 2d0*E2a + EcMP2(3) = -E2b + EcMP2(1) = EcMP2(2) + EcMP2(3) + + write(*,*) + write(*,'(A32)') '-----------------------' + write(*,'(A32)') ' MP2 calculation ' + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 correlation energy',EcMP2(1) + write(*,'(A32,1X,F16.10)') ' Direct part ',EcMP2(2) + write(*,'(A32,1X,F16.10)') ' Exchange part ',EcMP2(3) + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 electronic energy',EHF + EcMP2(1) + write(*,'(A32,1X,F16.10)') ' MP2 total energy',ENuc + EHF + EcMP2(1) + write(*,'(A32)') '-----------------------' + write(*,*) + +end subroutine MP2 diff --git a/src/MCQC/MP2F12.f90 b/src/MCQC/MP2F12.f90 new file mode 100644 index 0000000..27cf274 --- /dev/null +++ b/src/MCQC/MP2F12.f90 @@ -0,0 +1,131 @@ +subroutine MP2F12(nBas,nC,nO,nV,nA,ERI,F12,Yuk,EHF,EcMP2,c,cA,EcMP2F12) + +! Perform restricted Hartree-Fock calculation + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nA + double precision,intent(in) :: EHF,EcMP2 + double precision,intent(in) :: c(nBas,nBas),cA(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),F12(nBas,nBas,nBas,nBas),Yuk(nBas,nBas,nBas,nBas) + +! Local variables + + double precision,allocatable :: ooCoo(:,:,:,:),ooFoo(:,:,:,:),ooYoo(:,:,:,:) + double precision,allocatable :: ooCoa(:,:,:,:),ooFoa(:,:,:,:) + double precision,allocatable :: ooCvv(:,:,:,:),ooFvv(:,:,:,:) + double precision,allocatable :: cO(:,:),cV(:,:) + double precision :: E2a,E2b,E3a,E3b,E4a,E4b,E4c,E4d + integer :: i,j,k,l,a,b,x + +! Output variables + + double precision,intent(out) :: EcMP2F12(3) + +! Split MOs into occupied and virtual sets + + allocate(cO(nBas,nO),cV(nBas,nV)) + cO(1:nBas,1:nO) = c(1:nBas,nC+1:nC+nO) + cV(1:nBas,1:nV) = c(1:nBas,nC+nO+1:nBas) + +! Compute the two-electron part of the MP2-F12 energy + + allocate(ooYoo(nO,nO,nO,nO)) + call AOtoMO_oooo(nBas,nO,cO,Yuk,ooYoo) + + E2a = 0d0 + E2b = 0d0 + do i=1,nO + do j=1,nO + E2a = E2a + ooYoo(i,j,i,j) + E2b = E2b + ooYoo(i,j,j,i) + enddo + enddo + + deallocate(ooYoo) + +! Compute the three-electron part of the MP2-F12 energy + + allocate(ooCoa(nO,nO,nO,nA),ooFoa(nO,nO,nO,nA)) + call AOtoMO_oooa(nBas,nO,nA,cO,cA,ERI,ooCoa) + call AOtoMO_oooa(nBas,nO,nA,cO,cA,F12,ooFoa) + + E3a = 0d0 + E3b = 0d0 + do i=1,nO + do j=1,nO + do k=1,nO + do x=1,nA + E3a = E3a + ooCoa(i,j,k,x)*ooFoa(j,i,k,x) + E3b = E3b + ooCoa(i,j,k,x)*ooFoa(i,j,k,x) + enddo + enddo + enddo + enddo + + deallocate(ooCoa,ooFoa) + +! Compute the four-electron part of the MP2-F12 energy + + allocate(ooCoo(nO,nO,nO,nO),ooFoo(nO,nO,nO,nO)) + call AOtoMO_oooo(nBas,nO,cO,ERI,ooCoo) + call AOtoMO_oooo(nBas,nO,cO,F12,ooFoo) + + E4a = 0d0 + E4b = 0d0 + do i=1,nO + do j=1,nO + do k=1,nO + do l=1,nO + E4a = E4a + ooCoo(i,j,k,l)*ooFoo(i,j,k,l) + E4b = E4b + ooCoo(i,j,k,l)*ooFoo(j,i,k,l) + enddo + enddo + enddo + enddo + + deallocate(ooCoo,ooFoo) + + allocate(ooCvv(nO,nO,nV,nV),ooFvv(nO,nO,nV,nV)) + call AOtoMO_oovv(nBas,nO,nV,cO,cV,ERI,ooCvv) + call AOtoMO_oovv(nBas,nO,nV,cO,cV,F12,ooFvv) + + E4c = 0d0 + E4d = 0d0 + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + E4c = E4c + ooCvv(i,j,a,b)*ooFvv(i,j,a,b) + E4d = E4d + ooCvv(i,j,a,b)*ooFvv(j,i,a,b) + enddo + enddo + enddo + enddo + + deallocate(ooCvv,ooFvv) + +! Final scaling of the various components + + EcMP2F12(1) = +0.625d0*E2a - 0.125d0*E2b + EcMP2F12(2) = -1.250d0*E3a + 0.250d0*E3b + EcMP2F12(3) = +0.625d0*E4a - 0.125d0*E4b - 0.625d0*E4c + 0.125d0*E4d + + write(*,*) + write(*,'(A32)') '-----------------------' + write(*,'(A32)') ' MP2-F12 calculation ' + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 ',EcMP2 + write(*,'(A32,1X,F16.10)') ' MP2-F12 E(2) ',EcMP2F12(1) + write(*,'(A32,1X,F16.10)') ' MP2-F12 E(3) ',EcMP2F12(2) + write(*,'(A32,1X,F16.10)') ' MP2-F12 E(4) ',EcMP2F12(3) + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' Total ',EcMP2+EcMP2F12(1)+EcMP2F12(2)+EcMP2F12(3) + write(*,'(A32)') '-----------------------' + write(*,*) + + deallocate(cO,cV) + +end subroutine MP2F12 diff --git a/src/MCQC/MP3.f90 b/src/MCQC/MP3.f90 new file mode 100644 index 0000000..c84d7bc --- /dev/null +++ b/src/MCQC/MP3.f90 @@ -0,0 +1,113 @@ +subroutine MP3(nBas,nC,nO,nV,nR,V,EHF,EcMP2,e,EcMP3) + +! Perform third-order Moller-Plesset calculation + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: EHF,EcMP2 + double precision,intent(in) :: V(nBas,nBas,nBas,nBas),e(nBas) + +! Local variables + + double precision :: eps1,eps2,E3a,E3b,E3c + + integer :: i,j,k,l,a,b,c,d + +! Output variables + + double precision,intent(out) :: EcMP3 + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Moller-Plesset third-order calculation |' + write(*,*)'************************************************' + write(*,*) + +! Compute MP3 energy + + E3a = 0d0 + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do l=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = e(i) + e(j) - e(a) - e(b) + eps2 = e(k) + e(l) - e(a) - e(b) + + E3a = E3a + (V(i,j,a,b) - V(i,j,b,a))* & + (V(k,l,i,j) - V(k,l,j,i))* & + (V(a,b,k,l) - V(a,b,l,k))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + E3b = 0d0 + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + do d=nO+1,nBas-nR + + eps1 = e(i) + e(j) - e(a) - e(b) + eps2 = e(i) + e(j) - e(c) - e(d) + + E3b = E3b + (V(i,j,a,b) - V(i,j,b,a))* & + (V(a,b,c,d) - V(a,b,d,c))* & + (V(c,d,i,j) - V(c,d,j,i))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + E3c = 0d0 + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = e(i) + e(j) - e(a) - e(b) + eps2 = e(i) + e(k) - e(a) - e(c) + + E3c = E3c + (V(i,j,a,b) - V(i,j,b,a))* & + (V(k,b,c,j) - V(k,b,j,c))* & + (V(a,c,i,k) - V(a,c,k,i))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + EcMP3 = 0.25d0*E3a + 0.25d0*E3b + E3c + + write(*,*) + write(*,'(A32)') '-----------------------' + write(*,'(A32)') ' MP3 calculation ' + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 contribution ',EcMP2 + write(*,'(A32,1X,F16.10)') ' MP3 contribution ',EcMP3 + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP3 correlation energy', EcMP2 + EcMP3 + write(*,'(A32,1X,F16.10)') ' MP3 total energy',EHF + EcMP2 + EcMP3 + write(*,'(A32)') '-----------------------' + write(*,*) + +end subroutine MP3 diff --git a/src/MCQC/Makefile b/src/MCQC/Makefile new file mode 100644 index 0000000..abf685f --- /dev/null +++ b/src/MCQC/Makefile @@ -0,0 +1,31 @@ +IDIR =../../include +BDIR =../../bin +LDIR =../../lib +ODIR = obj +SDIR =. +FC = gfortran -g -I$(IDIR) +ifeq ($(DEBUG),1) +FFLAGS = -Wall -msse4.2 -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation -Wreal-q-constant +else +FFLAGS = -Wall -Wno-unused -Wno-unused-dummy-argument -O2 +endif + +LIBS = $(LDIR)/*.a $(LDIR)/slatec/src/static/libslatec.a + +SRC = $(wildcard *.f90) + +OBJ = $(patsubst %.f90,$(ODIR)/%.o,$(SRC)) + + +$(ODIR)/%.o: %.f90 + $(FC) -c -o $@ $< $(FFLAGS) 2>&1 + +$(BDIR)/MCQC: $(OBJ) + $(FC) -o $@ $^ $(FFLAGS) $(LIBS) +# $(FC) -o $(BDIR)/$@ $^ $(FFLAGS) $(LIBS) + +debug: + DEBUG=1 make clean $(BDIR)/MCQC + +clean: + rm -f $(ODIR)/*.o $(BDIR)/MCQC $(BDIR)/debug diff --git a/src/MCQC/MinMCMP2.f90 b/src/MCQC/MinMCMP2.f90 new file mode 100644 index 0000000..13c7c59 --- /dev/null +++ b/src/MCQC/MinMCMP2.f90 @@ -0,0 +1,121 @@ +subroutine MinMCMP2(nBas,nEl,nC,nO,nV,c,e,EcMP2, & + nMC,nEq,nWalk,dt,nPrint, & + nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + TrialType,Norm,cTrial,gradient,hessian) + +! Minimize the variance of MC-MP2 + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nEl,nC,nO,nV,nMC,nEq,nWalk,nPrint + double precision,intent(in) :: EcMP2(3),dt + double precision,intent(in) :: c(nBas,nBas),e(nBas) + + integer,intent(in) :: nShell + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: CenterShell(maxShell,3),DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + logical :: debug,varmin,mincvg + double precision :: thresh + double precision,allocatable :: max_gradient(:),energy_MCMP2(:),variance_MCMP2(:),error_MCMP2(:),NormTr(:) + + double precision :: EcMCMP2(3),Err_EcMCMP2(3),Var_EcMCMP2(3) + + integer :: it,nIt,i + +! Output variables + + integer,intent(in) :: TrialType + double precision,intent(inout):: Norm,cTrial(nBas),gradient(nBas),hessian(nBas,nBas) + +! Debuging mode + +! debug = .true. + debug = .false. + +! Minimization parameters + + varmin = .true. + mincvg = .false. + nIt = 10 + thresh = 1d-5 + allocate(max_gradient(nIt),energy_MCMP2(nIt),variance_MCMP2(nIt),error_MCMP2(nIt),normTr(nIt)) + + if(TrialType == 1) then + +! Use HOMO as guess + cTrial(1:nBas) = c(1:nBas,nEl/2) +! Normalization factor will be computed later + + endif + +!------------------------------------------------------------------------ +! Start MC-MP2 variance minimization +!------------------------------------------------------------------------ + it = 0 + do while (it < nIt .and. .not.(mincvg)) + + it = it + 1 + + write(*,*) '**********************************************************************' + write(*,*) ' Variance minimization of MC-MP2 energy ' + write(*,*) '**********************************************************************' + write(*,*) ' Iteration n.',it + write(*,*) '**********************************************************************' + + write(*,*) + write(*,*) ' Trial wave function coefficients at iteration n.',it + call matout(nBas,1,cTrial) + write(*,*) + + call MCMP2(varmin,nBas,nEl,nC,nO,nV,c,e,EcMP2, & + nMC,nEq,nWalk,dt,nPrint, & + nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + TrialType,Norm,cTrial,gradient,hessian, & + EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) + +! Newton update of the coefficients + + call Newton(nBas,gradient,hessian,cTrial) + +! Check for convergence + + max_gradient(it) = maxval(abs(gradient)) + energy_MCMP2(it) = EcMCMP2(1) + variance_MCMP2(it) = Var_EcMCMP2(1) + error_MCMP2(it) = Err_EcMCMP2(1) + NormTr(it) = Norm + + write(*,*) + write(*,*) 'Maximum gradient at iteration n.',it,':',max_gradient(it) + write(*,*) + + if(max_gradient(it) < thresh) then + write(*,*) ' Miracle! Variance minimization of MC-MP2 has converged!' + mincvg = .true. + endif + + enddo + + write(*,*) + write(*,*) '********************************' + write(*,*) 'Summary of variance minimization' + write(*,*) '********************************' + write(*,*) + + write(*,'(A3,A20,A20,A20,A20,A20,A20)') & + 'It.','Gradient','Ec(MC-MPC2)','Variance','Error','Ec(MC-MP2)-Ec(MP2)','Norm' + write(*,'(I3,4X,F16.10,4X,F16.10,4X,F16.10,4X,F16.10,4X,F16.10,4X,F16.10)') & + (i,max_gradient(i),energy_MCMP2(i),variance_MCMP2(i),error_MCMP2(i),energy_MCMP2(i)-EcMP2(1),NormTr(i),i=1,it) + write(*,*) + +!------------------------------------------------------------------------ +! End MC-MP2 variance minimization +!------------------------------------------------------------------------ + +end subroutine MinMCMP2 diff --git a/src/MCQC/NDrift.f90 b/src/MCQC/NDrift.f90 new file mode 100644 index 0000000..13cc5f3 --- /dev/null +++ b/src/MCQC/NDrift.f90 @@ -0,0 +1,67 @@ +subroutine NDrift(nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,P,r,w,F) + +! Compute quantum force numerically + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nWalk,nBas + double precision,intent(in) :: P(nBas,nBas),r(nWalk,2,3),w(nWalk) + + integer,intent(in) :: nShell + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: CenterShell(maxShell,3),DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + integer :: iW,iEl,ixyz + double precision :: delta + double precision :: wp,wm + double precision,allocatable :: rp(:,:,:),rm(:,:,:),r12p(:),r12m(:) + double precision,allocatable :: gAOp(:,:,:),dgAOp(:,:,:,:),gAOm(:,:,:),dgAOm(:,:,:,:) + double precision,allocatable :: gp(:,:),dgp(:,:,:),gm(:,:),dgm(:,:,:) + + +! Output variables + + double precision,intent(out) :: F(nWalk,2,3) + + allocate(rp(nWalk,2,3),rm(nWalk,2,3),r12p(nWalk),r12m(nWalk), & + gAOp(nWalk,2,nBas),dgAOp(nWalk,2,3,nBas),gAOm(nWalk,2,nBas),dgAOm(nWalk,2,3,nBas), & + gp(nWalk,2),dgp(nWalk,2,3),gm(nWalk,2),dgm(nWalk,2,3)) + + do iW=1,nWalk + do iEl=1,2 + do ixyz=1,3 + + delta = 1d-6 + + rp = r + rm = r + + rp(iW,iEl,ixyz) = r(iW,iEl,ixyz) + delta + rm(iW,iEl,ixyz) = r(iW,iEl,ixyz) - delta + + call AO_values(.false.,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,rp,gAOp,dgAOp) + call AO_values(.false.,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,rm,gAOm,dgAOm) + + call Density(.false.,nBas,nWalk,P,gAOp,dgAOp,gp,dgp) + call Density(.false.,nBas,nWalk,P,gAOm,dgAOm,gm,dgm) + + call rij(nWalk,rp,r12p) + call rij(nWalk,rm,r12m) + + wp = gp(iW,1)*gp(iW,2)/r12p(iW) + wm = gm(iW,1)*gm(iW,2)/r12m(iW) + + F(iW,iEl,ixyz) = (wp - wm)/(2d0*delta*w(iw)) + enddo + enddo + enddo + +! print*,'NF',F + + +end subroutine NDrift diff --git a/src/MCQC/Newton.f90 b/src/MCQC/Newton.f90 new file mode 100644 index 0000000..f074035 --- /dev/null +++ b/src/MCQC/Newton.f90 @@ -0,0 +1,67 @@ +subroutine Newton(nWSq,gradient,hessian,cWeight) + +! Calculate the Green functions + + implicit none + +! Input variables + + integer,intent(in) :: nWSq + double precision,intent(in) :: gradient(nWSq),hessian(nWSq,nWSq) + +! Local variables + + integer :: info + integer,allocatable :: ipiv(:) + double precision,allocatable :: scr(:),eigval(:),eigvec(:,:) + +! Output variables + + double precision,intent(inout):: cWeight(nWSq) + +! Memory allocation + + allocate(ipiv(nWSq),scr(3*nWsq),eigval(nWSq),eigvec(nWSq,nWSq)) + +! Compute eigenvectors and eigenvalues + + eigvec = hessian + call dsyev('V','U',nWSq,eigvec,nWSq,eigval,scr,3*nWSq,info) + + if(info /= 0)then + write(*,*) ' Problem with dsyev!' + stop + endif + + write(*,*) + write(*,*) 'Eigenvalues of hessian' + call matout(nWSq,1,eigval) + write(*,*) +! write(*,*) 'Eigenvectors of hessian' +! call matout(nWSq,1,eigval) +! write(*,*) + +! Compute inverse of the hessian + + call dgetrf(nWSq,nWSq,hessian,nWSq,ipiv,info) + + if(info /= 0) then + write(*,*) ' Problem in dgetrf!' + stop + endif + + call dgetri(nWSq,hessian,nWSq,ipiv,scr,nWSq,info) + + if(info /= 0) then + write(*,*) ' Problem in dgetri!' + stop + endif + + print*,'inverse hessian' + call matout(nWSq,nWSq,hessian) + +! Compute new coefficients + + cWeight = cWeight - matmul(hessian,gradient) + +end subroutine Newton diff --git a/src/MCQC/NormCoeff.f90 b/src/MCQC/NormCoeff.f90 new file mode 100644 index 0000000..9e6cabf --- /dev/null +++ b/src/MCQC/NormCoeff.f90 @@ -0,0 +1,29 @@ +function NormCoeff(alpha,a) + + implicit none + +! Input variables + + double precision,intent(in) :: alpha + integer,intent(in) :: a(3) + +! local variable + double precision :: pi,dfa(3),dfac + integer :: atot + +! Output variable + double precision NormCoeff + + pi = 4d0*atan(1d0) + atot = a(1) + a(2) + a(3) + + dfa(1) = dfac(2*a(1))/(2d0**a(1)*dfac(a(1))) + dfa(2) = dfac(2*a(2))/(2d0**a(2)*dfac(a(2))) + dfa(3) = dfac(2*a(3))/(2d0**a(3)*dfac(a(3))) + + + NormCoeff = (2d0*alpha/pi)**(3d0/2d0)*(4d0*alpha)**atot + NormCoeff = NormCoeff/(dfa(1)*dfa(2)*dfa(3)) + NormCoeff = sqrt(NormCoeff) + +end function NormCoeff diff --git a/src/MCQC/RHF.f90 b/src/MCQC/RHF.f90 new file mode 100644 index 0000000..25621d0 --- /dev/null +++ b/src/MCQC/RHF.f90 @@ -0,0 +1,171 @@ +subroutine RHF(maxSCF,thresh,max_diis,guess_type,nBas,nO,S,T,V,Hc,ERI,X,ENuc,ERHF,c,e,P) + +! Perform restricted Hartree-Fock calculation + + implicit none + +! Input variables + + integer,intent(in) :: maxSCF,max_diis,guess_type + double precision,intent(in) :: thresh + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: ENuc + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),X(nBas,nBas) + +! Local variables + + integer :: nSCF,nBasSq,n_diis + double precision :: ET,EV,EJ,EK,Conv,Gap + double precision,external :: trace_matrix + double precision,allocatable :: error(:,:),error_diis(:,:),F_diis(:,:) + double precision,allocatable :: J(:,:),K(:,:),cp(:,:),F(:,:),Fp(:,:) + +! Output variables + + double precision,intent(out) :: ERHF,c(nBas,nBas),e(nBas),P(nBas,nBas) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Restricted Hartree-Fock calculation |' + write(*,*)'************************************************' + write(*,*) + +! Useful quantities + + nBasSq = nBas*nBas + +! Memory allocation + + allocate(J(nBas,nBas),K(nBas,nBas),error(nBas,nBas), & + cp(nBas,nBas),Fp(nBas,nBas),F(nBas,nBas), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Guess coefficients and eigenvalues + + if(guess_type == 1) then + + Fp = matmul(transpose(X),matmul(Hc,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + + elseif(guess_type == 2) then + + call random_number(c) + + endif + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + + +! Initialization + + n_diis = 0 + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + Conv = 1d0 + nSCF = 0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| RHF calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','HF energy','|','Conv','|','HL Gap','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Build Fock matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI,J) + call exchange_matrix_AO_basis(nBas,P,ERI,K) + + F(:,:) = Hc(:,:) + J(:,:) + K(:,:) + +! Check convergence + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + +! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + +! Diagonalize Fock matrix + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + +! Density matrix + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + +! Compute HF energy + + ERHF = trace_matrix(nBas,matmul(P,Hc)) & + + 0.5d0*trace_matrix(nBas,matmul(P,J)) & + + 0.5d0*trace_matrix(nBas,matmul(P,K)) + +! Compute HOMO-LUMO gap + + if(nBas > nO) then + + Gap = e(nO+1) - e(nO) + + else + + Gap = 0d0 + + endif + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ERHF+ENuc,'|',Conv,'|',Gap,'|' + + enddo + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Compute HF energy + + ET = trace_matrix(nBas,matmul(P,T)) + EV = trace_matrix(nBas,matmul(P,V)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EK = 0.5d0*trace_matrix(nBas,matmul(P,K)) + ERHF = ET + EV + EJ + EK + + call print_RHF(nBas,nO,e,C,ENuc,ET,EV,EJ,EK,ERHF) + +end subroutine RHF diff --git a/src/MCQC/RHF.f90.x b/src/MCQC/RHF.f90.x new file mode 100644 index 0000000..25621d0 --- /dev/null +++ b/src/MCQC/RHF.f90.x @@ -0,0 +1,171 @@ +subroutine RHF(maxSCF,thresh,max_diis,guess_type,nBas,nO,S,T,V,Hc,ERI,X,ENuc,ERHF,c,e,P) + +! Perform restricted Hartree-Fock calculation + + implicit none + +! Input variables + + integer,intent(in) :: maxSCF,max_diis,guess_type + double precision,intent(in) :: thresh + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: ENuc + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),X(nBas,nBas) + +! Local variables + + integer :: nSCF,nBasSq,n_diis + double precision :: ET,EV,EJ,EK,Conv,Gap + double precision,external :: trace_matrix + double precision,allocatable :: error(:,:),error_diis(:,:),F_diis(:,:) + double precision,allocatable :: J(:,:),K(:,:),cp(:,:),F(:,:),Fp(:,:) + +! Output variables + + double precision,intent(out) :: ERHF,c(nBas,nBas),e(nBas),P(nBas,nBas) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Restricted Hartree-Fock calculation |' + write(*,*)'************************************************' + write(*,*) + +! Useful quantities + + nBasSq = nBas*nBas + +! Memory allocation + + allocate(J(nBas,nBas),K(nBas,nBas),error(nBas,nBas), & + cp(nBas,nBas),Fp(nBas,nBas),F(nBas,nBas), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Guess coefficients and eigenvalues + + if(guess_type == 1) then + + Fp = matmul(transpose(X),matmul(Hc,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + + elseif(guess_type == 2) then + + call random_number(c) + + endif + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + + +! Initialization + + n_diis = 0 + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + Conv = 1d0 + nSCF = 0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| RHF calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','HF energy','|','Conv','|','HL Gap','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Build Fock matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI,J) + call exchange_matrix_AO_basis(nBas,P,ERI,K) + + F(:,:) = Hc(:,:) + J(:,:) + K(:,:) + +! Check convergence + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + +! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + +! Diagonalize Fock matrix + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + +! Density matrix + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + +! Compute HF energy + + ERHF = trace_matrix(nBas,matmul(P,Hc)) & + + 0.5d0*trace_matrix(nBas,matmul(P,J)) & + + 0.5d0*trace_matrix(nBas,matmul(P,K)) + +! Compute HOMO-LUMO gap + + if(nBas > nO) then + + Gap = e(nO+1) - e(nO) + + else + + Gap = 0d0 + + endif + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ERHF+ENuc,'|',Conv,'|',Gap,'|' + + enddo + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Compute HF energy + + ET = trace_matrix(nBas,matmul(P,T)) + EV = trace_matrix(nBas,matmul(P,V)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EK = 0.5d0*trace_matrix(nBas,matmul(P,K)) + ERHF = ET + EV + EJ + EK + + call print_RHF(nBas,nO,e,C,ENuc,ET,EV,EJ,EK,ERHF) + +end subroutine RHF diff --git a/src/MCQC/SPHF.f90 b/src/MCQC/SPHF.f90 new file mode 100644 index 0000000..e6cd623 --- /dev/null +++ b/src/MCQC/SPHF.f90 @@ -0,0 +1,170 @@ +subroutine SPHF(maxSCF,thresh,max_diis,guess_type,nBas,nO,S,T,V,Hc,ERI,X,ENuc,ERHF,c,e,P) + +! Perform restricted Hartree-Fock calculation + + implicit none + +! Input variables + + integer,intent(in) :: maxSCF,max_diis,guess_type + double precision,intent(in) :: thresh + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: ENuc + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),X(nBas,nBas) + +! Local variables + + integer :: nSCF,nBasSq,n_diis + double precision :: ET,EV,EJ,EK,Conv,Gap + double precision,external :: trace_matrix + double precision,allocatable :: error(:,:),error_diis(:,:),F_diis(:,:) + double precision,allocatable :: J(:,:),K(:,:),cp(:,:),F(:,:),Fp(:,:) + +! Output variables + + double precision,intent(out) :: ERHF,c(nBas,nBas),e(nBas),P(nBas,nBas) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Restricted Hartree-Fock calculation |' + write(*,*)'************************************************' + write(*,*) + +! Useful quantities + + nBasSq = nBas*nBas + +! Memory allocation + + allocate(J(nBas,nBas),K(nBas,nBas),error(nBas,nBas), & + cp(nBas,nBas),Fp(nBas,nBas),F(nBas,nBas), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Guess coefficients and eigenvalues + + if(guess_type == 1) then + + Fp = matmul(transpose(X),matmul(Hc,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + + elseif(guess_type == 2) then + + call random_number(c) + + endif + + P(:,:) = matmul(c(:,1:nO),transpose(c(:,1:nO))) + +! Initialization + + n_diis = 0 + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + Conv = 1d0 + nSCF = 0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| SPHF calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','HF energy','|','Conv','|','HL Gap','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Build Fock matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI,J) + call exchange_matrix_AO_basis(nBas,P,ERI,K) + + F(:,:) = Hc(:,:) + J(:,:) + 2d0*K(:,:) + +! Check convergence + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + +! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + +! Diagonalize Fock matrix + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + +! Density matrix + + P(:,:) = matmul(c(:,1:nO),transpose(c(:,1:nO))) + +! Compute HF energy + + ERHF = trace_matrix(nBas,matmul(P,Hc)) & + + 0.5d0*trace_matrix(nBas,matmul(P,J)) & + + trace_matrix(nBas,matmul(P,K)) + +! Compute HOMO-LUMO gap + + if(nBas > nO) then + + Gap = e(nO+1) - e(nO) + + else + + Gap = 0d0 + + endif + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ERHF+ENuc,'|',Conv,'|',Gap,'|' + + enddo + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Compute HF energy + + ET = trace_matrix(nBas,matmul(P,T)) + EV = trace_matrix(nBas,matmul(P,V)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EK = trace_matrix(nBas,matmul(P,K)) + ERHF = ET + EV + EJ + EK + + call print_RHF(nBas,nO,e,C,ENuc,ET,EV,EJ,EK,ERHF) + +end subroutine SPHF diff --git a/src/MCQC/SPMP2.f90 b/src/MCQC/SPMP2.f90 new file mode 100644 index 0000000..d91d803 --- /dev/null +++ b/src/MCQC/SPMP2.f90 @@ -0,0 +1,71 @@ +subroutine SPMP2(nBas,nC,nO,nV,nR,ERI,ENuc,EHF,e,EcMP2) + +! Perform third-order Moller-Plesset calculation + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: ENuc,EHF + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),e(nBas) + +! Local variables + + integer :: i,j,a,b + double precision :: eps,E2a,E2b + +! Output variables + + double precision,intent(out) :: EcMP2(3) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Moller-Plesset second-order calculation |' + write(*,*)'************************************************' + write(*,*) + +! Compute MP2 energy + + E2a = 0d0 + E2b = 0d0 + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = e(i) + e(j) - e(a) - e(b) + +! Secon-order ring diagram + + E2a = E2a + ERI(i,j,a,b)*ERI(i,j,a,b)/eps + +! Second-order exchange + + E2b = E2b + ERI(i,j,a,b)*ERI(i,j,b,a)/eps + + enddo + enddo + enddo + enddo + + EcMP2(2) = E2a + EcMP2(3) = -E2b + EcMP2(1) = EcMP2(2) + EcMP2(3) + + write(*,*) + write(*,'(A32)') '-----------------------' + write(*,'(A32)') ' MP2 calculation ' + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 correlation energy',EcMP2(1) + write(*,'(A32,1X,F16.10)') ' Direct part ',EcMP2(2) + write(*,'(A32,1X,F16.10)') ' Exchange part ',EcMP2(3) + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 electronic energy',EHF + EcMP2(1) + write(*,'(A32,1X,F16.10)') ' MP2 total energy',ENuc + EHF + EcMP2(1) + write(*,'(A32)') '-----------------------' + write(*,*) + +end subroutine SPMP2 diff --git a/src/MCQC/SPTDHF.f90 b/src/MCQC/SPTDHF.f90 new file mode 100644 index 0000000..6409607 --- /dev/null +++ b/src/MCQC/SPTDHF.f90 @@ -0,0 +1,77 @@ +subroutine SPTDHF(singlet_manifold,triplet_manifold,nBas,nC,nO,nV,nR,nS,ERI,e) + +! Perform random phase approximation calculation + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),e(nBas) + +! Local variables + + logical :: dRPA,TDA,BSE + integer :: ispin + double precision,allocatable :: Omega(:,:),XpY(:,:,:) + + double precision :: rho + double precision :: EcRPA + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Time-dependent Hartree-Fock calculation |' + write(*,*)'************************************************' + write(*,*) + +! Switch on exchange for TDHF + + dRPA = .false. + +! Switch off Tamm-Dancoff approximation for TDHF + + TDA = .false. + +! Switch off Bethe-Salpeter equation for TDHF + + BSE = .false. + +! Memory allocation + + allocate(Omega(nS,nspin),XpY(nS,nS,nspin)) + +! Singlet manifold + + if(singlet_manifold) then + + ispin = 1 + + call SP_linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI, & + rho,EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('TDHF ',ispin,nS,Omega(:,ispin)) + + endif + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'RPA correlation energy =',EcRPA + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + + +! Triplet manifold + + if(triplet_manifold) then + + ispin = 2 + + call SP_linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI, & + rho,EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('TDHF ',ispin,nS,Omega(:,ispin)) + + endif + +end subroutine SPTDHF diff --git a/src/MCQC/SP_linear_response.f90 b/src/MCQC/SP_linear_response.f90 new file mode 100644 index 0000000..e087397 --- /dev/null +++ b/src/MCQC/SP_linear_response.f90 @@ -0,0 +1,81 @@ +subroutine SP_linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI,rho,EcRPA,Omega,XpY) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA,TDA,BSE + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas),rho(nBas,nBas,nS) + +! Local variables + + double precision :: trace_matrix + double precision,allocatable :: A(:,:),B(:,:),ApB(:,:),AmB(:,:),AmBSq(:,:),Z(:,:) + +! Output variables + + double precision,intent(out) :: EcRPA + double precision,intent(out) :: Omega(nS),XpY(nS,nS) + + +! Memory allocation + + allocate(A(nS,nS),B(nS,nS),ApB(nS,nS),AmB(nS,nS),AmBSq(nS,nS),Z(nS,nS)) + +! Build A and B matrices + + call SP_linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,e,ERI,A) + if(BSE) call Bethe_Salpeter_A_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,A) + +! Tamm-Dancoff approximation + + B = 0d0 + if(.not. TDA) then + + call SP_linear_response_B_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,ERI,B) + if(BSE) call Bethe_Salpeter_B_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,B) + + endif + +! Build A + B and A - B matrices + + AmB = A - B + ApB = A + B + +! print*,'A+B' +! call matout(nS,nS,ApB) + +! print*,'A-B' +! call matout(nS,nS,AmB) + +! Diagonalize TD-HF matrix + + call diagonalize_matrix(nS,AmB,Omega) + + if(minval(Omega) < 0d0) & + call print_warning('You may have instabilities in linear response!!') + + call ADAt(nS,AmB,sqrt(Omega),AmBSq) + Z = matmul(AmBSq,matmul(ApB,AmBSq)) + + call diagonalize_matrix(nS,Z,Omega) + + if(minval(Omega) < 0d0) & + call print_warning('You may have instabilities in linear response!!') + + Omega = sqrt(Omega) + XpY = matmul(transpose(Z),AmBSq) + call DA(nS,1d0/sqrt(Omega),XpY) + +! print*,'RPA excitations' +! call matout(nS,1,Omega) + +! Compute the RPA correlation energy + + EcRPA = 0.5d0*(sum(Omega) - trace_matrix(nS,A)) + +end subroutine SP_linear_response diff --git a/src/MCQC/SP_linear_response_A_matrix.f90 b/src/MCQC/SP_linear_response_A_matrix.f90 new file mode 100644 index 0000000..d95ebf4 --- /dev/null +++ b/src/MCQC/SP_linear_response_A_matrix.f90 @@ -0,0 +1,56 @@ +subroutine SP_linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,e,ERI,A_lr) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas) + +! Local variables + + double precision :: delta_spin,delta_dRPA + double precision :: Kronecker_delta + + integer :: i,j,a,b,ia,jb + +! Output variables + + double precision,intent(out) :: A_lr(nS,nS) + +! Singlet or triplet manifold? + + delta_spin = 0d0 + if(ispin == 1) delta_spin = +1d0 + if(ispin == 2) delta_spin = -1d0 + +! Direct RPA + + delta_dRPA = 0d0 + if(dRPA) delta_dRPA = 1d0 + +! Build A matrix + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + A_lr(ia,jb) = (e(a) - e(i))*Kronecker_delta(i,j)*Kronecker_delta(a,b) & + + 0.5d0*(1d0 + delta_spin)*ERI(i,b,a,j) & + - (1d0 - delta_dRPA)*ERI(i,b,j,a) + + enddo + enddo + enddo + enddo + +end subroutine SP_linear_response_A_matrix diff --git a/src/MCQC/SP_linear_response_B_matrix.f90 b/src/MCQC/SP_linear_response_B_matrix.f90 new file mode 100644 index 0000000..6e60338 --- /dev/null +++ b/src/MCQC/SP_linear_response_B_matrix.f90 @@ -0,0 +1,54 @@ +subroutine SP_linear_response_B_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,ERI,B_lr) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + double precision :: delta_spin,delta_dRPA + + integer :: i,j,a,b,ia,jb + +! Output variables + + double precision,intent(out) :: B_lr(nS,nS) + +! Singlet or triplet manifold? + + delta_spin = 0d0 + if(ispin == 1) delta_spin = +1d0 + if(ispin == 2) delta_spin = -1d0 + +! Direct RPA + + delta_dRPA = 0d0 + if(dRPA) delta_dRPA = 1d0 + +! Build A matrix + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + B_lr(ia,jb) = 0.5d0*(1d0 + delta_spin)*ERI(i,j,a,b) & + - (1d0 - delta_dRPA)*ERI(i,j,b,a) + + enddo + enddo + enddo + enddo + +end subroutine SP_linear_response_B_matrix diff --git a/src/MCQC/TDHF.f90 b/src/MCQC/TDHF.f90 new file mode 100644 index 0000000..1999792 --- /dev/null +++ b/src/MCQC/TDHF.f90 @@ -0,0 +1,77 @@ +subroutine TDHF(singlet_manifold,triplet_manifold,nBas,nC,nO,nV,nR,nS,ERI,e) + +! Perform random phase approximation calculation + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),e(nBas) + +! Local variables + + logical :: dRPA,TDA,BSE + integer :: ispin + double precision,allocatable :: Omega(:,:),XpY(:,:,:) + + double precision :: rho + double precision :: EcRPA + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Time-dependent Hartree-Fock calculation |' + write(*,*)'************************************************' + write(*,*) + +! Switch on exchange for TDHF + + dRPA = .false. + +! Switch off Tamm-Dancoff approximation for TDHF + + TDA = .false. + +! Switch off Bethe-Salpeter equation for TDHF + + BSE = .false. + +! Memory allocation + + allocate(Omega(nS,nspin),XpY(nS,nS,nspin)) + +! Singlet manifold + + if(singlet_manifold) then + + ispin = 1 + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI, & + rho,EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('TDHF ',ispin,nS,Omega(:,ispin)) + + endif + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'RPA correlation energy =',EcRPA + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + + +! Triplet manifold + + if(triplet_manifold) then + + ispin = 2 + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI, & + rho,EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('TDHF ',ispin,nS,Omega(:,ispin)) + + endif + +end subroutine TDHF diff --git a/src/MCQC/UHF.f90.x b/src/MCQC/UHF.f90.x new file mode 100644 index 0000000..72c539f --- /dev/null +++ b/src/MCQC/UHF.f90.x @@ -0,0 +1,199 @@ +subroutine UHF(nEl,nBas,S,T,V,Hc,G,X,ENuc,EHF,c,e,P,F) + +! Perform unrestricted Hartree-Fock calculation + + implicit none + +! Input variables + + integer,intent(in) :: nEl(nspin),nBas + double precision,intent(in) :: ENuc + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas) + double precision,intent(in) :: G(nBas,nBas,nBas,nBas),X(nBas,nBas) + +! Local variables + + logical :: random_guess,core_guess,DIIS + integer,parameter :: maxSCF = 64 + double precision,parameter :: thresh = 1d-6 + integer :: nO,nSCF,nBasSq,n_diis,ispin,jspin + double precision :: ET(spin),EV(nspin),EJ(nspin,nspin),EK(nspin,nspin),Conv(nspin),Gap(spin) + double precision :: trace_matrix + double precision,allocatable :: FPS_SPF(:,:,:),error_diis(:,:,:),F_diis(:,:,:) + double precision,allocatable :: J(:,:,:),K(:,:,:),cp(:,:,:),cO(:,:,:) + +! Output variables + + double precision,intent(out) :: EHF,c(nBas,nBas,nspin),e(nBas,nspin),P(nBas,nBas,nspin),F(nBas,nBas,nspin) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Unrestricted Hartree-Fock calculation |' + write(*,*)'************************************************' + write(*,*) + +! Useful quantities + + nBasSq = nBas*nBas + +! Number of occupied orbitals + +! Initialize DIIS variables + + DIIS = .false. + n_diis = 5 + if(.not.DIIS) n_diis = 1 + +! Type of guess + + random_guess = .false. + core_guess = .true. + +! Memory allocation + + allocate(J(nBas,nBas,nspin),K(nBas,nBas,nspin), & + cp(nBas,nBas,nspin),cO(nBas,nO,nspin),FPS_SPF(nBas,nBas,nspin), & + error_diis(nBasSq,n_diis,nspin),F_diis(nBasSq,n_diis,spin)) + +! Guess coefficients and eigenvalues + + if(random_guess) then + + call random_number(c) + + elseif(core_guess) then + + cp(:,:,ispin) = matmul(transpose(X(:,:)),matmul(Hc(:,:),X(:,:))) + call diagonalize_matrix(nBas,cp(:,:,ispin),e(:,:,ispin)) + c(:,:,ispin) = matmul(X,cp(:,:,ispin) + + endif + +! Occupied orbitals + + cO(1:nBas,1:nO,1:nspin) = c(1:nBas,1:nO,1:nspin) + +! Initialization + + Conv(:) = 1d0 + nSCF = 0 + F_diis(:,:,:) = 0d0 + error_diis(:,:,:) = 0d0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| UHF calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','HF energy','|','Conv','|','HL Gap','|' + write(*,*)'----------------------------------------------------' + + do while(maxval(Conv) > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Density matrix + + P(:,:,ispin) = 2d0*matmul(cO(:,:,ispin),transpose(cO(:,:,ispin))) + +! Build Fock matrix + + call Coulomb_matrix_AO_basis(nBas,P(:,:,ispin),G,J(:,:,ispin)) + call exchange_matrix_AO_basis(nBas,P(:,:,ispin),G,K(:,:,ispin)) + + F(:,:,ispin) = Hc(:,:) + J(:,:,ispin) + J(:,:,mod(ispin,2)+1) + K(:,:,ispin) + +! Check convergence + + FPS_SPF(:,:,ispin) = matmul(F(:,:,ispin),matmul(P(:,:,ispin),S)) & + - matmul(matmul(S,P(:,:,ispin)),F(:,:,ispin)) + Conv(ispin) = maxval(abs(FPS_SPF(:,:,ispin))) + +! DIIS extrapolation + + call prepend(nBasSq,n_diis,error_diis(:,:,ispin),FPS_SPF(:,:,ispin)) + call prepend(nBasSq,n_diis,F_diis(:,:,ispin),F(:,:,ispin)) + call diis(nBasSq,min(n_diis,nSCF),error_diis(:,:,ispin),F_diis(:,:,ispin),F(:,:,ispin)) + +! Diagonalize Fock matrix + + cp(:,:,ispin) = matmul(transpose(X),matmul(F(:,:,ispin),X)) + call diagonalize_matrix(nBas,cp(:,:,ispin),e(:,:,ispin)) + + c(:,:,ispin) = matmul(X,cp(:,:,ispin)) + cO(1:nBas,1:nO,1:nspin) = c(1:nBas,1:nO,1:nspin) + +! Compute HF energy + +! EHF = 0.5d0*trace_matrix(nBas,matmul(P,Hc+F)) + +! Compute HOMO-LUMO gap + + if(nBas > nO) then + + Gap(:) = e(nO+1,:) - e(nO,:) + + else + + Gap(:) = 0d0 + + endif + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',EHF+ENuc,'|',maxval(Conv),'|',minval(Gap),'|' + + enddo + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + + +! Compute HF energy + + EHF = 0d0 + do ispin=1,nspin + + ET(ispin) = trace_matrix(nBas,matmul(P(:,:,ispin),T(:,:,ispin)) + EV(ispin) = trace_matrix(nBas,matmul(P(:,:,ispin),V(:,:,ispin)) + + EHF = EHF + ET(ispin) + EV(ispin) + + do jspin=1,nspin + + EJ(ispin,jspin) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,ispin),J(:,:,jspin)) + EK(ispin,jspin) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,ispin,K(:,:,jspin))) + + EHF = EHF + EJ(ispin,jspin) + EK(ispin,jspin) + + enddo + + enddo + + +! call print_UHF(nBas,nO,e,C,ENuc,ET,EV,EJ,EK,EHF) + +end subroutine UHF diff --git a/src/MCQC/antisymmetrize_ERI.f90 b/src/MCQC/antisymmetrize_ERI.f90 new file mode 100644 index 0000000..034c94a --- /dev/null +++ b/src/MCQC/antisymmetrize_ERI.f90 @@ -0,0 +1,46 @@ +subroutine antisymmetrize_ERI(ispin,nBas,ERI,db_ERI) + +! Antisymmetrize ERIs + + implicit none + +! Input variables + + integer,intent(in) :: ispin,nBas + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: i,j,k,l + +! Output variables + + double precision,intent(out) :: db_ERI(nBas,nBas,nBas,nBas) + + if(ispin == 1) then + + do i=1,nBas + do j=1,nBas + do k=1,nBas + do l=1,nBas + db_ERI(i,j,k,l) = 2d0*ERI(i,j,k,l) - ERI(i,j,l,k) + enddo + enddo + enddo + enddo + + elseif(ispin == 2) then + + do i=1,nBas + do j=1,nBas + do k=1,nBas + do l=1,nBas + db_ERI(i,j,k,l) = ERI(i,j,k,l) - ERI(i,j,l,k) + enddo + enddo + enddo + enddo + + endif + +end subroutine antisymmetrize_ERI diff --git a/src/MCQC/dcgw.f90 b/src/MCQC/dcgw.f90 new file mode 100644 index 0000000..e67ff3b --- /dev/null +++ b/src/MCQC/dcgw.f90 @@ -0,0 +1,84 @@ +function SigC_dcgw(x,y) result(SigC) + +! Degeneracy-corrected GW + + implicit none + include 'parameters.h' + +! Input variables + + double precision,intent(in) :: x,y + +! Local variables + + double precision,parameter :: eta = 0.1d0 + double precision :: r + +! Output variables + + double precision :: SigC + +! Compute the divergence-free term + + r = y/x + +! Bare style + + SigC = y*r + +! DCPT style + +! SigC = -0.5d0*x*(1d0-sqrt(1d0+4d0*r*r)) + +! QDPT style + +! SigC = y*r/sqrt(1d0+4d0*r*r) + +! Infinitesimal + +! SigC = y*y*x/(x*x+eta*eta) + +end function SigC_dcgw + +function Z_dcgw(x,y) result(Z) + + +! Derivative of the degeneracy-corrected GW + + implicit none + include 'parameters.h' + +! Input variables + + double precision,intent(in) :: x,y + +! Local variables + + double precision,parameter :: eta = 1d0 + double precision :: r + +! Output variables + + double precision :: Z + +! Compute the divergence-free term + + r = y/x + +! Bare style + + Z = r*r + +! DCPT style + +! Z = 0.5d0*(1d0-1d0/sqrt(1d0+4d0*r*r)) + +! QDPT style + +! Z = r/sqrt(1d0+4d0*r*r)/(1d0+4d0*r*r) + +! Infinitesimal + +! Z = y*y*(x*x-eta*eta)/(x*x+eta*eta)**2 + +end function Z_dcgw diff --git a/src/MCQC/density.f90 b/src/MCQC/density.f90 new file mode 100644 index 0000000..90a17c1 --- /dev/null +++ b/src/MCQC/density.f90 @@ -0,0 +1,51 @@ +subroutine density(doDrift,nBas,nWalk,P,gAO,dgAO,g,dg) + +! Calculate the Green functions + + implicit none + +! Input variables + + logical,intent(in) :: doDrift + integer,intent(in) :: nBas,nWalk + double precision,intent(in) :: P(nBas,nBas),gAO(nWalk,2,nBas),dgAO(nWalk,2,3,nBas) + +! Local variables + + integer :: iW,iEl,ixyz,mu,nu + +! Output variables + + double precision,intent(out) :: g(nWalk,2),dg(nWalk,2,3) + + g = 0d0 + do iW=1,nWalk + do iEl=1,2 + do mu=1,nBas + do nu=1,nBas + g(iW,iEl) = g(iW,iEl) + gAO(iW,iEl,mu)*P(mu,nu)*gAO(iW,iEl,nu) + enddo + enddo + enddo + enddo + + if(doDrift) then + + dg = 0d0 + do iW=1,nWalk + do iEl=1,2 + do ixyz=1,3 + do mu=1,nBas + do nu=1,nBas + dg(iW,iEl,ixyz) = dg(iW,iEl,ixyz) & + + P(mu,nu)*(dgAO(iW,iEl,ixyz,mu)*gAO(iW,iEl,nu) & + + gAO(iW,iEl,mu)*dgAO(iW,iEl,ixyz,nu)) + enddo + enddo + enddo + enddo + enddo + + endif + +end subroutine density diff --git a/src/MCQC/density_matrix.f90 b/src/MCQC/density_matrix.f90 new file mode 100644 index 0000000..3556388 --- /dev/null +++ b/src/MCQC/density_matrix.f90 @@ -0,0 +1,30 @@ +subroutine density_matrix(nBas,ON,c,P) + +! Compute density matrix based on the occupation numbers + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: ON(nBas),c(nBas,nBas) + +! Local variables + + integer :: mu,nu,i + +! Output variables + + double precision,intent(out) :: P(nBas,nBas) + + P(:,:) = 0d0 + + do mu=1,nBas + do nu=1,nBas + do i=1,nBas + P(mu,nu) = P(mu,nu) + 2d0*ON(i)*c(mu,i)*c(nu,i) + enddo + enddo + enddo + +end subroutine density_matrix diff --git a/src/MCQC/drift.f90 b/src/MCQC/drift.f90 new file mode 100644 index 0000000..0a002e0 --- /dev/null +++ b/src/MCQC/drift.f90 @@ -0,0 +1,50 @@ +subroutine drift(nWalk,r,r12,g,dg,F) + +! Compute quantum force + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nWalk + double precision,intent(in) :: r(nWalk,2,3),r12(nWalk),g(nWalk,2),dg(nWalk,2,3) + +! Local variables + + logical :: smoothDrift + double precision :: rij,rijSq,w,wSq,damp + integer :: iW + +! Output variables + + double precision,intent(out) :: F(nWalk,2,3) + +! Compute + + smoothDrift = .false. + w = 0.1d0 + wSq = w*w + + do iW=1,nWalk + + rij = r12(iW) + rijSq = rij*rij + + F(iW,1,1:3) = dg(iW,1,1:3)/g(iW,1) + F(iW,2,1:3) = dg(iW,2,1:3)/g(iW,2) + + if(smoothDrift) then + damp = 1d0 + 2d0*w/sqrt(pi)*rij*exp(-wSq*rijSq)/erfc(w*rij) + else + damp = 1d0 + endif + + F(iW,1,1:3) = F(iW,1,1:3) - damp*(r(iW,2,1:3) - r(iW,1,1:3))/rijSq + F(iW,2,1:3) = F(iW,2,1:3) - damp*(r(iW,2,1:3) - r(iW,1,1:3))/rijSq + + enddo + +! print*,' F',F + +end subroutine drift diff --git a/src/MCQC/eNcusp.f90.x b/src/MCQC/eNcusp.f90.x new file mode 100644 index 0000000..01381b0 --- /dev/null +++ b/src/MCQC/eNcusp.f90.x @@ -0,0 +1,42 @@ +subroutine eNcusp(nEl,nBas,S,T,V,G,X,ENuc,EHF,c,e,P,F) + +! Perform restricted Hartree-Fock calculation + + implicit none + +! Input variables + + integer,intent(in) :: nEl,nBas + double precision,intent(in) :: ENuc,EHF + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),G(nBas,nBas,nBas,nBas),X(nBas,nBas) + double precision,intent(out) :: c(nBas,nBas),e(nBas),P(nBas,nBas),F(nBas,nBas) + +! Local variables + + integer,parameter :: maxSCF = 128 + double precision,parameter :: thresh = 1d-6 + integer :: nO,nSCF,lwork,info + double precision :: ET,EV,Conv,Gap + double precision,allocatable :: Hc(:,:),cp(:,:),cO(:,:),Fp(:,:),work(:) + + integer :: mu,nu,lambda,sigma,i + +! Output variables + +! Number of occupied orbitals + if(mod(nEl,2) /= 0) then + write(*,*) 'closed-shell system required!' + stop + endif + nO = nEl/2 + +! Memory allocation + allocate(Hc(nBas,nBas),cp(nBas,nBas),cO(nBas,nO),Fp(nBas,nBas)) + lwork = 3*nBas + allocate(work(lwork)) + +! Core Hamiltonian + Hc = T + V + + +end subroutine eNcusp diff --git a/src/MCQC/evGW.f90 b/src/MCQC/evGW.f90 new file mode 100644 index 0000000..12bfb51 --- /dev/null +++ b/src/MCQC/evGW.f90 @@ -0,0 +1,207 @@ +subroutine evGW(maxSCF,thresh,max_diis,COHSEX,SOSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold,linearize, & + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,Hc,ERI_AO_basis,ERI_MO_basis,PHF,cHF,eHF,eG0W0) + +! Perform self-consistent eigenvalue-only GW calculation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF,max_diis + double precision,intent(in) :: thresh,ENuc,ERHF + logical,intent(in) :: COHSEX,SOSEX,BSE,TDA,G0W,GW0 + logical,intent(in) :: singlet_manifold,triplet_manifold,linearize + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: cHF(nBas,nBas),eHF(nBas),eG0W0(nBas),Hc(nBas,nBas),PHF(nBas,nBas) + double precision,intent(in) :: ERI_AO_basis(nBas,nBas,nBas,nBas),ERI_MO_basis(nBas,nBas,nBas,nBas) + +! Local variables + + logical :: dRPA,linear_mixing + integer :: ispin,nSCF,n_diis + double precision :: Conv,EcRPA,lambda + double precision,allocatable :: error_diis(:,:),e_diis(:,:) + double precision,allocatable :: eGW(:),eOld(:),Z(:) + double precision,allocatable :: H(:,:),SigmaC(:) + double precision,allocatable :: Omega(:,:),XpY(:,:,:),rho(:,:,:,:),rhox(:,:,:,:) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Self-consistent evGW calculation |' + write(*,*)'************************************************' + write(*,*) + +! SOSEX correction + + if(SOSEX) write(*,*) 'SOSEX correction activated!' + write(*,*) + +! Switch off exchange for G0W0 + + dRPA = .true. + +! Linear mixing + + linear_mixing = .false. + lambda = 0.2d0 + +! Memory allocation + + allocate(eGW(nBas),eOld(nBas),Z(nBas), & + H(nBas,nBas),SigmaC(nBas), & + Omega(nS,nspin),XpY(nS,nS,nspin), & + rho(nBas,nBas,nS,nspin),rhox(nBas,nBas,nS,nspin), & + error_diis(nBas,max_diis),e_diis(nBas,max_diis)) + +! Initialization + + nSCF = 0 + ispin = 1 + n_diis = 0 + Conv = 1d0 + e_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + eGW(:) = eG0W0(:) + eOld(:) = eGW(:) + Z(:) = 1d0 + +! Compute Hartree Hamiltonian in the MO basis + + call Hartree_matrix_MO_basis(nBas,cHF,PHF,Hc,ERI_AO_basis,H) + +!------------------------------------------------------------------------ +! Main loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF <= maxSCF) + + ! Compute linear response + + if(.not. GW0 .or. nSCF == 0) then + + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,eGW,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + + endif + +! Compute correlation part of the self-energy + + call excitation_density(nBas,nC,nO,nR,nS,cHF,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + if(SOSEX) call excitation_density_SOSEX(nBas,nC,nO,nR,nS,cHF,ERI_AO_basis,XpY(:,:,ispin),rhox(:,:,:,ispin)) + + ! Correlation self-energy + + if(G0W) then + + call self_energy_correlation_diag(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,eHF, & + Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),SigmaC) + call renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,eHF,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),Z) + + else + + call self_energy_correlation_diag(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,eGW, & + Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),SigmaC) + call renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,eGW,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),Z) + + endif + + ! Solve the quasi-particle equation (linearized or not) + + if(linearize) then + + eGW(:) = eHF(:) + Z(:)*SigmaC(:) + + else + + eGW(:) = eHF(:) + SigmaC(:) + + endif + + ! Convergence criteria + + Conv = maxval(abs(eGW - eOld)) + + ! Print results + + call print_excitation('RPA ',ispin,nS,Omega(:,ispin)) + call print_evGW(nBas,nO,nSCF,Conv,eHF,ENuc,ERHF,SigmaC,Z,eGW,EcRPA) + + ! Linear mixing or DIIS extrapolation + + if(linear_mixing) then + + eGW(:) = lambda*eGW(:) + (1d0 - lambda)*eOld(:) + + else + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBas,nBas,n_diis,error_diis,e_diis,eGW-eOld,eGW) + + endif + + ! Save quasiparticles energy for next cycle + + eOld(:) = eGW(:) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main loop +!------------------------------------------------------------------------ + +! Plot stuff + + call plot_GW(nBas,nC,nO,nV,nR,nS,eHF,eGW,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin)) + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + if(BSE) stop + + endif + +! Perform BSE calculation + + if(BSE) then + + ! Singlet manifold + if(singlet_manifold) then + + ispin = 1 + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,eGW,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + ! Triplet manifold + if(triplet_manifold) then + + ispin = 2 + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,eGW,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call excitation_density(nBas,nC,nO,nR,nS,cHF,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,eGW,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + endif + +end subroutine evGW diff --git a/src/MCQC/exchange_matrix_AO_basis.f90 b/src/MCQC/exchange_matrix_AO_basis.f90 new file mode 100644 index 0000000..b60a59a --- /dev/null +++ b/src/MCQC/exchange_matrix_AO_basis.f90 @@ -0,0 +1,35 @@ +subroutine exchange_matrix_AO_basis(nBas,P,G,K) + +! Compute exchange matrix in the AO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: G(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: mu,nu,la,si + +! Output variables + + double precision,intent(out) :: K(nBas,nBas) + + K = 0d0 + do nu=1,nBas + do si=1,nBas + do la=1,nBas + do mu=1,nBas + K(mu,nu) = K(mu,nu) + P(la,si)*G(mu,la,si,nu) + enddo + enddo + enddo + enddo + + K = -0.5d0*K + +end subroutine exchange_matrix_AO_basis diff --git a/src/MCQC/exchange_matrix_MO_basis.f90 b/src/MCQC/exchange_matrix_MO_basis.f90 new file mode 100644 index 0000000..5cb13b1 --- /dev/null +++ b/src/MCQC/exchange_matrix_MO_basis.f90 @@ -0,0 +1,26 @@ +subroutine exchange_matrix_MO_basis(nBas,c,P,G,K) + +! Compute exchange matrix in the MO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas),P(nBas,nBas) + double precision,intent(in) :: G(nBas,nBas,nBas,nBas) + +! Output variables + + double precision,intent(out) :: K(nBas,nBas) + +! Compute Hartree Hamiltonian in the AO basis + + call exchange_matrix_AO_basis(nBas,P,G,K) + +! Transform Coulomb matrix in the MO basis + + K = matmul(transpose(c),matmul(K,c)) + +end subroutine exchange_matrix_MO_basis diff --git a/src/MCQC/excitation_density.f90 b/src/MCQC/excitation_density.f90 new file mode 100644 index 0000000..db8f222 --- /dev/null +++ b/src/MCQC/excitation_density.f90 @@ -0,0 +1,65 @@ +subroutine excitation_density(nBas,nC,nO,nR,nS,c,G,XpY,rho) + +! Compute excitation densities + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nR,nS + double precision,intent(in) :: c(nBas,nBas),G(nBas,nBas,nBas,nBas),XpY(nS,nS) + +! Local variables + + double precision,allocatable :: scr(:,:,:) + integer :: mu,nu,la,si,ia,jb,x,y,j,b + +! Output variables + + double precision,intent(out) :: rho(nBas,nBas,nS) + +! Memory allocation + allocate(scr(nBas,nBas,nS)) + + rho(:,:,:) = 0d0 + do nu=1,nBas + do si=1,nBas + do ia=1,nS + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + rho(nu,si,ia) = rho(nu,si,ia) + c(nu,j)*XpY(ia,jb)*c(si,b) + enddo + enddo + enddo + enddo + enddo + + scr(:,:,:) = 0d0 + do mu=1,nBas + do la=1,nBas + do ia=1,nS + do nu=1,nBas + do si=1,nBas + scr(mu,la,ia) = scr(mu,la,ia) + G(mu,nu,la,si)*rho(nu,si,ia) + enddo + enddo + enddo + enddo + enddo + + rho(:,:,:) = 0d0 + do ia=1,nS + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do mu=1,nBas + do la=1,nBas + rho(x,y,ia) = rho(x,y,ia) + c(mu,x)*scr(mu,la,ia)*c(la,y) + enddo + enddo + enddo + enddo + enddo + +end subroutine excitation_density diff --git a/src/MCQC/excitation_density_SOSEX.f90 b/src/MCQC/excitation_density_SOSEX.f90 new file mode 100644 index 0000000..53c9a66 --- /dev/null +++ b/src/MCQC/excitation_density_SOSEX.f90 @@ -0,0 +1,65 @@ +subroutine excitation_density_SOSEX(nBas,nC,nO,nR,nS,c,G,XpY,rho) + +! Compute excitation densities + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nR,nS + double precision,intent(in) :: c(nBas,nBas),G(nBas,nBas,nBas,nBas),XpY(nS,nS) + +! Local variables + + double precision,allocatable :: scr(:,:,:) + integer :: mu,nu,la,si,ia,jb,x,y,j,b + +! Output variables + + double precision,intent(out) :: rho(nBas,nBas,nS) + +! Memory allocation + allocate(scr(nBas,nBas,nS)) + + rho(:,:,:) = 0d0 + do nu=1,nBas + do si=1,nBas + do ia=1,nS + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + rho(nu,si,ia) = rho(nu,si,ia) + c(nu,j)*XpY(ia,jb)*c(si,b) + enddo + enddo + enddo + enddo + enddo + + scr(:,:,:) = 0d0 + do mu=1,nBas + do la=1,nBas + do ia=1,nS + do nu=1,nBas + do si=1,nBas + scr(mu,la,ia) = scr(mu,la,ia) + G(mu,nu,la,si)*rho(nu,si,ia) + enddo + enddo + enddo + enddo + enddo + + rho(:,:,:) = 0d0 + do ia=1,nS + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do mu=1,nBas + do la=1,nBas + rho(x,y,ia) = rho(x,y,ia) + c(mu,x)*scr(mu,la,ia)*c(la,y) + enddo + enddo + enddo + enddo + enddo + +end subroutine excitation_density_SOSEX diff --git a/src/MCQC/form_CABS.f90.x b/src/MCQC/form_CABS.f90.x new file mode 100644 index 0000000..73a279f --- /dev/null +++ b/src/MCQC/form_CABS.f90.x @@ -0,0 +1,60 @@ +subroutine form_CABS(nBas_OBS,nBas_ABS,c_OBS,c_ABS,S_ABS) + +! Perform configuration interaction single calculation` + + implicit none + +! Input variables + + integer,intent(in) :: nBas_OBS,nBas_ABS + double precision,intent(in) :: S_ABS(nBas,nBas),c_OBS(nBas_OBS,nBas_OBS) + +! Local variables + + integer :: + double precision :: thresh = 1d-07 + integer :: i,j,a,b + +! Output variables + + double precision,intent(out) :: c_ABS(nBas_ABS,nBas_ABS) + + allocate(c(nBas_ABS,nBAs_OBS)) + + c = 0d0 + c(1:nBas_OBS,1:nBas_OBS) = c_OBS(1:nBas_OBS,1:nBAs_OBS) + + c_ABS = 0d0 + do i=1,nBas_ABS + c_ABS(i,i) = 1d0 + enddo + + v_ABS = S_ABS + + call DiagMat(nBas_ABS,v_ABS,e_ABS) + + nLD = 0 + do i=1,nBas_ABS + if(abs(e_ABS(i)) < thresh) nLD = nLD +1 + enddo + write(*,*) 'Number of linear dependencies in ABS',nLD + + call DoSVD(nBas_ABS,S_ABS,u,v,w) + +! do a SVD of S_ABS to get u, v and w + + X_ABS = 0d0 + do i=1,nBas_ABS + do j=1,nBas_ABS + do k=1,nBas_ABS + X_ABS(i,k) = X_ABS(i,k) + v_ABS(i,j)*e_ABS(j)*v_ABS(k,j) + enddo + enddo + enddo + + cp_ABS = matmul(X_ABS,c_ABS) + + S12 = matmul(transpose(c),matmul(S_ABS,cp_ABS)) + + +end subroutine form_CABS diff --git a/src/MCQC/generate_shell.f90 b/src/MCQC/generate_shell.f90 new file mode 100644 index 0000000..0a13b8f --- /dev/null +++ b/src/MCQC/generate_shell.f90 @@ -0,0 +1,30 @@ +subroutine generate_shell(atot,nShellFunction,ShellFunction) + + implicit none + +! Input variables + + integer,intent(in) :: atot,nShellFunction + +! Local variables + + integer :: ax,ay,az,ia + +! Output variables + + integer,intent(out) :: ShellFunction(nShellFunction,3) + + ia = 0 + do ax=atot,0,-1 + do az=0,atot + ay = atot - ax - az + if(ay >= 0) then + ia = ia + 1 + ShellFunction(ia,1) = ax + ShellFunction(ia,2) = ay + ShellFunction(ia,3) = az + endif + enddo + enddo + +end subroutine generate_shell diff --git a/src/MCQC/initialize_random_generator.f90 b/src/MCQC/initialize_random_generator.f90 new file mode 100644 index 0000000..189c36b --- /dev/null +++ b/src/MCQC/initialize_random_generator.f90 @@ -0,0 +1,25 @@ +subroutine initialize_random_generator(iSeed) + +! Initialize random number generator + + implicit none + +! Input variables + + integer,intent(in) :: iSeed + +! Local variables + + integer,allocatable :: Seed(:) + integer :: nSeed + + call random_seed(size = nSeed) + allocate(Seed(nSeed)) + call random_seed(get=Seed) + if(iSeed /= 0) then + Seed = 0 + Seed(1) = iSeed + endif + call random_seed(put=Seed) + +end subroutine initialize_random_generator diff --git a/src/MCQC/linear_response.f90 b/src/MCQC/linear_response.f90 new file mode 100644 index 0000000..7a21e58 --- /dev/null +++ b/src/MCQC/linear_response.f90 @@ -0,0 +1,81 @@ +subroutine linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI,rho,EcRPA,Omega,XpY) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA,TDA,BSE + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas),rho(nBas,nBas,nS) + +! Local variables + + double precision :: trace_matrix + double precision,allocatable :: A(:,:),B(:,:),ApB(:,:),AmB(:,:),AmBSq(:,:),Z(:,:) + +! Output variables + + double precision,intent(out) :: EcRPA + double precision,intent(out) :: Omega(nS),XpY(nS,nS) + + +! Memory allocation + + allocate(A(nS,nS),B(nS,nS),ApB(nS,nS),AmB(nS,nS),AmBSq(nS,nS),Z(nS,nS)) + +! Build A and B matrices + + call linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,e,ERI,A) + if(BSE) call Bethe_Salpeter_A_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,A) + +! Tamm-Dancoff approximation + + B = 0d0 + if(.not. TDA) then + + call linear_response_B_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,ERI,B) + if(BSE) call Bethe_Salpeter_B_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,B) + + endif + +! Build A + B and A - B matrices + + AmB = A - B + ApB = A + B + +! print*,'A+B' +! call matout(nS,nS,ApB) + +! print*,'A-B' +! call matout(nS,nS,AmB) + +! Diagonalize TD-HF matrix + + call diagonalize_matrix(nS,AmB,Omega) + + if(minval(Omega) < 0d0) & + call print_warning('You may have instabilities in linear response!!') + + call ADAt(nS,AmB,sqrt(Omega),AmBSq) + Z = matmul(AmBSq,matmul(ApB,AmBSq)) + + call diagonalize_matrix(nS,Z,Omega) + + if(minval(Omega) < 0d0) & + call print_warning('You may have instabilities in linear response!!') + + Omega = sqrt(Omega) + XpY = matmul(transpose(Z),AmBSq) + call DA(nS,1d0/sqrt(Omega),XpY) + +! print*,'RPA excitations' +! call matout(nS,1,Omega) + +! Compute the RPA correlation energy + + EcRPA = 0.5d0*(sum(Omega) - trace_matrix(nS,A)) + +end subroutine linear_response diff --git a/src/MCQC/linear_response_A_matrix.f90 b/src/MCQC/linear_response_A_matrix.f90 new file mode 100644 index 0000000..c61ffd9 --- /dev/null +++ b/src/MCQC/linear_response_A_matrix.f90 @@ -0,0 +1,56 @@ +subroutine linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,e,ERI,A_lr) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas) + +! Local variables + + double precision :: delta_spin,delta_dRPA + double precision :: Kronecker_delta + + integer :: i,j,a,b,ia,jb + +! Output variables + + double precision,intent(out) :: A_lr(nS,nS) + +! Singlet or triplet manifold? + + delta_spin = 0d0 + if(ispin == 1) delta_spin = +1d0 + if(ispin == 2) delta_spin = -1d0 + +! Direct RPA + + delta_dRPA = 0d0 + if(dRPA) delta_dRPA = 1d0 + +! Build A matrix + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + A_lr(ia,jb) = (e(a) - e(i))*Kronecker_delta(i,j)*Kronecker_delta(a,b) & + + (1d0 + delta_spin)*ERI(i,b,a,j) & + - (1d0 - delta_dRPA)*ERI(i,b,j,a) + + enddo + enddo + enddo + enddo + +end subroutine linear_response_A_matrix diff --git a/src/MCQC/linear_response_B_matrix.f90 b/src/MCQC/linear_response_B_matrix.f90 new file mode 100644 index 0000000..17e5a85 --- /dev/null +++ b/src/MCQC/linear_response_B_matrix.f90 @@ -0,0 +1,54 @@ +subroutine linear_response_B_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,ERI,B_lr) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + double precision :: delta_spin,delta_dRPA + + integer :: i,j,a,b,ia,jb + +! Output variables + + double precision,intent(out) :: B_lr(nS,nS) + +! Singlet or triplet manifold? + + delta_spin = 0d0 + if(ispin == 1) delta_spin = +1d0 + if(ispin == 2) delta_spin = -1d0 + +! Direct RPA + + delta_dRPA = 0d0 + if(dRPA) delta_dRPA = 1d0 + +! Build A matrix + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + B_lr(ia,jb) = (1d0 + delta_spin)*ERI(i,j,a,b) & + - (1d0 - delta_dRPA)*ERI(i,j,b,a) + + enddo + enddo + enddo + enddo + +end subroutine linear_response_B_matrix diff --git a/src/MCQC/natural_orbital.f90 b/src/MCQC/natural_orbital.f90 new file mode 100644 index 0000000..14717a9 --- /dev/null +++ b/src/MCQC/natural_orbital.f90 @@ -0,0 +1,57 @@ +subroutine natural_orbital(nBas,nO,cHF,c) + +! Compute natural orbitals and natural occupancies + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: cHF(nBas,nBas),c(nBas,nBas) + +! Local variables + + integer :: i,j,k + double precision,allocatable :: eNO(:),cNO(:,:),P(:,:) + +! Allocate + + allocate(eNO(nBas),cNO(nBas,nBas),P(nBas,nBas)) + +! Compute density matrix + + P = matmul(transpose(cHF),cHF) + + call matout(nBas,nBas,P) + + cNO = 0d0 + + do i=1,nBas + do j=1,nBas + do k=1,1 + cNO(i,j) = cNO(i,j) + 2d0*P(i,k)*P(j,k) + enddo + enddo + enddo + +! cNO(:,:) = matmul(c(:,1:nO),transpose(c(:,1:nO))) + +! cNO = matmul(transpose(cHF),matmul(cNO,cHF)) + + call diagonalize_matrix(nBas,cNO,eNO) + +! Print results + + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' Natural orbitals ' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,nBas,cNO) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' Natural occupancies' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,eNO) + write(*,*) + +end subroutine natural_orbital diff --git a/src/MCQC/norm_trial.f90 b/src/MCQC/norm_trial.f90 new file mode 100644 index 0000000..4ca9e9c --- /dev/null +++ b/src/MCQC/norm_trial.f90 @@ -0,0 +1,53 @@ +subroutine norm_trial(nBas,nO,c,P,Norm,NormSq) + +! Initialize weight function + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nO + double precision,intent(inout):: c(nBas,nO),P(nBas,nBas) + +! Local variables + + double precision,allocatable :: S(:,:),T(:,:),V(:,:),Hc(:,:),G(:,:,:,:) + + integer :: mu,nu,la,si + +! Output variables + + double precision,intent(inout):: Norm,NormSq + +! Memory allocation for one- and two-electron integrals + + allocate(S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),G(nBas,nBas,nBas,nBas)) + +! Read integrals + + call read_integrals(nBas,S,T,V,Hc,G) + +! Compute normalization factor + + P = 2d0*matmul(c,transpose(c)) + + Norm = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + Norm = Norm + P(mu,nu)*P(la,si)*G(mu,la,nu,si) + enddo + enddo + enddo + enddo + + Norm = Norm*Norm + NormSq = Norm*Norm + + write(*,*) + write(*,*) 'Normalization of trial wave function: ',Norm + write(*,*) + +end subroutine norm_trial diff --git a/src/MCQC/obj/ADC.o b/src/MCQC/obj/ADC.o new file mode 100644 index 0000000..f736d0e Binary files /dev/null and b/src/MCQC/obj/ADC.o differ diff --git a/src/MCQC/obj/ADC2.o b/src/MCQC/obj/ADC2.o new file mode 100644 index 0000000..83b60fa Binary files /dev/null and b/src/MCQC/obj/ADC2.o differ diff --git a/src/MCQC/obj/AO_values.o b/src/MCQC/obj/AO_values.o new file mode 100644 index 0000000..8d94e7c Binary files /dev/null and b/src/MCQC/obj/AO_values.o differ diff --git a/src/MCQC/obj/AOtoMO_integral_transform.o b/src/MCQC/obj/AOtoMO_integral_transform.o new file mode 100644 index 0000000..d361c5c Binary files /dev/null and b/src/MCQC/obj/AOtoMO_integral_transform.o differ diff --git a/src/MCQC/obj/AOtoMO_oooa.o b/src/MCQC/obj/AOtoMO_oooa.o new file mode 100644 index 0000000..5315334 Binary files /dev/null and b/src/MCQC/obj/AOtoMO_oooa.o differ diff --git a/src/MCQC/obj/AOtoMO_oooo.o b/src/MCQC/obj/AOtoMO_oooo.o new file mode 100644 index 0000000..ca7b75c Binary files /dev/null and b/src/MCQC/obj/AOtoMO_oooo.o differ diff --git a/src/MCQC/obj/AOtoMO_oovv.o b/src/MCQC/obj/AOtoMO_oovv.o new file mode 100644 index 0000000..f1afc2b Binary files /dev/null and b/src/MCQC/obj/AOtoMO_oovv.o differ diff --git a/src/MCQC/obj/AOtoMO_transform.o b/src/MCQC/obj/AOtoMO_transform.o new file mode 100644 index 0000000..d4f0bfb Binary files /dev/null and b/src/MCQC/obj/AOtoMO_transform.o differ diff --git a/src/MCQC/obj/Bethe_Salpeter_A_matrix.o b/src/MCQC/obj/Bethe_Salpeter_A_matrix.o new file mode 100644 index 0000000..fb92770 Binary files /dev/null and b/src/MCQC/obj/Bethe_Salpeter_A_matrix.o differ diff --git a/src/MCQC/obj/Bethe_Salpeter_B_matrix.o b/src/MCQC/obj/Bethe_Salpeter_B_matrix.o new file mode 100644 index 0000000..4068154 Binary files /dev/null and b/src/MCQC/obj/Bethe_Salpeter_B_matrix.o differ diff --git a/src/MCQC/obj/CIS.o b/src/MCQC/obj/CIS.o new file mode 100644 index 0000000..8a3608c Binary files /dev/null and b/src/MCQC/obj/CIS.o differ diff --git a/src/MCQC/obj/Coulomb_matrix_AO_basis.o b/src/MCQC/obj/Coulomb_matrix_AO_basis.o new file mode 100644 index 0000000..4b336c1 Binary files /dev/null and b/src/MCQC/obj/Coulomb_matrix_AO_basis.o differ diff --git a/src/MCQC/obj/Coulomb_matrix_MO_basis.o b/src/MCQC/obj/Coulomb_matrix_MO_basis.o new file mode 100644 index 0000000..fcfaab1 Binary files /dev/null and b/src/MCQC/obj/Coulomb_matrix_MO_basis.o differ diff --git a/src/MCQC/obj/DIIS_extrapolation.o b/src/MCQC/obj/DIIS_extrapolation.o new file mode 100644 index 0000000..b05478d Binary files /dev/null and b/src/MCQC/obj/DIIS_extrapolation.o differ diff --git a/src/MCQC/obj/G0W0.o b/src/MCQC/obj/G0W0.o new file mode 100644 index 0000000..1f075e5 Binary files /dev/null and b/src/MCQC/obj/G0W0.o differ diff --git a/src/MCQC/obj/GF2.o b/src/MCQC/obj/GF2.o new file mode 100644 index 0000000..42597b1 Binary files /dev/null and b/src/MCQC/obj/GF2.o differ diff --git a/src/MCQC/obj/GF2_diag.o b/src/MCQC/obj/GF2_diag.o new file mode 100644 index 0000000..03fee9d Binary files /dev/null and b/src/MCQC/obj/GF2_diag.o differ diff --git a/src/MCQC/obj/GF3_diag.o b/src/MCQC/obj/GF3_diag.o new file mode 100644 index 0000000..737c163 Binary files /dev/null and b/src/MCQC/obj/GF3_diag.o differ diff --git a/src/MCQC/obj/Green_function.o b/src/MCQC/obj/Green_function.o new file mode 100644 index 0000000..4bab158 Binary files /dev/null and b/src/MCQC/obj/Green_function.o differ diff --git a/src/MCQC/obj/Hartree_matrix_AO_basis.o b/src/MCQC/obj/Hartree_matrix_AO_basis.o new file mode 100644 index 0000000..b71acb8 Binary files /dev/null and b/src/MCQC/obj/Hartree_matrix_AO_basis.o differ diff --git a/src/MCQC/obj/Hartree_matrix_MO_basis.o b/src/MCQC/obj/Hartree_matrix_MO_basis.o new file mode 100644 index 0000000..712d922 Binary files /dev/null and b/src/MCQC/obj/Hartree_matrix_MO_basis.o differ diff --git a/src/MCQC/obj/MCMP2.o b/src/MCQC/obj/MCMP2.o new file mode 100644 index 0000000..ed5dd69 Binary files /dev/null and b/src/MCQC/obj/MCMP2.o differ diff --git a/src/MCQC/obj/MCQC.o b/src/MCQC/obj/MCQC.o new file mode 100644 index 0000000..39c1d87 Binary files /dev/null and b/src/MCQC/obj/MCQC.o differ diff --git a/src/MCQC/obj/MOM.o b/src/MCQC/obj/MOM.o new file mode 100644 index 0000000..6c77f0b Binary files /dev/null and b/src/MCQC/obj/MOM.o differ diff --git a/src/MCQC/obj/MOM_overlap.o b/src/MCQC/obj/MOM_overlap.o new file mode 100644 index 0000000..03c2c16 Binary files /dev/null and b/src/MCQC/obj/MOM_overlap.o differ diff --git a/src/MCQC/obj/MOtoAO_transform.o b/src/MCQC/obj/MOtoAO_transform.o new file mode 100644 index 0000000..22719cc Binary files /dev/null and b/src/MCQC/obj/MOtoAO_transform.o differ diff --git a/src/MCQC/obj/MP2.o b/src/MCQC/obj/MP2.o new file mode 100644 index 0000000..78e3fcf Binary files /dev/null and b/src/MCQC/obj/MP2.o differ diff --git a/src/MCQC/obj/MP2F12.o b/src/MCQC/obj/MP2F12.o new file mode 100644 index 0000000..a097f36 Binary files /dev/null and b/src/MCQC/obj/MP2F12.o differ diff --git a/src/MCQC/obj/MP3.o b/src/MCQC/obj/MP3.o new file mode 100644 index 0000000..5d2db85 Binary files /dev/null and b/src/MCQC/obj/MP3.o differ diff --git a/src/MCQC/obj/MinMCMP2.o b/src/MCQC/obj/MinMCMP2.o new file mode 100644 index 0000000..5745bf0 Binary files /dev/null and b/src/MCQC/obj/MinMCMP2.o differ diff --git a/src/MCQC/obj/NDrift.o b/src/MCQC/obj/NDrift.o new file mode 100644 index 0000000..e2e5ec2 Binary files /dev/null and b/src/MCQC/obj/NDrift.o differ diff --git a/src/MCQC/obj/Newton.o b/src/MCQC/obj/Newton.o new file mode 100644 index 0000000..b6a36d6 Binary files /dev/null and b/src/MCQC/obj/Newton.o differ diff --git a/src/MCQC/obj/NormCoeff.o b/src/MCQC/obj/NormCoeff.o new file mode 100644 index 0000000..ba3fada Binary files /dev/null and b/src/MCQC/obj/NormCoeff.o differ diff --git a/src/MCQC/obj/RHF.o b/src/MCQC/obj/RHF.o new file mode 100644 index 0000000..8ebbd2c Binary files /dev/null and b/src/MCQC/obj/RHF.o differ diff --git a/src/MCQC/obj/SPHF.o b/src/MCQC/obj/SPHF.o new file mode 100644 index 0000000..ce63129 Binary files /dev/null and b/src/MCQC/obj/SPHF.o differ diff --git a/src/MCQC/obj/SPMP2.o b/src/MCQC/obj/SPMP2.o new file mode 100644 index 0000000..fb0ea36 Binary files /dev/null and b/src/MCQC/obj/SPMP2.o differ diff --git a/src/MCQC/obj/SPTDHF.o b/src/MCQC/obj/SPTDHF.o new file mode 100644 index 0000000..0f319d6 Binary files /dev/null and b/src/MCQC/obj/SPTDHF.o differ diff --git a/src/MCQC/obj/SP_linear_response.o b/src/MCQC/obj/SP_linear_response.o new file mode 100644 index 0000000..d908703 Binary files /dev/null and b/src/MCQC/obj/SP_linear_response.o differ diff --git a/src/MCQC/obj/SP_linear_response_A_matrix.o b/src/MCQC/obj/SP_linear_response_A_matrix.o new file mode 100644 index 0000000..7d4256f Binary files /dev/null and b/src/MCQC/obj/SP_linear_response_A_matrix.o differ diff --git a/src/MCQC/obj/SP_linear_response_B_matrix.o b/src/MCQC/obj/SP_linear_response_B_matrix.o new file mode 100644 index 0000000..c60de1c Binary files /dev/null and b/src/MCQC/obj/SP_linear_response_B_matrix.o differ diff --git a/src/MCQC/obj/TDHF.o b/src/MCQC/obj/TDHF.o new file mode 100644 index 0000000..0d80ef3 Binary files /dev/null and b/src/MCQC/obj/TDHF.o differ diff --git a/src/MCQC/obj/antisymmetrize_ERI.o b/src/MCQC/obj/antisymmetrize_ERI.o new file mode 100644 index 0000000..8e881e7 Binary files /dev/null and b/src/MCQC/obj/antisymmetrize_ERI.o differ diff --git a/src/MCQC/obj/dcgw.o b/src/MCQC/obj/dcgw.o new file mode 100644 index 0000000..62de5c8 Binary files /dev/null and b/src/MCQC/obj/dcgw.o differ diff --git a/src/MCQC/obj/density.o b/src/MCQC/obj/density.o new file mode 100644 index 0000000..ef03763 Binary files /dev/null and b/src/MCQC/obj/density.o differ diff --git a/src/MCQC/obj/density_matrix.o b/src/MCQC/obj/density_matrix.o new file mode 100644 index 0000000..c820c49 Binary files /dev/null and b/src/MCQC/obj/density_matrix.o differ diff --git a/src/MCQC/obj/drift.o b/src/MCQC/obj/drift.o new file mode 100644 index 0000000..da346a4 Binary files /dev/null and b/src/MCQC/obj/drift.o differ diff --git a/src/MCQC/obj/evGW.o b/src/MCQC/obj/evGW.o new file mode 100644 index 0000000..ba9953b Binary files /dev/null and b/src/MCQC/obj/evGW.o differ diff --git a/src/MCQC/obj/exchange_matrix_AO_basis.o b/src/MCQC/obj/exchange_matrix_AO_basis.o new file mode 100644 index 0000000..936816b Binary files /dev/null and b/src/MCQC/obj/exchange_matrix_AO_basis.o differ diff --git a/src/MCQC/obj/exchange_matrix_MO_basis.o b/src/MCQC/obj/exchange_matrix_MO_basis.o new file mode 100644 index 0000000..6a9d731 Binary files /dev/null and b/src/MCQC/obj/exchange_matrix_MO_basis.o differ diff --git a/src/MCQC/obj/excitation_density.o b/src/MCQC/obj/excitation_density.o new file mode 100644 index 0000000..3e0cd11 Binary files /dev/null and b/src/MCQC/obj/excitation_density.o differ diff --git a/src/MCQC/obj/excitation_density_SOSEX.o b/src/MCQC/obj/excitation_density_SOSEX.o new file mode 100644 index 0000000..cf4035f Binary files /dev/null and b/src/MCQC/obj/excitation_density_SOSEX.o differ diff --git a/src/MCQC/obj/generate_shell.o b/src/MCQC/obj/generate_shell.o new file mode 100644 index 0000000..159655e Binary files /dev/null and b/src/MCQC/obj/generate_shell.o differ diff --git a/src/MCQC/obj/initialize_random_generator.o b/src/MCQC/obj/initialize_random_generator.o new file mode 100644 index 0000000..c4db988 Binary files /dev/null and b/src/MCQC/obj/initialize_random_generator.o differ diff --git a/src/MCQC/obj/linear_response.o b/src/MCQC/obj/linear_response.o new file mode 100644 index 0000000..787989a Binary files /dev/null and b/src/MCQC/obj/linear_response.o differ diff --git a/src/MCQC/obj/linear_response_A_matrix.o b/src/MCQC/obj/linear_response_A_matrix.o new file mode 100644 index 0000000..4311e6d Binary files /dev/null and b/src/MCQC/obj/linear_response_A_matrix.o differ diff --git a/src/MCQC/obj/linear_response_B_matrix.o b/src/MCQC/obj/linear_response_B_matrix.o new file mode 100644 index 0000000..48f37c7 Binary files /dev/null and b/src/MCQC/obj/linear_response_B_matrix.o differ diff --git a/src/MCQC/obj/natural_orbital.o b/src/MCQC/obj/natural_orbital.o new file mode 100644 index 0000000..4245ce8 Binary files /dev/null and b/src/MCQC/obj/natural_orbital.o differ diff --git a/src/MCQC/obj/norm_trial.o b/src/MCQC/obj/norm_trial.o new file mode 100644 index 0000000..3f94ee7 Binary files /dev/null and b/src/MCQC/obj/norm_trial.o differ diff --git a/src/MCQC/obj/optimize_timestep.o b/src/MCQC/obj/optimize_timestep.o new file mode 100644 index 0000000..735761e Binary files /dev/null and b/src/MCQC/obj/optimize_timestep.o differ diff --git a/src/MCQC/obj/orthogonalization_matrix.o b/src/MCQC/obj/orthogonalization_matrix.o new file mode 100644 index 0000000..78f6615 Binary files /dev/null and b/src/MCQC/obj/orthogonalization_matrix.o differ diff --git a/src/MCQC/obj/overlap.o b/src/MCQC/obj/overlap.o new file mode 100644 index 0000000..0646a05 Binary files /dev/null and b/src/MCQC/obj/overlap.o differ diff --git a/src/MCQC/obj/plot_GW.o b/src/MCQC/obj/plot_GW.o new file mode 100644 index 0000000..7701b26 Binary files /dev/null and b/src/MCQC/obj/plot_GW.o differ diff --git a/src/MCQC/obj/print_G0W0.o b/src/MCQC/obj/print_G0W0.o new file mode 100644 index 0000000..4984798 Binary files /dev/null and b/src/MCQC/obj/print_G0W0.o differ diff --git a/src/MCQC/obj/print_GF2.o b/src/MCQC/obj/print_GF2.o new file mode 100644 index 0000000..3d41fc4 Binary files /dev/null and b/src/MCQC/obj/print_GF2.o differ diff --git a/src/MCQC/obj/print_GF3.o b/src/MCQC/obj/print_GF3.o new file mode 100644 index 0000000..c7ca821 Binary files /dev/null and b/src/MCQC/obj/print_GF3.o differ diff --git a/src/MCQC/obj/print_RHF.o b/src/MCQC/obj/print_RHF.o new file mode 100644 index 0000000..1850caa Binary files /dev/null and b/src/MCQC/obj/print_RHF.o differ diff --git a/src/MCQC/obj/print_evGW.o b/src/MCQC/obj/print_evGW.o new file mode 100644 index 0000000..eba0a36 Binary files /dev/null and b/src/MCQC/obj/print_evGW.o differ diff --git a/src/MCQC/obj/print_excitation.o b/src/MCQC/obj/print_excitation.o new file mode 100644 index 0000000..f85b16b Binary files /dev/null and b/src/MCQC/obj/print_excitation.o differ diff --git a/src/MCQC/obj/print_qsGW.o b/src/MCQC/obj/print_qsGW.o new file mode 100644 index 0000000..879b72d Binary files /dev/null and b/src/MCQC/obj/print_qsGW.o differ diff --git a/src/MCQC/obj/qsGW.o b/src/MCQC/obj/qsGW.o new file mode 100644 index 0000000..6057fee Binary files /dev/null and b/src/MCQC/obj/qsGW.o differ diff --git a/src/MCQC/obj/qsGW_PT.o b/src/MCQC/obj/qsGW_PT.o new file mode 100644 index 0000000..236539c Binary files /dev/null and b/src/MCQC/obj/qsGW_PT.o differ diff --git a/src/MCQC/obj/read_F12_integrals.o b/src/MCQC/obj/read_F12_integrals.o new file mode 100644 index 0000000..99be097 Binary files /dev/null and b/src/MCQC/obj/read_F12_integrals.o differ diff --git a/src/MCQC/obj/read_MOs.o b/src/MCQC/obj/read_MOs.o new file mode 100644 index 0000000..82508e4 Binary files /dev/null and b/src/MCQC/obj/read_MOs.o differ diff --git a/src/MCQC/obj/read_auxiliary_basis.o b/src/MCQC/obj/read_auxiliary_basis.o new file mode 100644 index 0000000..b7a86f4 Binary files /dev/null and b/src/MCQC/obj/read_auxiliary_basis.o differ diff --git a/src/MCQC/obj/read_basis.o b/src/MCQC/obj/read_basis.o new file mode 100644 index 0000000..ad94692 Binary files /dev/null and b/src/MCQC/obj/read_basis.o differ diff --git a/src/MCQC/obj/read_geometry.o b/src/MCQC/obj/read_geometry.o new file mode 100644 index 0000000..8916325 Binary files /dev/null and b/src/MCQC/obj/read_geometry.o differ diff --git a/src/MCQC/obj/read_integrals.o b/src/MCQC/obj/read_integrals.o new file mode 100644 index 0000000..48ec87f Binary files /dev/null and b/src/MCQC/obj/read_integrals.o differ diff --git a/src/MCQC/obj/read_methods.o b/src/MCQC/obj/read_methods.o new file mode 100644 index 0000000..0597307 Binary files /dev/null and b/src/MCQC/obj/read_methods.o differ diff --git a/src/MCQC/obj/read_molecule.o b/src/MCQC/obj/read_molecule.o new file mode 100644 index 0000000..4a8b698 Binary files /dev/null and b/src/MCQC/obj/read_molecule.o differ diff --git a/src/MCQC/obj/read_options.o b/src/MCQC/obj/read_options.o new file mode 100644 index 0000000..643ff9f Binary files /dev/null and b/src/MCQC/obj/read_options.o differ diff --git a/src/MCQC/obj/renormalization_factor.o b/src/MCQC/obj/renormalization_factor.o new file mode 100644 index 0000000..18f5913 Binary files /dev/null and b/src/MCQC/obj/renormalization_factor.o differ diff --git a/src/MCQC/obj/rij.o b/src/MCQC/obj/rij.o new file mode 100644 index 0000000..55f16c0 Binary files /dev/null and b/src/MCQC/obj/rij.o differ diff --git a/src/MCQC/obj/self_energy_correlation.o b/src/MCQC/obj/self_energy_correlation.o new file mode 100644 index 0000000..ac88ff5 Binary files /dev/null and b/src/MCQC/obj/self_energy_correlation.o differ diff --git a/src/MCQC/obj/self_energy_correlation_diag.o b/src/MCQC/obj/self_energy_correlation_diag.o new file mode 100644 index 0000000..bdbc6cf Binary files /dev/null and b/src/MCQC/obj/self_energy_correlation_diag.o differ diff --git a/src/MCQC/obj/self_energy_exchange.o b/src/MCQC/obj/self_energy_exchange.o new file mode 100644 index 0000000..7e109c5 Binary files /dev/null and b/src/MCQC/obj/self_energy_exchange.o differ diff --git a/src/MCQC/obj/transition_probability.o b/src/MCQC/obj/transition_probability.o new file mode 100644 index 0000000..593b975 Binary files /dev/null and b/src/MCQC/obj/transition_probability.o differ diff --git a/src/MCQC/obj/utils.o b/src/MCQC/obj/utils.o new file mode 100644 index 0000000..acf3a22 Binary files /dev/null and b/src/MCQC/obj/utils.o differ diff --git a/src/MCQC/obj/wrap_lapack.o b/src/MCQC/obj/wrap_lapack.o new file mode 100644 index 0000000..ac714a8 Binary files /dev/null and b/src/MCQC/obj/wrap_lapack.o differ diff --git a/src/MCQC/optimize_timestep.f90 b/src/MCQC/optimize_timestep.f90 new file mode 100644 index 0000000..916854a --- /dev/null +++ b/src/MCQC/optimize_timestep.f90 @@ -0,0 +1,28 @@ +subroutine optimize_timestep(nWalk,iMC,Acc,dt) + +! Optimize dt to get 50% of accepted moves + + implicit none + +! Input variables + + integer,intent(in) :: nWalk,iMC + double precision,intent(inout):: Acc,dt + +! Local variables + + double precision :: TotAcc,Current_Acc,Target_Acc,delta + + TotAcc = Acc/dble(nWalk) + Current_Acc = 100d0*TotAcc/dble(iMC) + + Target_Acc = 50.0d0 + + delta = dt*abs(Target_Acc - Current_Acc)/100.d0 + if(Current_Acc > Target_Acc + 0.5d0)then + dt = dt + delta + elseif(Current_Acc < Target_Acc - 0.5d0)then + dt = dt - delta + endif + +end subroutine optimize_timestep diff --git a/src/MCQC/orthogonalization_matrix.f90 b/src/MCQC/orthogonalization_matrix.f90 new file mode 100644 index 0000000..15ea4ac --- /dev/null +++ b/src/MCQC/orthogonalization_matrix.f90 @@ -0,0 +1,120 @@ +subroutine orthogonalization_matrix(ortho_type,nBas,S,X) + +! Compute the orthogonalization matrix X + + implicit none + +! Input variables + + integer,intent(in) :: nBas,ortho_type + double precision,intent(in) :: S(nBas,nBas) + +! Local variables + + logical :: debug + double precision,allocatable :: UVec(:,:),Uval(:) + double precision,parameter :: thresh = 1d-6 + + integer :: i + +! Output variables + + double precision,intent(out) :: X(nBas,nBas) + + debug = .false. + +! Type of orthogonalization ortho_type +! +! 1 = Lowdin +! 2 = Canonical +! 3 = SVD +! + + allocate(Uvec(nBas,nBas),Uval(nBas)) + + if(ortho_type == 1) then + + write(*,*) + write(*,*) ' Lowdin orthogonalization' + write(*,*) + + Uvec = S + call diagonalize_matrix(nBas,Uvec,Uval) + + do i=1,nBas + + if(Uval(i) > thresh) then + + Uval(i) = 1d0/sqrt(Uval(i)) + + else + + write(*,*) 'Eigenvalue',i,'too small for Lowdin orthogonalization' + + endif + + enddo + + call ADAt(nBas,Uvec,Uval,X) + + elseif(ortho_type == 2) then + + write(*,*) + write(*,*) 'Canonical orthogonalization' + write(*,*) + + Uvec = S + call diagonalize_matrix(nBas,Uvec,Uval) + + do i=1,nBas + + if(Uval(i) > thresh) then + + Uval(i) = 1d0/sqrt(Uval(i)) + + else + + write(*,*) ' Eigenvalue',i,'too small for canonical orthogonalization' + + endif + + enddo + + call AD(nBas,Uvec,Uval) + X = Uvec + + elseif(ortho_type == 3) then + + write(*,*) + write(*,*) ' SVD-based orthogonalization NYI' + write(*,*) + +! Uvec = S +! call diagonalize_matrix(nBas,Uvec,Uval) + +! do i=1,nBas +! if(Uval(i) > thresh) then +! Uval(i) = 1d0/sqrt(Uval(i)) +! else +! write(*,*) 'Eigenvalue',i,'too small for canonical orthogonalization' +! endif +! enddo +! +! call AD(nBas,Uvec,Uval) +! X = Uvec + + endif + +! Print results + + if(debug) then + + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Orthogonalization matrix' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,X) + write(*,*) + + endif + +end subroutine orthogonalization_matrix diff --git a/src/MCQC/overlap.f90 b/src/MCQC/overlap.f90 new file mode 100644 index 0000000..bb38800 --- /dev/null +++ b/src/MCQC/overlap.f90 @@ -0,0 +1,40 @@ +subroutine overlap(nBas,bra,ket) + +! Compute the overlap between two sets of coefficients + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: bra(nBas,nBas),ket(nBas,nBas) + +! Local variables + + double precision,allocatable :: s(:),Ov(:,:) + +! Allocate + + allocate(s(nBas),Ov(nBas,nBas)) + +! Compute overlap + + Ov = matmul(transpose(bra),ket) + + call diagonalize_matrix(nBas,Ov,s) + +! Print results + + write(*,'(A50)') '---------------------------------------' + write(*,'(A50)') ' Overlap ' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,nBas,Ov) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A50)') ' Eigenvalues of overlap matrix' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,s) + write(*,*) + +end subroutine overlap diff --git a/src/MCQC/plot_GW.f90 b/src/MCQC/plot_GW.f90 new file mode 100644 index 0000000..11c7f0c --- /dev/null +++ b/src/MCQC/plot_GW.f90 @@ -0,0 +1,113 @@ +subroutine plot_GW(nBas,nC,nO,nV,nR,nS,eHF,eGW,Omega,rho,rhox) + +! Dump several GW quantities for external plotting + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: eHF(nBas),eGW(nBas),Omega(nS),rho(nBas,nBas,nS),rhox(nBas,nBas,nS) + +! Local variables + + integer :: i,j,a,b,x,jb,g + integer :: nGrid + double precision :: eps,eta,wmin,wmax,dw + double precision,allocatable :: w(:),SigC(:,:),Z(:,:),S(:,:) + +! Infinitesimal + + eta = 1d-3 + +! Construct grid + + nGrid = 1000 + allocate(w(nGrid),SigC(nBas,nGrid),Z(nBas,nGrid),S(nBas,nGrid)) + +! Initialize + + SigC(:,:) = 0d0 + Z(:,:) = 0d0 + +! Minimum and maximum frequency values + + wmin = -5d0 + wmax = +5d0 + dw = (wmax - wmin)/dble(ngrid) + + do g=1,nGrid + w(g) = wmin + dble(g)*dw + enddo + +! Occupied part of the self-energy and renormalization factor + + do g=1,nGrid + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = w(g) - eHF(i) + Omega(jb) + SigC(x,g) = SigC(x,g) + 2d0*rho(x,i,jb)**2*eps/(eps**2 + eta**2) + Z(x,g) = Z(x,g) + 2d0*rho(x,i,jb)**2/eps**2 + enddo + enddo + enddo + enddo + enddo + +! Virtual part of the self-energy and renormalization factor + + do g=1,nGrid + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = w(g) - eHF(a) - Omega(jb) + SigC(x,g) = SigC(x,g) + 2d0*rho(x,a,jb)**2*eps/(eps**2 + eta**2) + Z(x,g) = Z(x,g) + 2d0*rho(x,a,jb)**2/eps**2 + enddo + enddo + enddo + enddo + enddo + + Z(:,:) = 1d0/(1d0 + Z(:,:)) + +! Compute spectral function + + do g=1,nGrid + do x=nC+1,nBas-nR + S(x,g) = eta/((w(g) - eHF(x) - SigC(x,g))**2 + eta**2) + enddo + enddo + + S(:,:) = S(:,:)/pi + +! Dump quantities in files as a function of w + + open(unit=8 ,file='plot/grid.dat') + open(unit=9 ,file='plot/SigC.dat') + open(unit=10 ,file='plot/Z.dat') + open(unit=11 ,file='plot/A.dat') + + do g=1,nGrid + write(8 ,*) w(g)*HaToeV,(SigC(x,g)*HaToeV,x=1,nBas) + write(9 ,*) w(g)*HaToeV,((w(g)-eHF(x))*HaToeV,x=1,nBas) + write(10,*) w(g)*HaToeV,(Z(x,g),x=1,nBas) + write(11,*) w(g)*HaToeV,(S(x,g),x=1,nBas) + enddo + +! Closing files + + close(unit=8) + close(unit=9) + close(unit=10) + close(unit=11) + +end subroutine plot_GW diff --git a/src/MCQC/print_G0W0.f90 b/src/MCQC/print_G0W0.f90 new file mode 100644 index 0000000..e3f96a5 --- /dev/null +++ b/src/MCQC/print_G0W0.f90 @@ -0,0 +1,47 @@ +subroutine print_G0W0(nBas,nO,e,ENuc,EHF,SigmaC,Z,eGW,EcRPA) + +! Print one-electron energies and other stuff for G0W0 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: ENuc,EHF,EcRPA + double precision,intent(in) :: e(nBas),SigmaC(nBas),Z(nBas),eGW(nBas) + + integer :: x,HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGW(LUMO)-eGW(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------' + write(*,*)' One-shot G0W0 calculation' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','Sigma_c (eV)','|','Z','|','e_QP (eV)','|' + write(*,*)'-------------------------------------------------------------------------------' + + do x=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',x,'|',e(x)*HaToeV,'|',SigmaC(x)*HaToeV,'|',Z(x),'|',eGW(x)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'G0W0 HOMO energy (eV):',eGW(HOMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'G0W0 LUMO energy (eV):',eGW(LUMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'G0W0 HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'G0W0 total energy =',ENuc + EHF + EcRPA + write(*,'(2X,A27,F15.6)') 'RPA correlation energy =',EcRPA + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + +end subroutine print_G0W0 + + diff --git a/src/MCQC/print_GF2.f90 b/src/MCQC/print_GF2.f90 new file mode 100644 index 0000000..98a3933 --- /dev/null +++ b/src/MCQC/print_GF2.f90 @@ -0,0 +1,44 @@ +subroutine print_GF2(nBas,nO,nSCF,Conv,eHF,eGF2) + +! Print one-electron energies and other stuff for GF2 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO,nSCF + double precision,intent(in) :: Conv,eHF(nBas),eGF2(nBas) + + integer :: x,HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGF2(LUMO)-eGF2(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------' + write(*,*)' Frequency-dependent diagonal GF2 calculation' + write(*,*)'-------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','e_GF2 (eV)','|' + write(*,*)'-------------------------------------------' + + do x=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',x,'|',eHF(x)*HaToeV,'|',eGF2(x)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv + write(*,*)'-------------------------------------------' + write(*,'(2X,A27,F15.6)') 'GF2 HOMO energy (eV):',eGF2(HOMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'GF2 LUMO energy (eV):',eGF2(LUMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'GF2 HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,*)'-------------------------------------------' + write(*,*) + +end subroutine print_GF2 diff --git a/src/MCQC/print_GF3.f90 b/src/MCQC/print_GF3.f90 new file mode 100644 index 0000000..cf0634b --- /dev/null +++ b/src/MCQC/print_GF3.f90 @@ -0,0 +1,44 @@ +subroutine print_GF3(nBas,nO,nSCF,Conv,eHF,Z,eGF3) + +! Print one-electron energies and other stuff for GF3 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO,nSCF + double precision,intent(in) :: Conv,eHF(nBas),eGF3(nBas),Z(nBas) + + integer :: x,HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGF3(LUMO)-eGF3(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------------------------' + write(*,*)' Frequency-dependent diagonal GF3 calculation' + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','Z','|','e_GF3 (eV)','|' + write(*,*)'-------------------------------------------------------------' + + do x=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',x,'|',eHF(x)*HaToeV,'|',Z(x),'|',eGF3(x)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv + write(*,*)'-------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'GF3 HOMO energy (eV):',eGF3(HOMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'GF3 LUMO energy (eV):',eGF3(LUMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'GF3 HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,*)'-------------------------------------------------------------' + write(*,*) + +end subroutine print_GF3 diff --git a/src/MCQC/print_RHF.f90 b/src/MCQC/print_RHF.f90 new file mode 100644 index 0000000..eef7055 --- /dev/null +++ b/src/MCQC/print_RHF.f90 @@ -0,0 +1,60 @@ +subroutine print_RHF(nBas,nO,eHF,cHF,ENuc,ET,EV,EJ,EK,ERHF) + +! Print one-electron energies and other stuff for G0W0 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: eHF(nBas),cHF(nBas,nBas),ENuc,ET,EV,EJ,EK,ERHF + + integer :: HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eHF(LUMO)-eHF(HOMO) + +! Dump results + + + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' Summary ' + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' One-electron energy ',ET + EV + write(*,'(A32,1X,F16.10)') ' Kinetic energy ',ET + write(*,'(A32,1X,F16.10)') ' Potential energy ',EV + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' Two-electron energy ',EJ + EK + write(*,'(A32,1X,F16.10)') ' Coulomb energy ',EJ + write(*,'(A32,1X,F16.10)') ' Exchange energy ',EK + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' Electronic energy ',ERHF + write(*,'(A32,1X,F16.10)') ' Nuclear repulsion ',ENuc + write(*,'(A32,1X,F16.10)') ' Hartree-Fock energy ',ERHF + ENuc + write(*,'(A50)') '---------------------------------------' + write(*,'(A36,F13.6)') ' HF HOMO energy (eV):',eHF(HOMO)*HaToeV + write(*,'(A36,F13.6)') ' HF LUMO energy (eV):',eHF(LUMO)*HaToeV + write(*,'(A36,F13.6)') ' HF HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,'(A50)') '---------------------------------------' + write(*,*) + +! Print results + + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') 'MO coefficients' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,nBas,cHF) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') 'MO energies' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,eHF) + write(*,*) + +end subroutine print_RHF + + diff --git a/src/MCQC/print_evGW.f90 b/src/MCQC/print_evGW.f90 new file mode 100644 index 0000000..a3b143c --- /dev/null +++ b/src/MCQC/print_evGW.f90 @@ -0,0 +1,52 @@ +subroutine print_evGW(nBas,nO,nSCF,Conv,e,ENuc,EHF,SigmaC,Z,eGW,EcRPA) + +! Print one-electron energies and other stuff for evGW + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO,nSCF + double precision,intent(in) :: ENuc,EHF,EcRPA + double precision,intent(in) :: Conv,e(nBas),SigmaC(nBas),Z(nBas),eGW(nBas) + + integer :: x,HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGW(LUMO)-eGW(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------' + if(nSCF < 10) then + write(*,'(1X,A21,I1,A1,I1,A12)')' Self-consistent evG',nSCF,'W',nSCF,' calculation' + else + write(*,'(1X,A21,I2,A1,I2,A12)')' Self-consistent evG',nSCF,'W',nSCF,' calculation' + endif + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','Sigma_c (eV)','|','Z','|','e_QP (eV)','|' + write(*,*)'-------------------------------------------------------------------------------' + + do x=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',x,'|',e(x)*HaToeV,'|',SigmaC(x)*HaToeV,'|',Z(x),'|',eGW(x)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'evGW HOMO energy (eV):',eGW(HOMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'evGW LUMO energy (eV):',eGW(LUMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'evGW HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'evGW total energy =',ENuc + EHF + EcRPA + write(*,'(2X,A27,F15.6)') 'RPA correlation energy =',EcRPA + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + +end subroutine print_evGW diff --git a/src/MCQC/print_excitation.f90 b/src/MCQC/print_excitation.f90 new file mode 100644 index 0000000..dbf90ef --- /dev/null +++ b/src/MCQC/print_excitation.f90 @@ -0,0 +1,36 @@ +subroutine print_excitation(method,ispin,nS,Omega) + +! Print excitation energies for a given spin manifold + + implicit none + include 'parameters.h' + + character*5,intent(in) :: method + integer,intent(in) :: ispin,nS + double precision,intent(in) :: Omega(nS) + + character*7 :: spin_manifold + integer :: ia + + if(ispin == 1) spin_manifold = 'singlet' + if(ispin == 2) spin_manifold = 'triplet' + + write(*,*) + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A4,A14,A7,A9,A25)')'|',method,' calculation: ',spin_manifold,' manifold',' |' + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A5,1X,A1,1X,A23,1X,A1,1X,A23,1X,A1,1X)') & + '|','State','|',' Excitation energy (au) ','|',' Excitation energy (eV) ','|' + write(*,*)'-------------------------------------------------------------' + + do ia=1,nS + write(*,'(1X,A1,1X,I5,1X,A1,1X,F23.6,1X,A1,1X,F23.6,1X,A1,1X)') & + '|',ia,'|',Omega(ia),'|',Omega(ia)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------' + write(*,*) + +end subroutine print_excitation + + diff --git a/src/MCQC/print_qsGW.f90 b/src/MCQC/print_qsGW.f90 new file mode 100644 index 0000000..bf7eb87 --- /dev/null +++ b/src/MCQC/print_qsGW.f90 @@ -0,0 +1,110 @@ +subroutine print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,ENuc,P,T,V,Hc,J,K,F,SigmaC,Z,EcRPA) + + +! Print one-electron energies and other stuff for qsGW + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nO,nSCF + double precision,intent(in) :: ENuc,EcRPA,Conv,thresh + double precision,intent(in) :: eHF(nBas),eGW(nBas),c(nBas),P(nBas,nBas) + double precision,intent(in) :: T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas) + double precision,intent(in) :: J(nBas,nBas),K(nBas,nBas),F(nBas,nBas) + double precision,intent(in) :: Z(nBas),SigmaC(nBas,nBas) + +! Local variables + + integer :: x,HOMO,LUMO + double precision :: Gap,ET,EV,EJ,Ex,Ec,EqsGW + double precision,external :: trace_matrix + + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGW(LUMO)-eGW(HOMO) + + ET = trace_matrix(nBas,matmul(P,T)) + EV = trace_matrix(nBas,matmul(P,V)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + Ex = 0.5d0*trace_matrix(nBas,matmul(P,K)) + EqsGW = ET + EV + EJ + Ex + Ec = 0d0 + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------' + if(nSCF < 10) then + write(*,'(1X,A21,I1,A1,I1,A12)')' Self-consistent qsG',nSCF,'W',nSCF,' calculation' + else + write(*,'(1X,A21,I2,A1,I2,A12)')' Self-consistent qsG',nSCF,'W',nSCF,' calculation' + endif + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','e_QP-e_HF (eV)','|','Z','|','e_QP (eV)','|' + write(*,*)'-------------------------------------------------------------------------------' + + do x=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',x,'|',eHF(x)*HaToeV,'|',(eGW(x)-eHF(x))*HaToeV,'|',Z(x),'|',eGW(x)*HaToeV,'|' + enddo + + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A19,F15.5)')'max(|FPS - SPF|) = ',Conv + write(*,*)'-------------------------------------------' + write(*,'(2X,A27,F15.6)') 'qsGW HOMO energy (eV):',eGW(HOMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'qsGW LUMO energy (eV):',eGW(LUMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'qsGW HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,*)'-------------------------------------------' + write(*,'(2X,A27,F15.6)') 'qsGW total energy =',EqsGW + ENuc + write(*,'(2X,A27,F15.6)') 'qsGW exchange energy =',Ex + write(*,'(2X,A27,F15.6)') 'qsGW correlation energy =',Ec + write(*,'(2X,A27,F15.6)') 'RPA correlation energy =',EcRPA + write(*,*)'-------------------------------------------' + write(*,*) + +! Dump results for final iteration + + if(Conv < thresh) then + + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' Summary ' + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' One-electron energy ',ET + EV + write(*,'(A32,1X,F16.10)') ' Kinetic energy ',ET + write(*,'(A32,1X,F16.10)') ' Potential energy ',EV + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' Two-electron energy ',EJ + Ex + write(*,'(A32,1X,F16.10)') ' Coulomb energy ',EJ + write(*,'(A32,1X,F16.10)') ' Exchange energy ',Ex + write(*,'(A32,1X,F16.10)') ' Correlation energy ',Ec + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' Electronic energy ',EqsGW + write(*,'(A32,1X,F16.10)') ' Nuclear repulsion ',ENuc + write(*,'(A32,1X,F16.10)') ' qsGW energy ',ENuc + EqsGW + write(*,'(A32,1X,F16.10)') ' RPA corr. energy ',EcRPA + write(*,'(A50)') '---------------------------------------' + write(*,*) + + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' qsGW MO coefficients' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,nBas,c) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' qsGW MO energies' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,eGW) + write(*,*) + + endif + + +end subroutine print_qsGW diff --git a/src/MCQC/qsGW.f90 b/src/MCQC/qsGW.f90 new file mode 100644 index 0000000..364ad66 --- /dev/null +++ b/src/MCQC/qsGW.f90 @@ -0,0 +1,222 @@ +subroutine qsGW(maxSCF,thresh,max_diis,COHSEX,SOSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ENuc,S,X,T,V,Hc,ERI_AO_basis,PHF,cHF,eHF) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF,max_diis + double precision,intent(in) :: thresh + logical,intent(in) :: COHSEX,SOSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ENuc + double precision,intent(in) :: PHF(nBas,nBas),cHF(nBas,nBas),eHF(nBas) + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBAs),V(nBas,nBas),Hc(nBas,nBas),X(nBas,nBas) + double precision,intent(in) :: ERI_AO_basis(nBas,nBas,nBas,nBas) + +! Local variables + + logical :: dRPA + integer :: nSCF,nBasSq,ispin,n_diis + double precision :: EcRPA,Conv + double precision,external :: trace_matrix + double precision,allocatable :: error_diis(:,:),F_diis(:,:) + double precision,allocatable :: Omega(:,:),XpY(:,:,:),rho(:,:,:,:),rhox(:,:,:,:) + double precision,allocatable :: c(:,:),cp(:,:),e(:),P(:,:) + double precision,allocatable :: F(:,:),Fp(:,:),J(:,:),K(:,:) + double precision,allocatable :: SigC(:,:),SigCp(:,:),SigCm(:,:),Z(:) + double precision,allocatable :: error(:,:),ERI_MO_basis(:,:,:,:) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Self-consistent qsGW calculation |' + write(*,*)'************************************************' + write(*,*) + +! Stuff + + nBasSq = nBas*nBas + +! SOSEX correction + + if(SOSEX) write(*,*) 'SOSEX correction activated!' + write(*,*) + +! Switch off exchange for G0W0 + + dRPA = .true. + +! Memory allocation + + allocate(e(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), & + J(nBas,nBas),K(nBas,nBas),SigC(nBas,nBas),SigCp(nBas,nBas),SigCm(nBas,nBas),Z(nBas), & + ERI_MO_basis(nBas,nBas,nBas,nBas),error(nBas,nBas), & + Omega(nS,nspin),XpY(nS,nS,nspin),rho(nBas,nBas,nS,nspin),rhox(nBas,nBas,nS,nspin), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Initialization + + nSCF = 0 + n_diis = 0 + ispin = 1 + Conv = 1d0 + P(:,:) = PHF(:,:) + e(:) = eHF(:) + c(:,:) = cHF(:,:) + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + +!------------------------------------------------------------------------ +! Main loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF <= maxSCF) + + ! Buid Coulomb matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI_AO_basis,J) + + ! Compute exchange part of the self-energy + + call exchange_matrix_AO_basis(nBas,P,ERI_AO_basis,K) + + ! AO to MO transformation of two-electron integrals + + call AOtoMO_integral_transform(nBas,c,ERI_AO_basis,ERI_MO_basis) + + ! Compute linear response + + if(.not. GW0 .or. nSCF == 0) then + + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + + endif + + ! Compute correlation part of the self-energy + + call excitation_density(nBas,nC,nO,nR,nS,c,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + if(SOSEX) call excitation_density_SOSEX(nBas,nC,nO,nR,nS,c,ERI_AO_basis,XpY(:,:,ispin),rhox(:,:,:,ispin)) + + if(G0W) then + + call self_energy_correlation(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,eHF, & + Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),SigC) + call renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,eHF,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),Z) + + else + + call self_energy_correlation(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,e, & + Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),SigC) + call renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,e,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),Z) + + endif + + ! Make correlation self-energy Hermitian and transform it back to AO basis + + SigCp = 0.5d0*(SigC + transpose(SigC)) + SigCm = 0.5d0*(SigC - transpose(SigC)) + + call MOtoAO_transform(nBas,S,c,SigCp) + + ! Solve the quasi-particle equation + + F(:,:) = Hc(:,:) + J(:,:) + K(:,:) + SigCp(:,:) + + ! Compute commutator and convergence criteria + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + + ! Diagonalize Hamiltonian in AO basis + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + + ! Compute new density matrix in the AO basis + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + + ! Print results + + call print_excitation('RPA ',ispin,nS,Omega(:,ispin)) + call print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,e,c,ENuc,P,T,V,Hc,J,K,F,SigCp,Z,EcRPA) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main loop +!------------------------------------------------------------------------ + +! Compute second-order correction of the Hermitization error + + call qsGW_PT(nBas,nC,nO,nV,nR,nS,e,SigCm) + +! Compute the overlap between HF and GW orbitals + +! call overlap(nBas,cHF,c) + +! Compute natural orbitals and occupancies + +! call natural_orbital(nBas,nO,cHF,c) + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + if(BSE) stop + + endif + +! Perform BSE calculation + + if(BSE) then + + ! Singlet manifold + if(singlet_manifold) then + + ispin = 1 + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + ! Triplet manifold + if(triplet_manifold) then + + ispin = 2 + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call excitation_density(nBas,nC,nO,nR,nS,c,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + endif + +end subroutine qsGW diff --git a/src/MCQC/qsGW_AO_basis.f90.x b/src/MCQC/qsGW_AO_basis.f90.x new file mode 100644 index 0000000..dc19569 --- /dev/null +++ b/src/MCQC/qsGW_AO_basis.f90.x @@ -0,0 +1,197 @@ +subroutine qsGW(maxSCF,thresh,max_diis,COHSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ENuc,S,X,T,V,Hc,ERI_AO_basis,PHF,cHF,eHF) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF,max_diis + double precision,intent(in) :: thresh + logical,intent(in) :: COHSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ENuc + double precision,intent(in) :: PHF(nBas,nBas),cHF(nBas,nBas),eHF(nBas) + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBAs),V(nBas,nBas),Hc(nBas,nBas),X(nBas,nBas) + double precision,intent(in) :: ERI_AO_basis(nBas,nBas,nBas,nBas) + +! Local variables + + logical :: dRPA + integer :: nSCF,nBasSq,ispin,n_diis + double precision :: EcRPA,Conv + double precision,external :: trace_matrix + double precision,allocatable :: error_diis(:,:),F_diis(:,:) + double precision,allocatable :: Omega(:,:),XpY(:,:,:),rho(:,:,:,:) + double precision,allocatable :: c(:,:),cp(:,:),e(:),P(:,:) + double precision,allocatable :: F(:,:),Fp(:,:),J(:,:),K(:,:),SigmaC(:,:) + double precision,allocatable :: error(:,:),ERI_MO_basis(:,:,:,:) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Self-consistent qsGW calculation |' + write(*,*)'************************************************' + write(*,*) + +! Stuff + + nBasSq = nBas*nBas + +! Switch off exchange for G0W0 + + dRPA = .true. + +! Memory allocation + + allocate(e(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), & + J(nBas,nBas),K(nBas,nBas),SigmaC(nBas,nBas), & + ERI_MO_basis(nBas,nBas,nBas,nBas),error(nBas,nBas), & + Omega(nS,nspin),XpY(nS,nS,nspin),rho(nBas,nBas,nS,nspin), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Initialization + + nSCF = 0 + n_diis = 0 + ispin = 1 + Conv = 1d0 + P(:,:) = PHF(:,:) + e(:) = eHF(:) + c(:,:) = cHF(:,:) + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + +!------------------------------------------------------------------------ +! Main loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF <= maxSCF) + + ! Buid Coulomb matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI_AO_basis,J) + + ! Compute exchange part of the self-energy + + call exchange_matrix_AO_basis(nBas,P,ERI_AO_basis,K) + + ! AO to MO transformation of two-electron integrals + + call AOtoMO_integral_transform(nBas,c,ERI_AO_basis,ERI_MO_basis) + + ! Compute linear response + + if(.not. GW0 .or. nSCF == 0) then + + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + + endif + + ! Compute correlation part of the self-energy + + call excitation_density(nBas,nC,nO,nR,nS,c,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + if(G0W) then + + call self_energy_correlation(COHSEX,nBas,nC,nO,nV,nR,nS,eHF,Omega(:,ispin),rho(:,:,:,ispin),SigmaC) + + else + + call self_energy_correlation(COHSEX,nBas,nC,nO,nV,nR,nS,e,Omega(:,ispin),rho(:,:,:,ispin),SigmaC) + + endif + + ! Make correlation self-energy Hermitian and transform it back to AO basis + + SigmaC = 0.5d0*(SigmaC + transpose(SigmaC)) + + call MOtoAO_transform(nBas,S,c,SigmaC) + + ! Solve the quasi-particle equation + + F(:,:) = Hc(:,:) + J(:,:) + K(:,:) + SigmaC(:,:) + + ! Compute commutator and convergence criteria + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + + ! Diagonalize Hamiltonian in AO basis + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + + ! Compute new density matrix in the AO basis + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + + ! Print results + + call print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,e,c,ENuc,P,T,V,Hc,J,K,F,EcRPA) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + if(BSE) stop + + endif + +! Perform BSE calculation + + if(BSE) then + + ! Singlet manifold + if(singlet_manifold) then + + ispin = 1 + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + ! Triplet manifold + if(triplet_manifold) then + + ispin = 2 + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call excitation_density(nBas,nC,nO,nR,nS,c,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + endif + +end subroutine qsGW diff --git a/src/MCQC/qsGW_MO_basis.f90.x b/src/MCQC/qsGW_MO_basis.f90.x new file mode 100644 index 0000000..0bdace6 --- /dev/null +++ b/src/MCQC/qsGW_MO_basis.f90.x @@ -0,0 +1,203 @@ +subroutine qsGW(maxSCF,thresh,max_diis,COHSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ENuc,S,X,T,V,Hc,ERI_AO_basis,PHF,cHF,eHF) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF,max_diis + double precision,intent(in) :: thresh + logical,intent(in) :: COHSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ENuc + double precision,intent(in) :: PHF(nBas,nBas),cHF(nBas,nBas),eHF(nBas) + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBAs),V(nBas,nBas),Hc(nBas,nBas),X(nBas,nBas) + double precision,intent(in) :: ERI_AO_basis(nBas,nBas,nBas,nBas) + +! Local variables + + logical :: dRPA + integer :: nSCF,nBasSq,ispin,i,a,ia,n_diis + double precision :: EcRPA,Conv + double precision,external :: trace_matrix + double precision,allocatable :: error_diis(:,:),F_diis(:,:) + double precision,allocatable :: Omega(:,:),XpY(:,:,:),rho(:,:,:,:) + double precision,allocatable :: c(:,:),e(:),P(:,:) + double precision,allocatable :: F(:,:),R(:,:),H(:,:),SigX(:,:),SigC(:,:) + double precision,allocatable :: error(:),ERI_MO_basis(:,:,:,:) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Self-consistent qsGW calculation |' + write(*,*)'************************************************' + write(*,*) + +! Stuff + + nBasSq = nBas*nBas + +! Switch off exchange for G0W0 + + dRPA = .true. + +! Memory allocation + + allocate(e(nBas),c(nBas,nBas),P(nBas,nBas),F(nBas,nBas),R(nBas,nBas), & + H(nBas,nBas),SigX(nBas,nBas),SigC(nBas,nBas), & + ERI_MO_basis(nBas,nBas,nBas,nBas),error(nO*nV), & + Omega(nS,nspin),XpY(nS,nS,nspin),rho(nBas,nBas,nS,nspin), & + error_diis(nO*nV,max_diis),F_diis(nBasSq,max_diis)) + +! Initialization + + nSCF = 0 + ispin = 1 + n_diis = 0 + Conv = 1d0 + P(:,:) = PHF(:,:) + e(:) = eHF(:) + c(:,:) = cHF(:,:) + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + +!------------------------------------------------------------------------ +! Main loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF <= maxSCF) + + ! Buid Hartree Hamiltonian + + call Hartree_matrix_MO_basis(nBas,c,P,Hc,ERI_AO_basis,H) + + ! Compute exchange part of the self-energy + + call exchange_matrix_MO_basis(nBas,c,P,ERI_AO_basis,SigX) + + ! AO to MO transformation of two-electron integrals + + call AOtoMO_integral_transform(nBas,c,ERI_AO_basis,ERI_MO_basis) + + ! Compute linear response + + if(.not. GW0 .or. nSCF == 0) then + + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + + endif + + ! Compute correlation part of the self-energy + + call excitation_density(nBas,nC,nO,nR,nS,c,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + if(G0W) then + + call self_energy_correlation(COHSEX,nBas,nC,nO,nV,nR,nS,eHF,Omega(:,ispin),rho(:,:,:,ispin),SigC) + + else + + call self_energy_correlation(COHSEX,nBas,nC,nO,nV,nR,nS,e,Omega(:,ispin),rho(:,:,:,ispin),SigC) + + endif + + ! Make correlation self-energy Hermitian and transform it back to AO basis + + SigC = 0.5d0*(SigC + transpose(SigC)) + + ! Solve the quasi-particle equationgg + + F(:,:) = H(:,:) + SigX(:,:) + SigC(:,:) + + call matout(nBas,nBas,F) + + ! Compute commutator and convergence criteria + + ia = 0 + do i=1,nO + do a=nO+1,nBas + ia = ia + 1 + error(ia) = F(i,a) + enddo + enddo + + Conv = maxval(abs(error)) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nO*nV,nBasSq,n_diis,error_diis,F_diis,error,F) + + ! Diagonalize Hamiltonian in MO basis + + R(:,:) = F(:,:) + call diagonalize_matrix(nBas,R,e) + c = matmul(c,R) + + ! Compute new density matrix in the AO basis + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + + ! Print results + + call print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,e,c,ENuc,P,T,V,Hc,H,SigX,F,EcRPA) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + if(BSE) stop + + endif + +! Perform BSE calculation + + if(BSE) then + + ! Singlet manifold + if(singlet_manifold) then + + ispin = 1 + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + ! Triplet manifold + if(triplet_manifold) then + + ispin = 2 + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call excitation_density(nBas,nC,nO,nR,nS,c,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + endif + +end subroutine qsGW diff --git a/src/MCQC/qsGW_PT.f90 b/src/MCQC/qsGW_PT.f90 new file mode 100644 index 0000000..6b23129 --- /dev/null +++ b/src/MCQC/qsGW_PT.f90 @@ -0,0 +1,120 @@ +subroutine qsGW_PT(nBas,nC,nO,nV,nR,nS,e0,SigCm) + +! Compute the 1st-, 2nd-, 3rd- and 4th-order correction on the qsGW quasiparticle energies + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e0(nBas),SigCm(nBas,nBas) + +! Local variables + + integer :: x,y,z,t + double precision :: eps + double precision,allocatable :: e1(:),e2(:),e3(:),e4(:) + double precision,parameter :: threshold = 1d-15 + +! Allocation + + allocate(e1(nBas),e2(nBas),e3(nBas),e4(nBas)) + +! Initalization + + e1(:) = 0d0 + e2(:) = 0d0 + e3(:) = 0d0 + e4(:) = 0d0 + +! Print zeroth-order qsGW QP energies + + write(*,*) + write(*,'(A50)') '-----------------------------------------------' + write(*,'(A50)') ' 0th-order values of qsGW QP energies (eV) ' + write(*,'(A50)') '-----------------------------------------------' + call matout(nBas,1,e0(:)*HaToeV) + +! Compute 1st-order correction of qsGW QP energies + + do x=nC+1,nBas-nR + + e1(x) = SigCm(x,x) + + end do + + write(*,*) + write(*,'(A50)') '-----------------------------------------------' + write(*,'(A50)') ' 1st-order correction of qsGW QP energies (eV) ' + write(*,'(A50)') '-----------------------------------------------' + call matout(nBas,1,e1(:)*HaToeV) + +! Compute 2nd-order correction of qsGW QP energies + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + + eps = e0(x) - e0(y) + if(abs(eps) > threshold) e2(x) = e2(x) + SigCm(x,y)**2/eps + + end do + end do + + write(*,*) + write(*,'(A50)') '-----------------------------------------------' + write(*,'(A50)') ' 2nd-order correction of qsGW QP energies (eV) ' + write(*,'(A50)') '-----------------------------------------------' + call matout(nBas,1,e2(:)*HaToeV) + +! Compute 3nd-order correction of qsGW QP energies + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do z=nC+1,nBas-nR + + eps = (e0(x) - e0(y))*(e0(x) - e0(z)) + if(abs(eps) > threshold) e3(x) = e3(x) + SigCm(x,y)*SigCm(y,z)*SigCm(z,x)/eps + + end do + end do + end do + + write(*,*) + write(*,'(A50)') '-----------------------------------------------' + write(*,'(A50)') ' 3rd-order correction of qsGW QP energies (eV) ' + write(*,'(A50)') '-----------------------------------------------' + call matout(nBas,1,e3(:)*HaToeV) + +! Compute 4nd-order correction of qsGW QP energies + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do z=nC+1,nBas-nR + do t=nC+1,nBas-nR + + eps = (e0(x) - e0(y))*(e0(x) - e0(z))*(e0(x) - e0(t)) + if(abs(eps) > threshold) e4(x) = e4(x) + SigCm(x,y)*SigCm(y,z)*SigCm(z,t)*SigCm(t,x)/eps + + end do + end do + end do + end do + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + + eps = (e0(x) - e0(y))**2 + if(abs(eps) > threshold) e4(x) = e4(x) - e2(x)*SigCm(x,y)**2/eps + + end do + end do + + write(*,*) + write(*,'(A50)') '-----------------------------------------------' + write(*,'(A50)') ' 4th-order correction of qsGW QP energies (eV) ' + write(*,'(A50)') '-----------------------------------------------' + call matout(nBas,1,e4(:)*HaToeV) + +end subroutine qsGW_PT diff --git a/src/MCQC/read_F12_integrals.f90 b/src/MCQC/read_F12_integrals.f90 new file mode 100644 index 0000000..3ef6461 --- /dev/null +++ b/src/MCQC/read_F12_integrals.f90 @@ -0,0 +1,151 @@ +subroutine read_F12_integrals(nBas,S,C,F,Y) + +! Read one- and two-electron integrals from files + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: S(nBas,nBas) + +! Local variables + + logical :: debug + integer :: mu,nu,la,si + double precision :: ERI,F12,Yuk,ExpS + +! Output variables + + double precision,intent(out) :: C(nBas,nBas,nBas,nBas),F(nBas,nBas,nBas,nBas),Y(nBas,nBas,nBas,nBas) + + debug = .false. + +! Open file with integrals + + open(unit=21,file='int/ERI.dat') + open(unit=22,file='int/F12.dat') + open(unit=23,file='int/Yuk.dat') + +! Read electron repulsion integrals + + C = 0d0 + do + read(21,*,end=21) mu,nu,la,si,ERI +! <12|34> + C(mu,nu,la,si) = ERI +! <32|14> + C(la,nu,mu,si) = ERI +! <14|32> + C(mu,si,la,nu) = ERI +! <34|12> + C(la,si,mu,nu) = ERI +! <41|23> + C(si,mu,nu,la) = ERI +! <23|41> + C(nu,la,si,mu) = ERI +! <21|43> + C(nu,mu,si,la) = ERI +! <43|21> + C(si,la,nu,mu) = ERI + enddo + 21 close(unit=21) + +! Read F12 integrals + + F = 0d0 + do + read(22,*,end=22) mu,nu,la,si,F12 +! <12|34> + F(mu,nu,la,si) = F12 +! <32|14> + F(la,nu,mu,si) = F12 +! <14|32> + F(mu,si,la,nu) = F12 +! <34|12> + F(la,si,mu,nu) = F12 +! <41|23> + F(si,mu,nu,la) = F12 +! <23|41> + F(nu,la,si,mu) = F12 +! <21|43> + F(nu,mu,si,la) = F12 +! <43|21> + F(si,la,nu,mu) = F12 + enddo + 22 close(unit=22) +! Read electron repulsion integrals + + Y = 0d0 + do + read(23,*,end=23) mu,nu,la,si,Yuk +! <12|34> + Y(mu,nu,la,si) = Yuk +! <32|14> + Y(la,nu,mu,si) = Yuk +! <14|32> + Y(mu,si,la,nu) = Yuk +! <34|12> + Y(la,si,mu,nu) = Yuk +! <41|23> + Y(si,mu,nu,la) = Yuk +! <23|41> + Y(nu,la,si,mu) = Yuk +! <21|43> + Y(nu,mu,si,la) = Yuk +! <43|21> + Y(si,la,nu,mu) = Yuk + enddo + 23 close(unit=23) + + +! Print results + if(debug) then + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Electron repulsion integrals' + write(*,'(A28)') '----------------------' + do la=1,nBas + do si=1,nBas + call matout(nBas,nBas,C(1,1,la,si)) + enddo + enddo + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'F12 integrals' + write(*,'(A28)') '----------------------' + do la=1,nBas + do si=1,nBas + call matout(nBas,nBas,F(1,1,la,si)) + enddo + enddo + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Yukawa integrals' + write(*,'(A28)') '----------------------' + do la=1,nBas + do si=1,nBas + call matout(nBas,nBas,Y(1,1,la,si)) + enddo + enddo + write(*,*) + endif + +! Read exponent of Slater geminal + open(unit=4,file='input/geminal') + read(4,*) ExpS + close(unit=4) + +! Transform two-electron integrals + + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + F(mu,nu,la,si) = (S(mu,la)*S(nu,si) - F(mu,nu,la,si))/ExpS + Y(mu,nu,la,si) = (C(mu,nu,la,si) - Y(mu,nu,la,si))/ExpS + enddo + enddo + enddo + enddo + +end subroutine read_F12_integrals diff --git a/src/MCQC/read_MOs.f90 b/src/MCQC/read_MOs.f90 new file mode 100644 index 0000000..d775fb9 --- /dev/null +++ b/src/MCQC/read_MOs.f90 @@ -0,0 +1,58 @@ +subroutine read_MOs(nBas,C,e,EJ) + +! Read normalization factor and MOs (coefficients and eigenvalues) + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + +! Local variables + + integer :: i,j + +! Output variables + + double precision,intent(out) :: EJ + double precision,intent(out) :: C(nBas,nBas),e(nBas) + +!------------------------------------------------------------------------ +! Primary basis set information +!------------------------------------------------------------------------ + +! Open file with basis set specification + + open(unit=3,file='input/MOs') + +! Read MO information + + read(3,*) EJ + + do i=1,nBas + read(3,*) (C(i,j),j=1,nBas) + enddo + + do i=1,nBas + read(3,*) e(i) + enddo + +! Print results + + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'MO coefficients' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,C) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'MO energies' + write(*,'(A28)') '----------------------' + call matout(nBas,1,e) + write(*,*) + +! Close file + + close(unit=3) + +end subroutine read_MOs diff --git a/src/MCQC/read_auxiliary_basis.f90 b/src/MCQC/read_auxiliary_basis.f90 new file mode 100644 index 0000000..cf4f6ed --- /dev/null +++ b/src/MCQC/read_auxiliary_basis.f90 @@ -0,0 +1,176 @@ +subroutine read_auxiliary_basis(NAtoms,XYZAtoms,nShell,CenterShell, & + TotAngMomShell,KShell,DShell,ExpShell) + +! Read auxiliary basis set information + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: NAtoms + double precision,intent(in) :: XYZAtoms(NAtoms,3) + +! Local variables + + integer :: nShAt,iAt + integer :: i,j,k + character :: shelltype + +! Output variables + + integer,intent(out) :: nShell + double precision,intent(out) :: CenterShell(maxShell,3) + integer,intent(out) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(out) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +!------------------------------------------------------------------------ +! Primary basis set information +!------------------------------------------------------------------------ + +! Open file with basis set specification + + open(unit=2,file='input/basis') + +! Read basis information + + write(*,'(A28)') 'Gaussian basis set' + write(*,'(A28)') '------------------' + + nShell = 0 + do i=1,NAtoms + read(2,*) iAt,nShAt + write(*,'(A28,1X,I16)') 'Atom n. ',iAt + write(*,'(A28,1X,I16)') 'number of shells ',nShAt + write(*,'(A28)') '------------------' + +! Basis function centers + + do j=1,nShAt + nShell = nShell + 1 + do k=1,3 + CenterShell(nShell,k) = XYZAtoms(iAt,k) + enddo + +! Shell type and contraction degree + + read(2,*) shelltype,KShell(nShell) + if(shelltype == "S") then + TotAngMomShell(nShell) = 0 + write(*,'(A28,1X,I16)') 's-type shell with K = ',KShell(nShell) + elseif(shelltype == "P") then + TotAngMomShell(nShell) = 1 + write(*,'(A28,1X,I16)') 'p-type shell with K = ',KShell(nShell) + elseif(shelltype == "D") then + TotAngMomShell(nShell) = 2 + write(*,'(A28,1X,I16)') 'd-type shell with K = ',KShell(nShell) + elseif(shelltype == "F") then + TotAngMomShell(nShell) = 3 + write(*,'(A28,1X,I16)') 'f-type shell with K = ',KShell(nShell) + elseif(shelltype == "G") then + TotAngMomShell(nShell) = 4 + write(*,'(A28,1X,I16)') 'g-type shell with K = ',KShell(nShell) + elseif(shelltype == "H") then + TotAngMomShell(nShell) = 5 + write(*,'(A28,1X,I16)') 'h-type shell with K = ',KShell(nShell) + elseif(shelltype == "I") then + TotAngMomShell(nShell) = 6 + write(*,'(A28,1X,I16)') 'i-type shell with K = ',KShell(nShell) + endif + +! Read exponents and contraction coefficients + + write(*,'(A28,1X,A16,A16)') '','Exponents','Contraction' + do k=1,Kshell(nShell) + read(2,*) ExpShell(nShell,k),DShell(nShell,k) + write(*,'(A28,1X,F16.10,F16.10)') '',ExpShell(nShell,k),DShell(nShell,k) + enddo + enddo + write(*,'(A28)') '------------------' + enddo + +! Total number of shells + + write(*,'(A28,1X,I16)') 'Number of shells in OBS',nShell + write(*,'(A28)') '------------------' + write(*,*) + +! Close file with basis set specification + + close(unit=2) + +!------------------------------------------------------------------------ +! Auxiliary basis set information +!------------------------------------------------------------------------ + +! Open file with auxilairy basis specification + + open(unit=3,file='input/auxbasis') + +! Read basis information + + write(*,'(A28)') 'Auxiliary basis set' + write(*,'(A28)') '-------------------' + + do i=1,NAtoms + read(3,*) iAt,nShAt + write(*,'(A28,1X,I16)') 'Atom n. ',iAt + write(*,'(A28,1X,I16)') 'number of shells ',nShAt + write(*,'(A28)') '------------------' + +! Basis function centers + + do j=1,nShAt + nShell = nShell + 1 + do k=1,3 + CenterShell(nShell,k) = XYZAtoms(iAt,k) + enddo + +! Shell type and contraction degree + + read(3,*) shelltype,KShell(nShell) + if(shelltype == "S") then + TotAngMomShell(nShell) = 0 + write(*,'(A28,1X,I16)') 's-type shell with K = ',KShell(nShell) + elseif(shelltype == "P") then + TotAngMomShell(nShell) = 1 + write(*,'(A28,1X,I16)') 'p-type shell with K = ',KShell(nShell) + elseif(shelltype == "D") then + TotAngMomShell(nShell) = 2 + write(*,'(A28,1X,I16)') 'd-type shell with K = ',KShell(nShell) + elseif(shelltype == "F") then + TotAngMomShell(nShell) = 3 + write(*,'(A28,1X,I16)') 'f-type shell with K = ',KShell(nShell) + elseif(shelltype == "G") then + TotAngMomShell(nShell) = 4 + write(*,'(A28,1X,I16)') 'g-type shell with K = ',KShell(nShell) + elseif(shelltype == "H") then + TotAngMomShell(nShell) = 5 + write(*,'(A28,1X,I16)') 'h-type shell with K = ',KShell(nShell) + elseif(shelltype == "I") then + TotAngMomShell(nShell) = 6 + write(*,'(A28,1X,I16)') 'i-type shell with K = ',KShell(nShell) + endif + +! Read exponents and contraction coefficients + + write(*,'(A28,1X,A16,A16)') '','Exponents','Contraction' + do k=1,Kshell(nShell) + read(3,*) ExpShell(nShell,k),DShell(nShell,k) + write(*,'(A28,1X,F16.10,F16.10)') '',ExpShell(nShell,k),DShell(nShell,k) + enddo + enddo + write(*,'(A28)') '------------------' + enddo + +! Total number of shells + + write(*,'(A28,1X,I16)') 'Number of shells in ABS',nShell + write(*,'(A28)') '------------------' + write(*,*) + +! Close file with basis set specification + + close(unit=3) + +end subroutine read_auxiliary_basis diff --git a/src/MCQC/read_basis.f90 b/src/MCQC/read_basis.f90 new file mode 100644 index 0000000..cc82700 --- /dev/null +++ b/src/MCQC/read_basis.f90 @@ -0,0 +1,128 @@ +subroutine read_basis(nAt,rAt,nBas,nC,nO,nV,nR,nS, & + nShell,atot,CenterShell,TotAngMomShell,KShell,DShell,ExpShell) + +! Read basis set information + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nAt,nC,nO,nR,atot(maxShell) + double precision,intent(in) :: rAt(nAt,3) + +! Local variables + + integer :: nShAt,iAt,iShell + integer :: i,j,k + character :: shelltype + +! Output variables + + integer,intent(out) :: nShell,nBas,nV,nS + double precision,intent(out) :: CenterShell(maxShell,3) + integer,intent(out) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(out) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +!------------------------------------------------------------------------ +! Primary basis set information +!------------------------------------------------------------------------ + +! Open file with basis set specification + + open(unit=2,file='input/basis') + +! Read basis information + + write(*,'(A28)') 'Gaussian basis set' + write(*,'(A28)') '------------------' + + nShell = 0 + do i=1,nAt + read(2,*) iAt,nShAt + write(*,'(A28,1X,I16)') 'Atom n. ',iAt + write(*,'(A28,1X,I16)') 'number of shells ',nShAt + write(*,'(A28)') '------------------' + +! Basis function centers + + do j=1,nShAt + nShell = nShell + 1 + do k=1,3 + CenterShell(nShell,k) = rAt(iAt,k) + enddo + +! Shell type and contraction degree + + read(2,*) shelltype,KShell(nShell) + if(shelltype == "S") then + TotAngMomShell(nShell) = 0 + write(*,'(A28,1X,I16)') 's-type shell with K = ',KShell(nShell) + elseif(shelltype == "P") then + TotAngMomShell(nShell) = 1 + write(*,'(A28,1X,I16)') 'p-type shell with K = ',KShell(nShell) + elseif(shelltype == "D") then + TotAngMomShell(nShell) = 2 + write(*,'(A28,1X,I16)') 'd-type shell with K = ',KShell(nShell) + elseif(shelltype == "F") then + TotAngMomShell(nShell) = 3 + write(*,'(A28,1X,I16)') 'f-type shell with K = ',KShell(nShell) + elseif(shelltype == "G") then + TotAngMomShell(nShell) = 4 + write(*,'(A28,1X,I16)') 'g-type shell with K = ',KShell(nShell) + elseif(shelltype == "H") then + TotAngMomShell(nShell) = 5 + write(*,'(A28,1X,I16)') 'h-type shell with K = ',KShell(nShell) + elseif(shelltype == "I") then + TotAngMomShell(nShell) = 6 + write(*,'(A28,1X,I16)') 'i-type shell with K = ',KShell(nShell) + endif + +! Read exponents and contraction coefficients + + write(*,'(A28,1X,A16,A16)') '','Exponents','Contraction' + do k=1,Kshell(nShell) + read(2,*) ExpShell(nShell,k),DShell(nShell,k) + write(*,'(A28,1X,F16.10,F16.10)') '',ExpShell(nShell,k),DShell(nShell,k) + enddo + enddo + write(*,'(A28)') '------------------' + enddo + +! Total number of shells + + write(*,'(A28,1X,I16)') 'Number of shells in OBS',nShell + write(*,'(A28)') '------------------' + write(*,*) + +! Close file with basis set specification + + close(unit=2) + +! Calculate number of basis functions + + nBas = 0 + do iShell=1,nShell + nBas = nBas + (atot(iShell)*atot(iShell) + 3*atot(iShell) + 2)/2 + enddo + + write(*,'(A28)') '------------------' + write(*,'(A28,1X,I16)') 'Number of basis functions',NBas + write(*,'(A28)') '------------------' + write(*,*) + +! Number of virtual orbitals + + nV = nBas - nO + + if(nR > nV) then + write(*,*) 'Number of Rydberg orbitals greater than number of virtual orbitals!' + stop + endif + +! Number of single excitation + + nS = (nO - nC)*(nV - nR) + + +end subroutine read_basis diff --git a/src/MCQC/read_geometry.f90 b/src/MCQC/read_geometry.f90 new file mode 100644 index 0000000..8f0fc56 --- /dev/null +++ b/src/MCQC/read_geometry.f90 @@ -0,0 +1,58 @@ +subroutine read_geometry(nAt,ZNuc,rA,ENuc) + +! Read molecular geometry + + implicit none + +! Ouput variables + integer,intent(in) :: nAt + +! Local variables + integer :: i,j + double precision :: RAB + +! Ouput variables + double precision,intent(out) :: ZNuc(NAt),rA(nAt,3),ENuc + + +! Open file with geometry specification + open(unit=1,file='input/molecule') + +! Read number of atoms + read(1,*) + read(1,*) + read(1,*) + + do i=1,nAt + read(1,*) ZNuc(i),rA(i,1),rA(i,2),rA(i,3) + enddo + +! Compute nuclear repulsion energy + ENuc = 0 + + do i=1,nAt-1 + do j=i+1,nAt + RAB = (rA(i,1)-rA(j,1))**2 + (rA(i,2)-rA(j,2))**2 + (rA(i,3)-rA(j,3))**2 + ENuc = ENuc + ZNuc(i)*ZNuc(j)/sqrt(RAB) + enddo + enddo + +! Close file with geometry specification + close(unit=1) + +! Print geometry + write(*,'(A28)') '------------------' + write(*,'(A28)') 'Molecular geometry' + write(*,'(A28)') '------------------' + do i=1,NAt + write(*,'(A28,1X,I16)') 'Atom n. ',i + write(*,'(A28,1X,F16.10)') 'Z = ',ZNuc(i) + write(*,'(A28,1X,F16.10,F16.10,F16.10)') 'Atom coordinates:',(rA(i,j),j=1,3) + enddo + write(*,*) + write(*,'(A28)') '------------------' + write(*,'(A28,1X,F16.10)') 'Nuclear repulsion energy = ',ENuc + write(*,'(A28)') '------------------' + write(*,*) + +end subroutine read_geometry diff --git a/src/MCQC/read_integrals.f90 b/src/MCQC/read_integrals.f90 new file mode 100644 index 0000000..0226865 --- /dev/null +++ b/src/MCQC/read_integrals.f90 @@ -0,0 +1,120 @@ +subroutine read_integrals(nBas,S,T,V,Hc,G) + +! Read one- and two-electron integrals from files + + implicit none + +! Input variables + + integer,intent(in) :: nBas + +! Local variables + + logical :: debug + integer :: mu,nu,la,si + double precision :: Ov,Kin,Nuc,ERI + double precision :: scale + +! Output variables + + double precision,intent(out) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),G(nBas,nBas,nBas,nBas) + +! Open file with integrals + + debug = .false. + + scale = 1d0 + + open(unit=8 ,file='int/Ov.dat') + open(unit=9 ,file='int/Kin.dat') + open(unit=10,file='int/Nuc.dat') + open(unit=11,file='int/ERI.dat') + +! Read overlap integrals + + S = 0d0 + do + read(8,*,end=8) mu,nu,Ov + S(mu,nu) = Ov + enddo + 8 close(unit=8) + +! Read kinetic integrals + + T = 0d0 + do + read(9,*,end=9) mu,nu,Kin + T(mu,nu) = Kin/scale**2 + enddo + 9 close(unit=9) + +! Read nuclear integrals + + V = 0d0 + do + read(10,*,end=10) mu,nu,Nuc + V(mu,nu) = Nuc + enddo + 10 close(unit=10) + +! Define core Hamiltonian + + Hc = T + V + +! Read nuclear integrals + + G = 0d0 + do + read(11,*,end=11) mu,la,nu,si,ERI +! read(11,*,end=11) ERI,mu,nu,la,si + + ERI = ERI/scale +! <12|34> + G(mu,nu,la,si) = ERI +! <32|14> + G(la,nu,mu,si) = ERI +! <14|32> + G(mu,si,la,nu) = ERI +! <34|12> + G(la,si,mu,nu) = ERI +! <41|23> + G(si,mu,nu,la) = ERI +! <23|41> + G(nu,la,si,mu) = ERI +! <21|43> + G(nu,mu,si,la) = ERI +! <43|21> + G(si,la,nu,mu) = ERI + enddo + 11 close(unit=11) + + +! Print results + if(debug) then + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Overlap integrals' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,S) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Kinetic integrals' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,T) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Nuclear integrals' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,V) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Electron repulsion integrals' + write(*,'(A28)') '----------------------' + do la=1,nBas + do si=1,nBas + call matout(nBas,nBas,G(1,1,la,si)) + enddo + enddo + write(*,*) + endif + +end subroutine read_integrals diff --git a/src/MCQC/read_methods.f90 b/src/MCQC/read_methods.f90 new file mode 100644 index 0000000..6db5635 --- /dev/null +++ b/src/MCQC/read_methods.f90 @@ -0,0 +1,97 @@ +subroutine read_methods(doHF,doMOM, & + doMP2,doMP3, & + doCIS,doTDHF,doADC, & + doGF2,doGF3, & + doG0W0,doevGW,doqsGW, & + doMCMP2) + +! Read desired methods + + implicit none + +! Input variables + + logical,intent(out) :: doHF,doMOM + logical,intent(out) :: doMP2,doMP3 + logical,intent(out) :: doCIS,doTDHF,doADC + logical,intent(out) :: doGF2,doGF3 + logical,intent(out) :: doG0W0,doevGW,doqsGW + logical,intent(out) :: doMCMP2 + +! Local variables + + character(len=1) :: answer1,answer2,answer3 + +! Open file with method specification + + open(unit=1,file='input/methods') + +! Set all the booleans to false + + doHF = .false. + doMOM = .false. + + doMP2 = .false. + doMP3 = .false. + + doCIS = .false. + doTDHF = .false. + doADC = .false. + + doGF2 = .false. + doGF3 = .false. + + doG0W0 = .false. + doevGW = .false. + doqsGW = .false. + + doMCMP2 = .false. + +! Read mean-field methods + + read(1,*) + read(1,*) answer1,answer2 + if(answer1 == 'T') doHF = .true. + if(answer2 == 'T') doMOM = .true. + +! Read MPn methods + + read(1,*) + read(1,*) answer1,answer2 + if(answer1 == 'T') doMP2 = .true. + if(answer2 == 'T') doMP3 = .true. + +! Read excited state methods + + read(1,*) + read(1,*) answer1,answer2,answer3 + if(answer1 == 'T') doCIS = .true. + if(answer2 == 'T') doTDHF = .true. + if(answer3 == 'T') doADC = .true. + +! Read Green function methods + + read(1,*) + read(1,*) answer1,answer2 + if(answer1 == 'T') doGF2 = .true. + if(answer2 == 'T') doGF3 = .true. + +! Read GW methods + + read(1,*) + read(1,*) answer1,answer2,answer3 + if(answer1 == 'T') doG0W0 = .true. + if(answer2 == 'T') doevGW = .true. + if(answer3 == 'T') doqsGW = .true. + +! Read stochastic methods + + read(1,*) + read(1,*) answer1 + if(answer1 == 'T') doMCMP2 = .true. + +! Close file with geometry specification + + close(unit=1) + +end subroutine read_methods diff --git a/src/MCQC/read_molecule.f90 b/src/MCQC/read_molecule.f90 new file mode 100644 index 0000000..b7f14b9 --- /dev/null +++ b/src/MCQC/read_molecule.f90 @@ -0,0 +1,67 @@ +subroutine read_molecule(nAt,nEl,nC,nO,nR) + +! Read number of atoms nAt, +! number of electrons nEl, +! number of core electrons nC, +! number of Rydberg orbitals nR + + implicit none + +! Input variables + integer,intent(out) :: nAt,nEl,nC,nO,nR + +! Open file with geometry specification + + open(unit=1,file='input/molecule') + +! Read number of atoms and number of electrons + + read(1,*) + read(1,*) nAt,nEl,nC,nR + +! Number of occupied orbitals + + if(mod(nEl,2) /= 0) then + write(*,*) 'closed-shell system required!' +! stop + endif + nO = nEl/2 + +! Number of core orbitals + + if(mod(nC,2) /= 0) then + write(*,*) 'Number of core electrons not even!' + stop + endif + nC = nC/2 + + if(nC > nO) then + write(*,*) 'Number of core electrons greater than number of electrons!' + stop + endif + +! Print results + + write(*,'(A28)') '----------------------' + write(*,'(A28,1X,I16)') 'Number of atoms',nAt + write(*,'(A28)') '----------------------' + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28,1X,I16)') 'Number of electrons',nEl + write(*,'(A28)') '----------------------' + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28,1X,I16)') 'Number of core electrons',2*nC + write(*,'(A28)') '----------------------' + write(*,*) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28,1X,I16)') 'Number of Rydberg orbitals',nR + write(*,'(A28)') '----------------------' + write(*,*) + +! Close file with geometry specification + + close(unit=1) + +end subroutine read_molecule diff --git a/src/MCQC/read_options.f90 b/src/MCQC/read_options.f90 new file mode 100644 index 0000000..0096914 --- /dev/null +++ b/src/MCQC/read_options.f90 @@ -0,0 +1,151 @@ +subroutine read_options(maxSCF_HF,thresh_HF,DIIS_HF,n_diis_HF,guess_type,ortho_type, & + singlet_manifold,triplet_manifold, & + maxSCF_GF,thresh_GF,DIIS_GF,n_diis_GF,renormalization, & + maxSCF_GW,thresh_GW,DIIS_GW,n_diis_GW,COHSEX,SOSEX,BSE,TDA,G0W,GW0,linearize, & + nMC,nEq,nWalk,dt,nPrint,iSeed,doDrift) + +! Read desired methods + + implicit none + +! Input variables + + integer,intent(out) :: maxSCF_HF + double precision,intent(out) :: thresh_HF + logical,intent(out) :: DIIS_HF + integer,intent(out) :: n_diis_HF + integer,intent(out) :: guess_type + integer,intent(out) :: ortho_type + + logical,intent(out) :: singlet_manifold + logical,intent(out) :: triplet_manifold + + integer,intent(out) :: maxSCF_GF + double precision,intent(out) :: thresh_GF + logical,intent(out) :: DIIS_GF + integer,intent(out) :: n_diis_GF + integer,intent(out) :: renormalization + + integer,intent(out) :: maxSCF_GW + double precision,intent(out) :: thresh_GW + logical,intent(out) :: DIIS_GW + integer,intent(out) :: n_diis_GW + logical,intent(out) :: COHSEX + logical,intent(out) :: SOSEX + logical,intent(out) :: BSE + logical,intent(out) :: TDA + logical,intent(out) :: G0W + logical,intent(out) :: GW0 + logical,intent(out) :: linearize + + integer,intent(out) :: nMC + integer,intent(out) :: nEq + integer,intent(out) :: nWalk + double precision,intent(out) :: dt + integer,intent(out) :: nPrint + integer,intent(out) :: iSeed + logical,intent(out) :: doDrift + +! Local variables + + character(len=1) :: answer1,answer2,answer3,answer4,answer5,answer6,answer7,answer8 + +! Open file with method specification + + open(unit=1,file='input/options') + +! Read HF options + + maxSCF_HF = 64 + thresh_HF = 1d-6 + DIIS_HF = .false. + n_diis_HF = 5 + guess_type = 1 + ortho_type = 1 + + read(1,*) + read(1,*) maxSCF_HF,thresh_HF,answer1,n_diis_HF,guess_type,ortho_type + + if(answer1 == 'T') DIIS_HF = .true. + + if(.not.DIIS_HF) n_diis_HF = 1 + +! Read MPn options + + read(1,*) + read(1,*) + +! Read excited state options + + singlet_manifold = .false. + triplet_manifold = .false. + + read(1,*) + read(1,*) answer1,answer2 + + if(answer1 == 'T') singlet_manifold = .true. + if(answer2 == 'T') triplet_manifold = .true. + +! Read Green function options + + maxSCF_GF = 64 + thresh_GF = 1d-5 + DIIS_GF = .false. + n_diis_GF = 5 + renormalization = 0 + + read(1,*) + read(1,*) maxSCF_GF,thresh_GW,answer1,n_diis_GF,renormalization + + if(answer1 == 'T') DIIS_GF = .true. + if(.not.DIIS_GF) n_diis_GF = 1 + +! Read GW options + + maxSCF_GW = 64 + thresh_GW = 1d-5 + DIIS_GW = .false. + n_diis_GW = 5 + COHSEX = .false. + SOSEX = .false. + BSE = .false. + TDA = .false. + G0W = .false. + GW0 = .false. + linearize = .false. + + read(1,*) + read(1,*) maxSCF_GW,thresh_GW,answer1,n_diis_GW,answer2, & + answer3,answer4,answer5,answer6,answer7,answer8 + + if(answer1 == 'T') DIIS_GW = .true. + if(answer2 == 'T') COHSEX = .true. + if(answer3 == 'T') SOSEX = .true. + if(answer4 == 'T') BSE = .true. + if(answer5 == 'T') TDA = .true. + if(answer6 == 'T') G0W = .true. + if(answer7 == 'T') GW0 = .true. + if(answer8 == 'T') linearize = .true. + if(.not.DIIS_GW) n_diis_GW = 1 + +! Read options for MC-MP2: Monte Carlo steps, number of equilibration steps, number of walkers, +! Monte Carlo time step, frequency of output results, and seed for random number generator + + nMC = 100000 + nEq = 10000 + nWalk = 10 + dt = 0.3d0 + nPrint = 1000 + iSeed = 0 + doDrift = .false. + + read(1,*) + read(1,*) nMC,nEq,nWalk,dt,nPrint,iSeed,answer1 + + if(answer1 == 'T') doDrift = .true. + +! Close file with options + + close(unit=1) + +end subroutine read_options diff --git a/src/MCQC/renormalization_factor.f90 b/src/MCQC/renormalization_factor.f90 new file mode 100644 index 0000000..b4fff31 --- /dev/null +++ b/src/MCQC/renormalization_factor.f90 @@ -0,0 +1,112 @@ +subroutine renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,e,Omega,rho,rhox,Z) + +! Compute renormalization factor for GW + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: SOSEX + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),Omega(nS),rho(nBas,nBas,nS),rhox(nBas,nBas,nS) + +! Local variables + + integer :: i,j,a,b,x,jb + double precision :: eps + double precision,allocatable :: SigC(:),dSigC(:),d2SigC(:) + double precision,external :: Z_dcgw + +! Output variables + + double precision,intent(out) :: Z(nBas) + +! Allocate + + allocate(SigC(nBas),dSigC(nBas),d2SigC(nBas)) + + SigC(:) = 0d0 + dSigC(:) = 0d0 + d2SigC(:) = 0d0 + +! Occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) +! Z(x) = Z(x) + 2d0*Z_dcgw(eps,rho(x,i,jb)) +! SigC(x) = SigC(x) + 2d0*rho(x,i,jb)**2/eps + dSigC(x) = dSigC(x) - 2d0*rho(x,i,jb)**2/eps**2 +! d2SigC(x) = d2SigC(x) + 4d0*rho(x,i,jb)**2/eps**3 + enddo + enddo + enddo + enddo + +! Virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) +! Z(x) = Z(x) + 2d0*Z_dcgw(eps,rho(x,a,jb)) +! SigC(x) = SigC(x) + 2d0*rho(x,a,jb)**2/eps + dSigC(x) = dSigC(x) - 2d0*rho(x,a,jb)**2/eps**2 +! d2SigC(x) = d2SigC(x) + 4d0*rho(x,a,jb)**2/eps**3 + enddo + enddo + enddo + enddo + + ! SOSEX correction + + if(SOSEX) then + + ! Occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) + dSigC(x) = dSigC(x) - (rho(x,i,jb)/eps)*(rhox(x,i,jb)/eps) + enddo + enddo + enddo + enddo + + ! Virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) + dSigC(x) = dSigC(x) - (rho(x,a,jb)/eps)*(rhox(x,a,jb)/eps) + enddo + enddo + enddo + enddo + + endif + +! Compute renormalization factor from derivative of SigC + + Z(:) = 1d0/(1d0-dSigC(:)) + +! Z(:) = 1d0 - dSigC(:) + sqrt( (1d0 - dSigC(:))**2 - 2d0*SigC(:)*d2SigC(:) ) +! Z(:) = Z(:)/(SigC(:)*d2SigC(:)) + +end subroutine renormalization_factor diff --git a/src/MCQC/rij.f90 b/src/MCQC/rij.f90 new file mode 100644 index 0000000..ff9b6f8 --- /dev/null +++ b/src/MCQC/rij.f90 @@ -0,0 +1,24 @@ +subroutine rij(nWalk,r,r12) + +! Compute the interelectronic distances + + implicit none + +! Input variables + + integer,intent(in) :: nWalk + double precision,intent(in) :: r(nWalk,1:2,1:3) + +! Output variables + + double precision,intent(out) :: r12(nWalk) + +! Compute + + r12(1:nWalk) = (r(1:nWalk,1,1)-r(1:nWalk,2,1))**2 & + + (r(1:nWalk,1,2)-r(1:nWalk,2,2))**2 & + + (r(1:nWalk,1,3)-r(1:nWalk,2,3))**2 + + r12 = sqrt(r12) + +end subroutine rij diff --git a/src/MCQC/self_energy_correlation.f90 b/src/MCQC/self_energy_correlation.f90 new file mode 100644 index 0000000..07f6436 --- /dev/null +++ b/src/MCQC/self_energy_correlation.f90 @@ -0,0 +1,143 @@ +subroutine self_energy_correlation(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,e,Omega,rho,rhox,SigC) + +! Compute correlation part of the self-energy + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: COHSEX,SOSEX + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),Omega(nS),rho(nBas,nBas,nS),rhox(nBas,nBas,nS) + +! Local variables + + integer :: i,j,a,b,x,y,jb + double precision :: eps,eta + +! Output variables + + double precision,intent(out) :: SigC(nBas,nBas) + +! Initialize + + SigC = 0d0 + +! Infinitesimal + + eta = 0.001d0 + +! COHSEX static approximation + + if(COHSEX) then + + ! COHSEX: occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + SigC(x,y) = SigC(x,y) + 4d0*rho(x,i,jb)*rho(y,i,jb)/Omega(jb) + enddo + enddo + enddo + enddo + enddo + + ! COHSEX: virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + SigC(x,y) = SigC(x,y) - 2d0*rho(x,a,jb)*rho(y,a,jb)/Omega(jb) + enddo + enddo + enddo + enddo + enddo + + else + + ! Occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) + SigC(x,y) = SigC(x,y) + 2d0*rho(x,i,jb)*rho(y,i,jb)*eps/(eps**2 + eta**2) + enddo + enddo + enddo + enddo + enddo + + ! Virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) + SigC(x,y) = SigC(x,y) + 2d0*rho(x,a,jb)*rho(y,a,jb)*eps/(eps**2 + eta**2) + enddo + enddo + enddo + enddo + enddo + + if(SOSEX) then + + ! SOSEX: occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) + SigC(x,y) = SigC(x,y) - rho(x,i,jb)*rhox(y,i,jb)/eps + enddo + enddo + enddo + enddo + enddo + + ! SOSEX: virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) + SigC(x,y) = SigC(x,y) - rho(x,a,jb)*rhox(y,a,jb)/eps + enddo + enddo + enddo + enddo + enddo + + endif + + endif + +end subroutine self_energy_correlation diff --git a/src/MCQC/self_energy_correlation_diag.f90 b/src/MCQC/self_energy_correlation_diag.f90 new file mode 100644 index 0000000..9116561 --- /dev/null +++ b/src/MCQC/self_energy_correlation_diag.f90 @@ -0,0 +1,137 @@ +subroutine self_energy_correlation_diag(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,e,Omega,rho,rhox,SigC) + +! Compute diagonal of the correlation part of the self-energy + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: COHSEX,SOSEX + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),Omega(nS),rho(nBas,nBas,nS),rhox(nBas,nBas,nS) + +! Local variables + + integer :: i,j,a,b,x,jb + double precision :: eps,eta + double precision,external :: SigC_dcgw + +! Output variables + + double precision,intent(out) :: SigC(nBas) + +! Initialize + + SigC = 0d0 + +! Infinitesimal + + eta = 0d0 +! eta = 0.001d0 + +! COHSEX static approximation + + if(COHSEX) then + + ! COHSEX: occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + SigC(x) = SigC(x) + 4d0*rho(x,i,jb)**2/Omega(jb) + enddo + enddo + enddo + enddo + + ! COHSEX: virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + SigC(x) = SigC(x) - 2d0*rho(x,a,jb)**2/Omega(jb) + enddo + enddo + enddo + enddo + + else + + ! Occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) +! SigC(x) = SigC(x) + 4d0*rho(x,i,jb)**2/(eps + eps*sqrt(1d0 + rho(x,i,jb)**2/eps**2)) + SigC(x) = SigC(x) + 2d0*rho(x,i,jb)**2*eps/(eps**2 + eta**2) +! SigC(x) = SigC(x) + 2d0*SigC_dcgw(eps,rho(x,i,jb)) + enddo + enddo + enddo + enddo + + ! Virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) +! SigC(x) = SigC(x) + 4d0*rho(x,a,jb)**2/(eps + eps*sqrt(1d0 + 4d0*rho(x,a,jb)**2/eps**2)) + SigC(x) = SigC(x) + 2d0*rho(x,a,jb)**2*eps/(eps**2 + eta**2) +! SigC(x) = SigC(x) + 2d0*SigC_dcgw(eps,rho(x,a,jb)) + enddo + enddo + enddo + enddo + + if(SOSEX) then + + ! SOSEX: occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) + SigC(x) = SigC(x) - rho(x,i,jb)*rhox(x,i,jb)/eps + enddo + enddo + enddo + enddo + + ! SOSEX: virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) + SigC(x) = SigC(x) - rho(x,a,jb)*rhox(x,a,jb)/eps + enddo + enddo + enddo + enddo + + endif + + endif + +end subroutine self_energy_correlation_diag diff --git a/src/MCQC/self_energy_exchange.f90 b/src/MCQC/self_energy_exchange.f90 new file mode 100644 index 0000000..26db034 --- /dev/null +++ b/src/MCQC/self_energy_exchange.f90 @@ -0,0 +1,25 @@ +subroutine self_energy_exchange(nBas,c,P,G,SigmaX) + +! Compute exchange part of the self-energy + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas),P(nBas,nBas),G(nBas,nBas,nBas,nBas) + +! Output variables + + double precision,intent(out) :: SigmaX(nBas,nBas) + +! Compute exchange part of the self-energy in the AO basis + + call exchange_matrix_AO_basis(nBas,P,G,SigmaX) + +! Compute exchange part of the self-energy in the MO basis + + SigmaX = matmul(transpose(c),matmul(SigmaX,c)) + +end subroutine self_energy_exchange diff --git a/src/MCQC/transition_probability.f90 b/src/MCQC/transition_probability.f90 new file mode 100644 index 0000000..76da1d5 --- /dev/null +++ b/src/MCQC/transition_probability.f90 @@ -0,0 +1,41 @@ +subroutine transition_probability(nWalk,dt,D,r,rp,F,Fp,T,Tp) + +! Compute transition probability + + implicit none + +! Input variables + + integer,intent(in) :: nWalk + double precision,intent(in) :: dt,D + double precision,intent(in) :: r(nWalk,1:2,1:3), F(nWalk,1:2,1:3) + double precision,intent(in) :: rp(nWalk,1:2,1:3),Fp(nWalk,1:2,1:3) + +! Local variables + + integer :: iW,iEl,ixyz + +! Output variables + + double precision,intent(out) :: T(nWalk),Tp(nWalk) + +! Initialize + + T = 0d0 + Tp = 0d0 + +! Compute + + do iW=1,nWalk + do iEl=1,2 + do ixyz=1,3 + T(iW) = T(iW) + (rp(iW,iEl,ixyz) - r(iW,iEl,ixyz) - D*dt*F(iW,iEl,ixyz))**2 + Tp(iW) = Tp(iW) + (r(iW,iEl,ixyz) - rp(iW,iEl,ixyz) - D*dt*Fp(iW,iEl,ixyz))**2 + enddo + enddo + enddo + + T(:) = exp(-0.25d0*T(:)/(D*dt)) + Tp(:) = exp(-0.25d0*Tp(:)/(D*dt)) + +end subroutine transition_probability diff --git a/src/MCQC/utils.f90 b/src/MCQC/utils.f90 new file mode 100644 index 0000000..8669f34 --- /dev/null +++ b/src/MCQC/utils.f90 @@ -0,0 +1,339 @@ +!------------------------------------------------------------------------ +function Kronecker_delta(i,j) result(delta) + +! Kronecker Delta + + implicit none + +! Input variables + + integer,intent(in) :: i,j + +! Output variables + + double precision :: delta + + if(i == j) then + delta = 1d0 + else + delta = 0d0 + endif + +end function Kronecker_delta + +!------------------------------------------------------------------------ +subroutine matout(m,n,A) + +! Print the MxN array A + + implicit none + + integer,parameter :: ncol = 5 + double precision,parameter :: small = 1d-10 + integer,intent(in) :: m,n + double precision,intent(in) :: A(m,n) + double precision :: B(ncol) + integer :: ilower,iupper,num,i,j + + do ilower=1,n,ncol + iupper = min(ilower + ncol - 1,n) + num = iupper - ilower + 1 + write(*,'(3X,10(9X,I6))') (j,j=ilower,iupper) + do i=1,m + do j=ilower,iupper + B(j-ilower+1) = A(i,j) + enddo + do j=1,num + if(abs(B(j)) < small) B(j) = 0d0 + enddo + write(*,'(I7,10F15.8)') i,(B(j),j=1,num) + enddo + enddo + +end subroutine matout + +!------------------------------------------------------------------------ +subroutine trace_vector(n,v,Tr) + +! Calculate the trace of the vector v of length n +!!! Please use the intrinsic fortran sum() !!! + + implicit none + +! Input variables + + integer,intent(in) :: n + double precision,intent(in) :: v(n) + +! Local variables + + integer :: i + +! Output variables + + double precision,intent(out) :: Tr + + Tr = 0d0 + do i=1,n + Tr = Tr + v(i) + enddo + +end subroutine trace_vector + +!------------------------------------------------------------------------ +function trace_matrix(n,A) result(Tr) + +! Calculate the trace of the square matrix A + + implicit none + +! Input variables + + integer,intent(in) :: n + double precision,intent(in) :: A(n,n) + +! Local variables + + integer :: i + +! Output variables + + double precision :: Tr + + Tr = 0d0 + do i=1,n + Tr = Tr + A(i,i) + enddo + +end function trace_matrix + +!------------------------------------------------------------------------ +subroutine compute_error(nData,Mean,Var,Error) + +! Calculate the statistical error + + implicit none + +! Input variables + + double precision,intent(in) :: nData,Mean(3) + +! Output variables + + double precision,intent(out) :: Error(3) + double precision,intent(inout):: Var(3) + + Error = sqrt((Var-Mean**2/nData)/nData/(nData-1d0)) + +end subroutine compute_error + +!------------------------------------------------------------------------ +subroutine identity_matrix(N,A) + +! Set the matrix A to the identity matrix + + implicit none + +! Input variables + + integer,intent(in) :: N + +! Local viaruabkes + + integer :: i + +! Output variables + + double precision,intent(out) :: A(N,N) + + A = 0d0 + + do i=1,N + A(i,i) = 1d0 + enddo + +end subroutine identity_matrix + +!------------------------------------------------------------------------ +subroutine prepend(N,M,A,b) + +! Prepend the vector b of size N into the matrix A of size NxM + + implicit none + +! Input variables + + integer,intent(in) :: N,M + double precision,intent(in) :: b(N) + +! Local viaruabkes + + integer :: i,j + +! Output variables + + double precision,intent(out) :: A(N,M) + + +! print*,'b in append' +! call matout(N,1,b) + + do i=1,N + do j=M-1,1,-1 + A(i,j+1) = A(i,j) + enddo + A(i,1) = b(i) + enddo + +end subroutine prepend + +!------------------------------------------------------------------------ +subroutine append(N,M,A,b) + +! Append the vector b of size N into the matrix A of size NxM + + implicit none + +! Input variables + + integer,intent(in) :: N,M + double precision,intent(in) :: b(N) + +! Local viaruabkes + + integer :: i,j + +! Output variables + + double precision,intent(out) :: A(N,M) + + do i=1,N + do j=2,M + A(i,j-1) = A(i,j) + enddo + A(i,M) = b(i) + enddo + +end subroutine append + +!------------------------------------------------------------------------ +subroutine AtDA(N,A,D,B) + +! Perform B = At.D.A where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + +! Input variables + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),D(N) + +! Local viaruabkes + + integer :: i,j,k + +! Output variables + + double precision,intent(out) :: B(N,N) + + B = 0d0 + + do i=1,N + do j=1,N + do k=1,N + B(i,k) = B(i,k) + A(j,i)*D(j)*A(j,k) + enddo + enddo + enddo + +end subroutine AtDA + +!------------------------------------------------------------------------ +subroutine ADAt(N,A,D,B) + +! Perform B = A.D.At where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + +! Input variables + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),D(N) + +! Local viaruabkes + + integer :: i,j,k + +! Output variables + + double precision,intent(out) :: B(N,N) + + B = 0d0 + + do i=1,N + do j=1,N + do k=1,N + B(i,k) = B(i,k) + A(i,j)*D(j)*A(k,j) + enddo + enddo + enddo + +end subroutine ADAt +!------------------------------------------------------------------------ +subroutine DA(N,D,A) + +! Perform A <- D.A where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + + integer,intent(in) :: N + integer :: i,j,k + double precision,intent(in) :: D(N) + double precision,intent(inout):: A(N,N) + + do i=1,N + do j=1,N + A(i,j) = D(i)*A(i,j) + enddo + enddo + +end subroutine DA + +!------------------------------------------------------------------------ +subroutine AD(N,A,D) + +! Perform A <- A.D where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + + integer,intent(in) :: N + integer :: i,j,k + double precision,intent(in) :: D(N) + double precision,intent(inout):: A(N,N) + + do i=1,N + do j=1,N + A(i,j) = A(i,j)*D(j) + enddo + enddo + +end subroutine AD + +!------------------------------------------------------------------------ +subroutine print_warning(message) + +! Print warning + + implicit none + + character(len=*),intent(in) :: message + + write(*,*) message + +end subroutine print_warning + + diff --git a/src/MCQC/wrap_lapack.f90 b/src/MCQC/wrap_lapack.f90 new file mode 100644 index 0000000..6c29ab7 --- /dev/null +++ b/src/MCQC/wrap_lapack.f90 @@ -0,0 +1,207 @@ +!subroutine eigenvalues_non_symmetric_matrix(N,A,e) +! +!! Diagonalize a square matrix +! +! implicit none +! +!! Input variables +! +! integer,intent(in) :: N +! double precision,intent(inout):: A(N,N) +! double precision,intent(out) :: e(N) +! +!! Local variables +! +! integer :: lwork,info +! double precision,allocatable :: work(:) +! +!! Memory allocation +! +! allocate(eRe(N),eIm(N),work(3*N)) +! lwork = size(work) +! +! call DGEEV('N','N',N,A,N, eRe, eIm, 0d0,1, VR,LDVR, WORK, LWORK, INFO ) +! +! if(info /= 0) then +! print*,'Problem in diagonalize_matrix (dseev)!!' +! stop +! endif +! +!end subroutine eigenvalues_non_symmetric_matrix + +subroutine diagonalize_matrix(N,A,e) + +! Diagonalize a square matrix + + implicit none + +! Input variables + + integer,intent(in) :: N + double precision,intent(inout):: A(N,N) + double precision,intent(out) :: e(N) + +! Local variables + + integer :: lwork,info + double precision,allocatable :: work(:) + +! Memory allocation + + allocate(work(3*N)) + lwork = size(work) + + call dsyev('V','U',N,A,N,e,work,lwork,info) + + if(info /= 0) then + print*,'Problem in diagonalize_matrix (dsyev)!!' + endif + +end subroutine diagonalize_matrix + +subroutine svd(N,A,U,D,Vt) + + ! Compute A = U.D.Vt + ! Dimension of A is NxN + + implicit none + + integer, intent(in) :: N + double precision,intent(in) :: A(N,N) + double precision,intent(out) :: U(N,N) + double precision,intent(out) :: Vt(N,N) + double precision,intent(out) :: D(N) + double precision,allocatable :: work(:) + integer :: info,lwork + + double precision,allocatable :: scr(:,:) + + allocate (scr(N,N)) + + scr(:,:) = A(:,:) + + ! Find optimal size for temporary arrays + + allocate(work(1)) + + lwork = -1 + call dgesvd('A','A',N,N,scr,N,D,U,N,Vt,N,work,lwork,info) + lwork = int(work(1)) + + deallocate(work) + + allocate(work(lwork)) + + call dgesvd('A','A',N,N,scr,N,D,U,N,Vt,N,work,lwork,info) + + deallocate(work,scr) + + if (info /= 0) then + print *, info, ': SVD failed' + stop + endif + +end + +subroutine inverse_matrix(N,A,B) + +! Returns the inverse of the square matrix A in B + + implicit none + + integer,intent(in) :: N + double precision, intent(in) :: A(N,N) + double precision, intent(out) :: B(N,N) + + integer :: info,lwork + integer, allocatable :: ipiv(:) + double precision,allocatable :: work(:) + + allocate (ipiv(N),work(N*N)) + lwork = size(work) + + B(1:N,1:N) = A(1:N,1:N) + + call dgetrf(N,N,B,N,ipiv,info) + + if (info /= 0) then + + print*,info + stop 'error in inverse (dgetrf)!!' + + endif + + call dgetri(N,B,N,ipiv,work,lwork,info) + + if (info /= 0) then + + print *, info + stop 'error in inverse (dgetri)!!' + + endif + + deallocate(ipiv,work) + +end subroutine inverse_matrix + +subroutine linear_solve(N,A,b,x,rcond) + +! Solve the linear system A.x = b where A is a NxN matrix +! and x and x are vectors of size N + + implicit none + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),b(N),rcond + double precision,intent(out) :: x(N) + + integer :: info,lwork + double precision :: ferr,berr + integer,allocatable :: ipiv(:),iwork(:) + double precision,allocatable :: AF(:,:),work(:) + + lwork = 3*N + allocate(AF(N,N),ipiv(N),work(lwork),iwork(N)) + + call dsysvx('N','U',N,1,A,N,AF,N,ipiv,b,N,x,N,rcond,ferr,berr,work,lwork,iwork,info) + +! if (info /= 0) then + +! print *, info +! stop 'error in linear_solve (dsysvx)!!' + +! endif + +end subroutine linear_solve + +subroutine easy_linear_solve(N,A,b,x) + +! Solve the linear system A.x = b where A is a NxN matrix +! and x and x are vectors of size N + + implicit none + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),b(N) + double precision,intent(out) :: x(N) + + integer :: info,lwork + integer,allocatable :: ipiv(:) + double precision,allocatable :: work(:) + + allocate(ipiv(N),work(N*N)) + lwork = size(work) + + x = b + + call dsysv('U',N,1,A,N,ipiv,x,N,work,lwork,info) + + if (info /= 0) then + + print *, info + stop 'error in linear_solve (dsysv)!!' + + endif + +end subroutine easy_linear_solve + diff --git a/src/xcDFT/AO_values_grid.f90 b/src/xcDFT/AO_values_grid.f90 new file mode 100644 index 0000000..75416e7 --- /dev/null +++ b/src/xcDFT/AO_values_grid.f90 @@ -0,0 +1,101 @@ +subroutine AO_values_grid(nBas,nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + nGrid,root,AO,dAO) + +! Compute values of the AOs and their derivatives with respect to the cartesian coordinates + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nShell + double precision,intent(in) :: CenterShell(maxShell,3) + integer,intent(in) :: TotAngMomShell(maxShell) + integer,intent(in) :: KShell(maxShell) + double precision,intent(in) :: DShell(maxShell,maxK) + double precision,intent(in) :: ExpShell(maxShell,maxK) + double precision,intent(in) :: root(3,nGrid) + integer,intent(in) :: nGrid + +! Local variables + + integer :: atot,nShellFunction,a(3) + integer,allocatable :: ShellFunction(:,:) + double precision :: rASq,xA,yA,zA,NormCoeff,prim + + integer :: iSh,iShF,iK,iG,iBas + +! Output variables + + double precision,intent(out) :: AO(nBas,nGrid) + double precision,intent(out) :: dAO(3,nBas,nGrid) + +! Initialization + + iBas = 0 + AO(:,:) = 0d0 + dAO(:,:,:) = 0d0 + +!------------------------------------------------------------------------ +! Loops over shells +!------------------------------------------------------------------------ + do iSh=1,nShell + + atot = TotAngMomShell(iSh) + nShellFunction = (atot*atot + 3*atot + 2)/2 + allocate(ShellFunction(1:nShellFunction,1:3)) + call generate_shell(atot,nShellFunction,ShellFunction) + + do iShF=1,nShellFunction + + iBas = iBas + 1 + a(:) = ShellFunction(iShF,:) + + do iG=1,nGrid + + xA = root(1,iG) - CenterShell(iSh,1) + yA = root(2,iG) - CenterShell(iSh,2) + zA = root(3,iG) - CenterShell(iSh,3) + +! Calculate distance for exponential + + rASq = xA**2 + yA**2 + zA**2 + +!------------------------------------------------------------------------ +! Loops over contraction degrees +!------------------------------------------------------------------------- + do iK=1,KShell(iSh) + +! Calculate the exponential part + + prim = DShell(iSh,iK)*NormCoeff(ExpShell(iSh,iK),a)*exp(-ExpShell(iSh,iK)*rASq) + AO(iBas,iG) = AO(iBas,iG) + prim + + prim = -2d0*ExpShell(iSh,iK)*prim + dAO(:,iBas,iG) = dAO(:,iBas,iG) + prim + + enddo + + dAO(1,iBas,iG) = xA**(a(1)+1)*yA**a(2)*zA**a(3)*dAO(1,iBas,iG) + if(a(1) > 0) dAO(1,iBas,iG) = dAO(1,iBas,iG) + dble(a(1))*xA**(a(1)-1)*yA**a(2)*zA**a(3)*AO(iBas,iG) + + dAO(2,iBas,iG) = xA**a(1)*yA**(a(2)+1)*zA**a(3)*dAO(2,iBas,iG) + if(a(2) > 0) dAO(2,iBas,iG) = dAO(2,iBas,iG) + dble(a(2))*xA**a(1)*yA**(a(2)-1)*zA**a(3)*AO(iBas,iG) + + dAO(3,iBas,iG) = xA**a(1)*yA**a(2)*zA**(a(3)+1)*dAO(3,iBas,iG) + if(a(3) > 0) dAO(3,iBas,iG) = dAO(3,iBas,iG) + dble(a(3))*xA**a(1)*yA**a(2)*zA**(a(3)-1)*AO(iBas,iG) + +! Calculate polynmial part + + AO(iBas,iG) = xA**a(1)*yA**a(2)*zA**a(3)*AO(iBas,iG) + + enddo + + enddo + deallocate(ShellFunction) + enddo +!------------------------------------------------------------------------ +! End loops over shells +!------------------------------------------------------------------------ + +end subroutine AO_values_grid diff --git a/src/xcDFT/DIIS_extrapolation.f90 b/src/xcDFT/DIIS_extrapolation.f90 new file mode 100644 index 0000000..9ba503e --- /dev/null +++ b/src/xcDFT/DIIS_extrapolation.f90 @@ -0,0 +1,52 @@ +subroutine DIIS_extrapolation(n,n_diis,error,e,error_in,e_inout) + +! Perform DIIS extrapolation + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: n,n_diis + double precision,intent(in) :: error(n,n_diis),e(n,n_diis),error_in(n) + +! Local variables + + double precision,allocatable :: A(:,:),b(:),w(:) + +! Output variables + + double precision,intent(inout):: e_inout(n) + +! Memory allocaiton + + allocate(A(n_diis+1,n_diis+1),b(n_diis+1),w(n_diis+1)) + +! Update DIIS "history" + + call prepend(n,n_diis,error,error_in) + call prepend(n,n_diis,e,e_inout) + +! Build A matrix + + A(1:n_diis,1:n_diis) = matmul(transpose(error),error) + + A(1:n_diis,n_diis+1) = -1d0 + A(n_diis+1,1:n_diis) = -1d0 + A(n_diis+1,n_diis+1) = +0d0 + +! Build x matrix + + b(1:n_diis) = +0d0 + b(n_diis+1) = -1d0 + +! Solve linear system + + call linear_solve(n_diis+1,A,b,w) + +! Extrapolate + + e_inout(:) = matmul(w(1:n_diis),transpose(e(:,1:n_diis))) + +end subroutine DIIS_extrapolation diff --git a/src/xcDFT/Makefile b/src/xcDFT/Makefile new file mode 100644 index 0000000..cbacf0f --- /dev/null +++ b/src/xcDFT/Makefile @@ -0,0 +1,34 @@ +IDIR =../../include +BDIR =../../bin +ODIR = obj +SDIR =. +FC = gfortran -I$(IDIR) +ifeq ($(DEBUG),1) +FFLAGS = -Wall -g -msse4.2 -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation -Wreal-q-constant +else +FFLAGS = -Wall -Wno-unused -Wno-unused-dummy-argument -O2 +endif + +LIBS = ~/Dropbox/quack/lib/*.a +#LIBS = -lblas -llapack + +SRCF90 = $(wildcard *.f90) + +SRC = $(wildcard *.f) + +OBJ = $(patsubst %.f90,$(ODIR)/%.o,$(SRCF90)) $(patsubst %.f,$(ODIR)/%.o,$(SRC)) + +$(ODIR)/%.o: %.f90 + $(FC) -c -o $@ $< $(FFLAGS) + +$(ODIR)/%.o: %.f + $(FC) -c -o $@ $< $(FFLAGS) + +$(BDIR)/xcDFT: $(OBJ) + $(FC) -o $@ $^ $(FFLAGS) $(LIBS) + +debug: + DEBUG=1 make clean $(BDIR)/xcDFT + +clean: + rm -f $(ODIR)/*.o $(BDIR)/xcDFT $(BDIR)/debug diff --git a/src/xcDFT/NormCoeff.f90 b/src/xcDFT/NormCoeff.f90 new file mode 100644 index 0000000..ff0fac9 --- /dev/null +++ b/src/xcDFT/NormCoeff.f90 @@ -0,0 +1,31 @@ +function NormCoeff(alpha,a) + +! Compute normalization coefficients for cartesian gaussians + + implicit none + +! Input variables + + double precision,intent(in) :: alpha + integer,intent(in) :: a(3) + +! local variable + double precision :: pi,dfa(3),dfac + integer :: atot + +! Output variable + double precision NormCoeff + + pi = 4d0*atan(1d0) + atot = a(1) + a(2) + a(3) + + dfa(1) = dfac(2*a(1))/(2d0**a(1)*dfac(a(1))) + dfa(2) = dfac(2*a(2))/(2d0**a(2)*dfac(a(2))) + dfa(3) = dfac(2*a(3))/(2d0**a(3)*dfac(a(3))) + + + NormCoeff = (2d0*alpha/pi)**(3d0/2d0)*(4d0*alpha)**atot + NormCoeff = NormCoeff/(dfa(1)*dfa(2)*dfa(3)) + NormCoeff = sqrt(NormCoeff) + +end function NormCoeff diff --git a/src/xcDFT/RKS.f90 b/src/xcDFT/RKS.f90 new file mode 100644 index 0000000..571f21e --- /dev/null +++ b/src/xcDFT/RKS.f90 @@ -0,0 +1,221 @@ +subroutine RKS(rung,nGrid,weight,nBas,AO,dAO,nO,S,T,V,Hc,ERI,X,ENuc,EKS) + +! Perform a restricted Kohn-Sham calculation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: rung + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(3,nBas,nGrid) + + integer,intent(in) :: nO + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: T(nBas,nBas) + double precision,intent(in) :: V(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas) + double precision,intent(in) :: X(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ENuc + +! Local variables + + integer,parameter :: maxSCF = 64 + double precision,parameter :: thresh = 1d-5 + integer,parameter :: n_diis = 1 + integer :: nSCF + double precision :: Conv + double precision :: ET,EV,EJ + double precision :: Ex + double precision :: Ec + double precision,allocatable :: e(:) + double precision,allocatable :: c(:,:),cp(:,:) + double precision,allocatable :: P(:,:),Pa(:,:) + double precision,allocatable :: J(:,:) + double precision,allocatable :: F(:,:),Fp(:,:) + double precision,allocatable :: Fx(:,:),FxHF(:,:) + double precision,allocatable :: Fc(:,:) + double precision,allocatable :: error(:,:) + double precision,allocatable :: error_diis(:,:),F_diis(:,:) + double precision,external :: trace_matrix + double precision,external :: exchange_energy + double precision,external :: electron_number + + double precision,allocatable :: rhoa(:) + double precision,allocatable :: drhoa(:,:) + double precision :: nEl + +! Output variables + + double precision,intent(out) :: EKS + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Restricted Kohn-Sham calculation |' + write(*,*)'************************************************' + write(*,*) + +!------------------------------------------------------------------------ +! Rung of Jacob's ladder +!------------------------------------------------------------------------ + + call select_rung(rung) + +! Memory allocation + + allocate(e(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),Pa(nBas,nBas), & + J(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas),Fx(nBas,nBas),FxHF(nBas,nBas), & + Fc(nBas,nBas),error(nBas,nBas),rhoa(nGrid),drhoa(3,nGrid), & + error_diis(nBas*nBas,n_diis),F_diis(nBas*nBas,n_diis)) + +! Guess coefficients and eigenvalues + + F(:,:) = Hc(:,:) + +! Initialization + + nSCF = 0 + Conv = 1d0 + nEl = 0d0 + + Ex = 0d0 + Ec = 0d0 + + Fx(:,:) = 0d0 + FxHF(:,:) = 0d0 + Fc(:,:) = 0d0 + + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + + write(*,*) + write(*,*)'------------------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A16,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','EKS','|','ExKS','|','EcKS','|','Conv','|','nEl','|' + write(*,*)'------------------------------------------------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Transform Fock matrix in orthogonal basis + + Fp = matmul(transpose(X),matmul(F,X)) + +! Diagonalize Fock matrix to get eigenvectors and eigenvalues + + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + +! Back-transform eigenvectors in non-orthogonal basis + + c = matmul(X,cp) + +! Compute density matrix + + Pa(:,:) = matmul(c(:,1:nO),transpose(c(:,1:nO))) + P(:,:) = 2d0*Pa(:,:) + +! Compute one-electron density and its gradient if necessary + + call density(nGrid,nBas,Pa,AO,rhoa) + if(rung > 1) call gradient_density(nGrid,nBas,Pa,AO,dAO,drhoa) + +! Build Coulomb repulsion + + call hartree_coulomb(nBas,P,ERI,J) + +! Compute exchange potential + + call exchange_potential(rung,nGrid,weight,nBas,Pa,ERI,AO,dAO,rhoa,drhoa,Fx,FxHF) + +! Compute correlation potential + +! call correlation_potential(rung,nGrid,weight,nBas,Pa,ERI,AO,dAO,rhoa,drhoa,Fc) + +! Build Fock operator + + F(:,:) = Hc(:,:) + J(:,:) + Fx(:,:) + Fc(:,:) + +! Check convergence + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + +! DIIS extrapolation + + call DIIS_extrapolation(nBas*nBas,min(n_diis,nSCF),error_diis,F_diis,error,F) + +!------------------------------------------------------------------------ +! Compute KS energy +!------------------------------------------------------------------------ + +! Kinetic energy + + ET = trace_matrix(nBas,matmul(P,T)) + +! Potential energy + + EV = trace_matrix(nBas,matmul(P,V)) + +! Coulomb energy + + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + +! Exchange energy + + Ex = exchange_energy(rung,nGrid,weight,nBas,Pa,FxHF,rhoa,drhoa) + +! Correlation energy + +! call correlation_energy(rung,nGrid,weight,nBas,Pa,rhoa,drhoa,Ec) + + EKS = ET + EV + EJ + Ex + Ec + +! Check the grid accuracy by computing the number of electrons + + nEl = electron_number(nGrid,weight,rhoa) + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F16.10,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',EKS+ENuc,'|',Ex,'|',Ec,'|',Conv,'|',nEl,'|' + + enddo + write(*,*)'------------------------------------------------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Compute final KS energy + + call print_RKS(nBas,nO,e,C,ENuc,ET,EV,EJ,Ex,Ec,EKS) + +end subroutine RKS diff --git a/src/xcDFT/density.f90 b/src/xcDFT/density.f90 new file mode 100644 index 0000000..e6bfd22 --- /dev/null +++ b/src/xcDFT/density.f90 @@ -0,0 +1,38 @@ +subroutine density(nGrid,nBas,P,AO,rho) + +! Calculate one-electron density + + implicit none + include 'parameters.h' + +! Input variables + + double precision,parameter :: thresh = 1d-15 + + integer,intent(in) :: nGrid + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: AO(nBas,nGrid) + +! Local variables + + integer :: iG,mu,nu + +! Output variables + + double precision,intent(out) :: rho(nGrid) + + rho(:) = 0d0 + do iG=1,nGrid + do mu=1,nBas + do nu=1,nBas + rho(iG) = rho(iG) + AO(mu,iG)*P(mu,nu)*AO(nu,iG) + enddo + enddo + enddo + +! do iG=1,nGrid +! rho(iG) = max(rho(iG),thresh) +! enddo + +end subroutine density diff --git a/src/xcDFT/dft_grid.f b/src/xcDFT/dft_grid.f new file mode 100644 index 0000000..66eb029 --- /dev/null +++ b/src/xcDFT/dft_grid.f @@ -0,0 +1,3017 @@ +c----------------------------------------------------------------------- + + SUBROUTINE EulMac(Pts,Wts,N,R) +c ****************************************************************** +c * * +c * EulMac constructs an Euler-Maclaurin quadrature formula for * +c * * +c * inf * +c * Integral [r**2 g(r)] dr * +c * 0 * +c * * +c * OUTPUT: * +c * Pts - Quadrature points * +c * Wts - Quadrature weights * +c * * +c * INPUT: * +c * N - Number of points desired * +c * R - Length scaling factor * +c * * +c ****************************************************************** + IMPLICIT REAL*8 (a-h,o-z) + REAL*8 Pts(N),Wts(N) + T = R**3 * FLOAT(N+1) + DO i = 1,N + U = FLOAT(i) + V = FLOAT(N-i+1) + Pts(i) = R * (U/V)**2 + Wts(i) = 2 * T * U**5 / V**7 + END DO + RETURN + END + +c----------------------------------------------------------------------- + + SUBROUTINE Lebdev(Pts,Wts,N) +c ****************************************************************** +c * * +c * Lebdev returns a Lebedev formula for quadrature on the * +c * surface of the unit sphere having the desired number * +c * of points. * +c * * +c * OUTPUT: * +c * Pts - Cartesian coordinates of quadrature points * +c * Wts - Quadrature weights * +c * * +c * INPUT: * +c * N - Number of quadrature points desired * +c * * +c * N Description * +c * --- ----------- * +c * 1 Debugging formula * +c * 4 2nd-degree, Tetrahedral formula * +c * 6 3rd-degree, Octahedral formula * +c * 18 5th-degree, Abramowitz & Stegun, p. 894 * +c * 26 7th-degree, Abramowitz & Stegun, p. 894 * +c * 38 9th-degree, Ref. 1 * +c * 50 11th-degree, Ref. 1 * +c * 86 15th-degree, Ref. 1 * +c * 110 17th-degree, Ref. 1 * +c * 146 19th-degree, Ref. 2 * +c * 194 23rd-degree, Ref. 2 * +c * 302 29th-degree, Ref. 3 * +c * * +c * Refs: 1) Zh. Vychisl. Mat. Mat. Fiz. 15, 48 (1975). * +c * 2) Zh. Vychisl. Mat. Mat. Fiz. 16, 293 (1976). * +c * 3) Sibirsk. Mat. Zh. 18, 132 (1977). * +c * * +c ****************************************************************** + IMPLICIT REAL*8 (a-h,o-z) + PARAMETER (NLeb=31,MaxB=30,MaxC=10,MaxD=90) + REAL*8 Pts(3,*),Wts(*),A(3,NLeb),B(MaxB,NLeb),C(MaxC,NLeb), + $ D(MaxD,NLeb),T(MaxB,NLeb),V(MaxC,NLeb),S(2,MaxD,NLeb), + $ mk,lk,r(3),Guess(3) + INTEGER SetTyp(6,NLeb),Pmt(3,6) + SAVE SetTyp,Pmt,Guess + SAVE A,B,C,D,T,V,S + DATA SetTyp / 1,0,0,0,0,0, + $ 1,1,0,0,0,0, + $ 1,1,1,0,0,0, + $ 1,0,1,0,1,0, + $ 1,1,1,1,0,0, + $ 1,1,1,1,1,0, + $ 1,0,1,2,1,0, + $ 1,0,1,3,1,0, + $ 1,1,1,3,0,1, + $ 1,1,1,3,1,1, + $ 1,1,1,4,1,1, + $ 1,0,1,5,2,1, + $ 1,1,1,5,1,2, + $ 1,0,1,6,2,2, + $ 1,0,1,6,2,3, + $ 1,1,1,7,2,4, + $ 1,0,1,9,3,6, + $ 1,1,1,10,3,9, + $ 1,0,1,12,4,12, + $ 1,1,1,13,4,16, + $ 1,0,1,15,5,20, + $ 1,1,1,16,5,25, + $ 1,0,1,18,6,30, + $ 1,1,1,19,6,36, + $ 1,0,1,21,7,42, + $ 1,1,1,22,7,49, + $ 1,0,1,24,8,56, + $ 1,1,1,25,8,64, + $ 1,0,1,27,9,72, + $ 1,1,1,28,9,81, + $ 1,0,1,30,10,90 / + DATA Pmt / 1,2,3, 2,3,1, 3,1,2, 2,1,3, 1,3,2, 3,2,1 / + DATA Guess / 0.15D0,0.5D0,0.85D0 / + + DATA A(1,1) + $ / 0.1666666666666666666666666666666667D+00 / + DATA (A(j,2),j=1,2) + $ / 0.3333333333333333333333333333333333D-01, + $ 0.6666666666666666666666666666666667D-01 / + DATA (A(j,3),j=1,3) + $ / 0.4761904761904761904761904761904762D-01, + $ 0.3809523809523809523809523809523810D-01, + $ 0.3214285714285714285714285714285714D-01 / + DATA (A(j,4),j=1,3) + $ / 0.9523809523809523809523809523809525D-02, 0D0, + $ 0.3214285714285714285714285714285714D-01 / + DATA (A(j,5),j=1,3) + $ / 0.1269841269841269841269841269841270D-01, + $ 0.2257495590828924162257495590828924D-01, + $ 0.2109375D-01 / + DATA (A(j,6),j=1,3) + $ / 5.130671797338D-04, + $ 1.660406956574D-02, + $ -2.958603896104D-02 / + DATA (A(j,7),j=1,3) + $ / 0.1154401154401154401154401154401154D-01, 0D0, + $ 0.1194390908585628232369892597364696D-01 / + DATA (A(j,8),j=1,3) + $ / 0.3828270494937161603828270494937183D-02, 0D0, + $ 0.9793737512487512487512487512487502D-02 / + DATA (A(j,9),j=1,3) + $ / 0.5996313688621380929073236765544457D-03, + $ 0.7372999718620756423057432684105612D-02, + $ 0.7210515360144487777633059968342821D-02 / + DATA (A(j,10),j=1,3) + $ / 5.544842902037D-03, + $ 6.071332770671D-03, + $ 6.383674773515D-03 / + DATA (A(j,11),j=1,3) + $ / 0.1782340447244611157367271048698676D-02, + $ 0.5716905949977101892992128388320993D-02, + $ 0.5573383178848737968367849584466468D-02 / + DATA (A(j,12),j=1,3) + $ / -5.522639919727D-02, + $ 0.000000000000D+00, + $ 4.450274607445D-03 / + DATA (A(j,13),j=1,3) + $ / -1.313769127327D-03, + $ -2.522728704859D-03, + $ 4.186853881701D-03 / + DATA (A(j,14),j=1,3) + $ / 0.8545911725128148134231210325881270D-03, 0D0, + $ 0.3599119285025571458863978589612291D-02 / + DATA (A(j,15),j=1,3) + $ / 3.006796749454D-03, + $ 0.000000000000D+00, + $ 3.050627745651D-03 / + DATA (A(j,16),j=1,3) + $ / 5.265897968224D-04, + $ 2.548219972003D-03, + $ 2.512317418927D-03 / + DATA (A(j,17),j=1,3) + $ / 3.095121295306D-04, + $ 0.000000000000D+00, + $ 1.852379698597D-03 / + DATA (A(j,18),j=1,3) + $ / 2.192942088181D-04, + $ 1.436433617319D-03, + $ 1.421940344336D-03 / + DATA (A(j,19),j=1,3) + $ / 1.438294190527D-04, + $ 0.000000000000D+00, + $ 1.125772288287D-03 / + DATA (A(j,20),j=1,3) + $ / 1.105189233268D-04, + $ 9.205232738091D-04, + $ 9.133159786444D-04 / + DATA (A(j,21),j=1,3) + $ / 7.777160743261D-05, + $ 0.000000000000D+00, + $ 7.557646413005D-04 / + DATA (A(j,22),j=1,3) + $ / 6.309049437421D-05, + $ 6.398287705572D-04, + $ 6.357185073531D-04 / + DATA (A(j,23),j=1,3) + $ / 4.656031899197D-05, + $ 0.000000000000D+00, + $ 5.421549195296D-04 / + DATA (A(j,24),j=1,3) + $ / 3.922616270665D-05, + $ 4.703831750854D-04, + $ 4.678202801282D-04 / + DATA (A(j,25),j=1,3) + $ / 2.998675149888D-05, + $ 0.000000000000D+00, + $ 4.077860529495D-04 / + DATA (A(j,26),j=1,3) + $ / 2.599095953755D-05, + $ 3.603134089688D-04, + $ 3.586067974412D-04 / + DATA (A(j,27),j=1,3) + $ / 2.040382730826D-05, + $ 0.000000000000D+00, + $ 3.178149703890D-04 / + DATA (A(j,28),j=1,3) + $ / 1.807395252197D-05, + $ 2.848008782239D-04, + $ 2.836065837531D-04 / + DATA (A(j,29),j=1,3) + $ / 1.449063022538D-05, + $ 0.000000000000D+00, + $ 2.546377329828D-04 / + DATA (A(j,30),j=1,3) + $ / 9.687521879421D-05, + $ 2.307897895368D-04, + $ 2.297310852499D-04 / + DATA (A(j,31),j=1,3) + $ / 9.080510764308D-05, + $ 0.000000000000D+00, + $ 2.084824361988D-04 / + DATA B(1,5) + $ / 0.2017333553791887125220458553791887D-01 / + DATA B(1,6) + $ / 2.657620708216D-02 / + DATA (B(j,7),j=1,2) + $ / 0.1111055571060340251094684821601397D-01, + $ 0.1187650129453714201378828059940252D-01 / + DATA (B(j,8),j=1,3) + $ / 0.8211737283191110975989934052273075D-02, + $ 0.9595471336070962849453181172902595D-02, + $ 0.9942814891178103281400658285264506D-02 / + DATA (B(j,9),j=1,3) + $ / 0.7574394159054033722687485747138069D-02, + $ 0.6753829486314477440735417324864531D-02, + $ 0.7116355493117555387600892849539733D-02 / + DATA (B(j,10),j=1,3) + $ / 5.183387587748D-03, + $ 6.317929009814D-03, + $ 6.201670006589D-03 / + DATA (B(j,11),j=1,4) + $ / 0.5518771467273613691727684601193794D-02, + $ 0.5158237711805383103249161547187927D-02, + $ 0.5608704082587996843749366738551845D-02, + $ 0.4106777028169394090728611285645817D-02 / + DATA (B(j,12),j=1,5) + $ / 4.496841067921D-03, + $ 5.049153450479D-03, + $ 3.976408018052D-03, + $ 4.401400650381D-03, + $ 1.724544350544D-02 / + DATA (B(j,13),j=1,5) + $ / 5.315167977811D-03, + $ 4.047142377086D-03, + $ 4.112482394407D-03, + $ 3.595584899759D-03, + $ 4.256131351428D-03 / + DATA (B(j,14),j=1,6) + $ / 0.3650045807677255428654332201126546D-02, + $ 0.3604822601419881711314809131043636D-02, + $ 0.3576729661743367075562081375609260D-02, + $ 0.3449788424305883310013027710484181D-02, + $ 0.3108953122413675254845876980830533D-02, + $ 0.2352101413689164378792171183376706D-02 / + DATA (B(j,15),j=1,6) + $ / 1.621104600289D-03, + $ 3.005701484902D-03, + $ 2.990992529654D-03, + $ 2.982170644108D-03, + $ 2.721564237311D-03, + $ 3.033513795811D-03 / + DATA (B(j,16),j=1,7) + $ / 2.530403801186D-03, + $ 2.014279020919D-03, + $ 2.501725168403D-03, + $ 2.513267174598D-03, + $ 2.302694782227D-03, + $ 1.462495621595D-03, + $ 2.445373437313D-03 / + DATA (B(j,17),j=1,9) + $ / 1.871790639278D-03, + $ 1.858812585438D-03, + $ 1.852028828296D-03, + $ 1.846715956151D-03, + $ 1.818471778163D-03, + $ 1.749564657281D-03, + $ 1.617210647254D-03, + $ 1.384737234852D-03, + $ 9.764331165051D-04 / + DATA (B(j,18),j=1,10) + $ / 6.798123511051D-04, + $ 9.913184235295D-04, + $ 1.180207833239D-03, + $ 1.296599602081D-03, + $ 1.365871427428D-03, + $ 1.402988604775D-03, + $ 1.418645563596D-03, + $ 1.421376741852D-03, + $ 1.423996475491D-03, + $ 1.431554042179D-03 / + DATA (B(j,19),j=1,12) + $ / 4.948029341949D-04, + $ 7.357990109125D-04, + $ 8.889132771304D-04, + $ 9.888347838921D-04, + $ 1.053299681709D-03, + $ 1.092778807015D-03, + $ 1.114389394063D-03, + $ 1.123724788052D-03, + $ 1.125239325244D-03, + $ 1.126153271816D-03, + $ 1.130286931124D-03, + $ 1.134986534364D-03 / + DATA (B(j,20),j=1,13) + $ / 3.690421898018D-04, + $ 5.603990928681D-04, + $ 6.865297629283D-04, + $ 7.720338551146D-04, + $ 8.301545958895D-04, + $ 8.686692550180D-04, + $ 8.927076285847D-04, + $ 9.060820238568D-04, + $ 9.119777254941D-04, + $ 9.128720138604D-04, + $ 9.130714935692D-04, + $ 9.152873784554D-04, + $ 9.187436274322D-04 / + DATA (B(j,21),j=1,15) + $ / 2.841633806091D-04, + $ 4.374419127054D-04, + $ 5.417174740872D-04, + $ 6.148000891359D-04, + $ 6.664394485801D-04, + $ 7.025039356923D-04, + $ 7.268511789250D-04, + $ 7.422637534209D-04, + $ 7.509545035841D-04, + $ 7.548535057718D-04, + $ 7.554088969774D-04, + $ 7.553147174443D-04, + $ 7.564767653292D-04, + $ 7.587991808519D-04, + $ 7.608261832033D-04 / + DATA (B(j,22),j=1,16) + $ / 2.221207162188D-04, + $ 3.475784022287D-04, + $ 4.350742443590D-04, + $ 4.978569136522D-04, + $ 5.435036221998D-04, + $ 5.765913388220D-04, + $ 6.001200359226D-04, + $ 6.162178172718D-04, + $ 6.265218152438D-04, + $ 6.323987160974D-04, + $ 6.350767851541D-04, + $ 6.354362775297D-04, + $ 6.352302462706D-04, + $ 6.358117881418D-04, + $ 6.373101590310D-04, + $ 6.390428961369D-04 / + DATA (B(j,23),j=1,18) + $ / 1.778522133347D-04, + $ 2.811325405683D-04, + $ 3.548896312631D-04, + $ 4.090310897173D-04, + $ 4.493286134170D-04, + $ 4.793728447963D-04, + $ 5.015415319164D-04, + $ 5.175127372678D-04, + $ 5.285522262081D-04, + $ 5.356832703714D-04, + $ 5.397914736175D-04, + $ 5.416899441600D-04, + $ 5.419308476890D-04, + $ 5.416936902031D-04, + $ 5.419544338703D-04, + $ 5.428983656631D-04, + $ 5.442286500098D-04, + $ 5.452250345057D-04 / + DATA (B(j,24),j=1,19) + $ / 1.437832228980D-04, + $ 2.303572493578D-04, + $ 2.933110752447D-04, + $ 3.402905998360D-04, + $ 3.759138466870D-04, + $ 4.030638447900D-04, + $ 4.236591432242D-04, + $ 4.390522656947D-04, + $ 4.502523466626D-04, + $ 4.580577727784D-04, + $ 4.631391616616D-04, + $ 4.660928953699D-04, + $ 4.674751807937D-04, + $ 4.676414903933D-04, + $ 4.674086492348D-04, + $ 4.674928539483D-04, + $ 4.680748979686D-04, + $ 4.690449806389D-04, + $ 4.699877075861D-04 / + DATA (B(j,25),j=1,21) + $ / 1.185349192521D-04, + $ 1.913408643426D-04, + $ 2.452886577210D-04, + $ 2.862408183289D-04, + $ 3.178032258257D-04, + $ 3.422945667634D-04, + $ 3.612790520236D-04, + $ 3.758638229819D-04, + $ 3.868711798860D-04, + $ 3.949429933190D-04, + $ 4.006068107541D-04, + $ 4.043192149673D-04, + $ 4.064947495808D-04, + $ 4.075245619813D-04, + $ 4.076423540894D-04, + $ 4.074280862252D-04, + $ 4.074163756012D-04, + $ 4.077647795071D-04, + $ 4.084517552783D-04, + $ 4.092468459224D-04, + $ 4.097872687241D-04 / + DATA (B(j,26),j=1,22) + $ / 9.831528474386D-05, + $ 1.605023107954D-04, + $ 2.072200131464D-04, + $ 2.431297618814D-04, + $ 2.711819064497D-04, + $ 2.932762038321D-04, + $ 3.107032514197D-04, + $ 3.243808058921D-04, + $ 3.349899091374D-04, + $ 3.430580688505D-04, + $ 3.490124109290D-04, + $ 3.532148948562D-04, + $ 3.559862669063D-04, + $ 3.576224317551D-04, + $ 3.584050533086D-04, + $ 3.584903581373D-04, + $ 3.582991879041D-04, + $ 3.582371187963D-04, + $ 3.584353631122D-04, + $ 3.589120166518D-04, + $ 3.595445704532D-04, + $ 3.600943557111D-04 / + DATA (B(j,27),j=1,24) + $ / 8.288115128076D-05, + $ 1.360883192523D-04, + $ 1.766854454543D-04, + $ 2.083153161230D-04, + $ 2.333279544657D-04, + $ 2.532809539930D-04, + $ 2.692472184211D-04, + $ 2.819949946812D-04, + $ 2.920953593973D-04, + $ 2.999889782948D-04, + $ 3.060292120497D-04, + $ 3.105109167522D-04, + $ 3.136902387550D-04, + $ 3.157984652455D-04, + $ 3.170516518425D-04, + $ 3.176568425634D-04, + $ 3.177198411207D-04, + $ 3.175519492395D-04, + $ 3.174654952635D-04, + $ 3.175676415468D-04, + $ 3.178923417835D-04, + $ 3.183788287532D-04, + $ 3.188755151919D-04, + $ 3.191916889314D-04 / + DATA (B(j,28),j=1,25) + $ / 7.013149266674D-05, + $ 1.162798021957D-04, + $ 1.518728583972D-04, + $ 1.798796108217D-04, + $ 2.022593385973D-04, + $ 2.203093105575D-04, + $ 2.349294234300D-04, + $ 2.467682058747D-04, + $ 2.563092683572D-04, + $ 2.639253896763D-04, + $ 2.699137479265D-04, + $ 2.745196420167D-04, + $ 2.779529197398D-04, + $ 2.803996086684D-04, + $ 2.820302356716D-04, + $ 2.830056747491D-04, + $ 2.834808950777D-04, + $ 2.835282339079D-04, + $ 2.833819267066D-04, + $ 2.832858336907D-04, + $ 2.833268235451D-04, + $ 2.835432677029D-04, + $ 2.839091722743D-04, + $ 2.843308178876D-04, + $ 2.846703550534D-04 / + DATA (B(j,29),j=1,27) + $ / 6.018432961087D-05, + $ 1.002286583264D-04, + $ 1.315222931028D-04, + $ 1.564213746877D-04, + $ 1.765118841508D-04, + $ 1.928737099311D-04, + $ 2.062658534263D-04, + $ 2.172395445954D-04, + $ 2.262076188876D-04, + $ 2.334885699462D-04, + $ 2.393355273179D-04, + $ 2.439559200469D-04, + $ 2.475251866060D-04, + $ 2.501965558159D-04, + $ 2.521081407926D-04, + $ 2.533881002388D-04, + $ 2.541582900848D-04, + $ 2.545365737526D-04, + $ 2.545726993067D-04, + $ 2.544456197466D-04, + $ 2.543481596881D-04, + $ 2.543506451429D-04, + $ 2.544905675494D-04, + $ 2.547611407344D-04, + $ 2.551060375449D-04, + $ 2.554291933816D-04, + $ 2.556255710686D-04 / + DATA (B(j,30),j=1,28) + $ / 7.386265944002D-05, + $ 8.257977698542D-05, + $ 9.706044762058D-05, + $ 1.302393847117D-04, + $ 1.541957004601D-04, + $ 1.704459770092D-04, + $ 1.827374890943D-04, + $ 1.926360817436D-04, + $ 2.008010239495D-04, + $ 2.075635983209D-04, + $ 2.131306638691D-04, + $ 2.176562329937D-04, + $ 2.212682262991D-04, + $ 2.240799515669D-04, + $ 2.261959816188D-04, + $ 2.277156368809D-04, + $ 2.287351772128D-04, + $ 2.293490814084D-04, + $ 2.296505312376D-04, + $ 2.296793832319D-04, + $ 2.295785443843D-04, + $ 2.295017931529D-04, + $ 2.295059638185D-04, + $ 2.296232343237D-04, + $ 2.298530178741D-04, + $ 2.301579790281D-04, + $ 2.304690404997D-04, + $ 2.307027995907D-04 / + DATA (B(j,31),j=1,30) + $ / 5.011105657240D-05, + $ 5.942520409684D-05, + $ 9.564394826110D-05, + $ 1.185530657126D-04, + $ 1.364510114230D-04, + $ 1.505828825605D-04, + $ 1.619298749867D-04, + $ 1.712450504268D-04, + $ 1.789891098165D-04, + $ 1.854474955630D-04, + $ 1.908148636674D-04, + $ 1.952377405282D-04, + $ 1.988349254282D-04, + $ 2.017079807160D-04, + $ 2.039473082709D-04, + $ 2.056360279289D-04, + $ 2.068525823067D-04, + $ 2.076724877534D-04, + $ 2.081694278238D-04, + $ 2.084157631219D-04, + $ 2.084381531129D-04, + $ 2.083476277129D-04, + $ 2.082686194460D-04, + $ 2.082475686112D-04, + $ 2.083139860290D-04, + $ 2.084745561831D-04, + $ 2.087091313376D-04, + $ 2.089718413298D-04, + $ 2.092003303480D-04, + $ 2.093336148263D-04 / + DATA C(1,4) + $ / 0.2857142857142857142857142857142857D-01 / + DATA C(1,6) + $ / 1.652217099372D-02 / + DATA C(1,7) + $ / 0.1181230374690447536447922630736498D-01 / + DATA C(1,8) + $ / 0.9694996361663028329694996361663027D-02 / + DATA C(1,10) + $ / 5.477143385137D-03 / + DATA C(1,11) + $ / 0.5051846064614808475989311960063897D-02 / + DATA (C(j,12),j=1,2) + $ / 4.231083095357D-03, + $ 5.198069864064D-03 / + DATA C(1,13) + $ / 4.229582700647D-03 / + DATA (C(j,14),j=1,2) + $ / 0.3600820932216460272799206341770999D-02, + $ 0.2982344963171803851951110469245206D-02 / + DATA (C(j,15),j=1,2) + $ / 3.007949555219D-03, + $ 2.881964603055D-03 / + DATA (C(j,16),j=1,2) + $ / 2.417442375639D-03, + $ 1.910951282180D-03 / + DATA (C(j,17),j=1,3) + $ / 1.857161196774D-03, + $ 1.705153996396D-03, + $ 1.300321685886D-03 / + DATA (C(j,18),j=1,3) + $ / 9.254401499865D-04, + $ 1.250239995054D-03, + $ 1.394365843329D-03 / + DATA (C(j,19),j=1,4) + $ / 6.823367927110D-04, + $ 9.454158160447D-04, + $ 1.074429975386D-03, + $ 1.129300086569D-03 / + DATA (C(j,20),j=1,4) + $ / 5.176977312966D-04, + $ 7.331143682101D-04, + $ 8.463232836380D-04, + $ 9.031122694254D-04 / + DATA (C(j,21),j=1,5) + $ / 4.021680447875D-04, + $ 5.804871793946D-04, + $ 6.792151955945D-04, + $ 7.336741211286D-04, + $ 7.581866300990D-04 / + DATA (C(j,22),j=1,5) + $ / 3.186913449947D-04, + $ 4.678028558592D-04, + $ 5.538829697599D-04, + $ 6.044475907190D-04, + $ 6.313575103509D-04 / + DATA (C(j,23),j=1,6) + $ / 2.568002497729D-04, + $ 3.827211700292D-04, + $ 4.579491561918D-04, + $ 5.042003969084D-04, + $ 5.312708889976D-04, + $ 5.438401790747D-04 / + DATA (C(j,24),j=1,6) + $ / 2.099942281069D-04, + $ 3.172269150713D-04, + $ 3.832051358547D-04, + $ 4.252193818147D-04, + $ 4.513807963755D-04, + $ 4.657797469114D-04 / + DATA (C(j,25),j=1,7) + $ / 1.738986811745D-04, + $ 2.659616045280D-04, + $ 3.240596008172D-04, + $ 3.621195964433D-04, + $ 3.868838330761D-04, + $ 4.018911532693D-04, + $ 4.089929432983D-04 / + DATA (C(j,26),j=1,7) + $ / 1.456447096742D-04, + $ 2.252370188284D-04, + $ 2.766135443475D-04, + $ 3.110729491501D-04, + $ 3.342506712303D-04, + $ 3.491981834027D-04, + $ 3.576003604349D-04 / + DATA (C(j,27),j=1,8) + $ / 1.231779611745D-04, + $ 1.924661373840D-04, + $ 2.380881867403D-04, + $ 2.693100663038D-04, + $ 2.908673382834D-04, + $ 3.053914619382D-04, + $ 3.143916684148D-04, + $ 3.187042244055D-04 / + DATA (C(j,28),j=1,8) + $ / 1.051193406972D-04, + $ 1.657871838797D-04, + $ 2.064648113714D-04, + $ 2.347942745820D-04, + $ 2.547775326598D-04, + $ 2.686876684847D-04, + $ 2.778665755516D-04, + $ 2.830996616783D-04 / + DATA (C(j,29),j=1,9) + $ / 9.041339695118D-05, + $ 1.438426330079D-04, + $ 1.802523089821D-04, + $ 2.060052290565D-04, + $ 2.245002248967D-04, + $ 2.377059847731D-04, + $ 2.468118955883D-04, + $ 2.525410872967D-04, + $ 2.553101409933D-04 / + DATA (C(j,30),j=1,9) + $ / 9.312274696671D-05, + $ 1.199919385877D-04, + $ 1.598039138878D-04, + $ 1.822253763575D-04, + $ 1.988579593655D-04, + $ 2.112620102533D-04, + $ 2.201594887699D-04, + $ 2.261622590895D-04, + $ 2.296458453436D-04 / + DATA (C(j,31),j=1,10) + $ / 7.591708117365D-05, + $ 1.083383968169D-04, + $ 1.403019395293D-04, + $ 1.615970179286D-04, + $ 1.771144187505D-04, + $ 1.887760022988D-04, + $ 1.973474670768D-04, + $ 2.033787661235D-04, + $ 2.072343626517D-04, + $ 2.091177834227D-04 / + DATA D(1,9) + $ / 0.6991087353303262394171485080575989D-02 / + DATA D(1,10) + $ / 5.968383987681D-03 / + DATA D(1,11) + $ / 0.5530248916233093701297682691433032D-02 / + DATA D(1,12) + $ / 4.695720972569D-03 / + DATA (D(j,13),j=1,2) + $ / 4.080914225781D-03, + $ 4.071467593831D-03 / + DATA (D(j,14),j=1,2) + $ / 0.3571540554273387081232979203123946D-02, + $ 0.3392312205006170181978826539456957D-02 / + DATA (D(j,15),j=1,3) + $ / 2.958357626536D-03, + $ 3.036020026407D-03, + $ 2.832187403926D-03 / + DATA (D(j,16),j=1,4) + $ / 2.416930044325D-03, + $ 2.512236854563D-03, + $ 2.496644054553D-03, + $ 2.236607760438D-03 / + DATA (D(j,17),j=1,6) + $ / 1.842866472905D-03, + $ 1.802658934377D-03, + $ 1.849830560444D-03, + $ 1.713904507107D-03, + $ 1.555213603397D-03, + $ 1.802239128009D-03 / + DATA (D(j,18),j=1,9) + $ / 1.127089094672D-03, + $ 1.345753760911D-03, + $ 1.424957283317D-03, + $ 1.261523341238D-03, + $ 1.392547106053D-03, + $ 1.418761677878D-03, + $ 1.338366684480D-03, + $ 1.393700862676D-03, + $ 1.415914757467D-03 / + DATA (D(j,19),j=1,12) + $ / 8.436884500902D-04, + $ 1.075255720449D-03, + $ 1.108577236864D-03, + $ 9.566475323783D-04, + $ 1.080663250717D-03, + $ 1.126797131196D-03, + $ 1.022568715358D-03, + $ 1.108960267713D-03, + $ 1.122790653436D-03, + $ 1.032401847117D-03, + $ 1.107249382284D-03, + $ 1.121780048520D-03 / + DATA (D(j,20),j=1,16) + $ / 6.485778453163D-04, + $ 7.435030910982D-04, + $ 7.998527891839D-04, + $ 8.101731497468D-04, + $ 8.483389574594D-04, + $ 8.556299257312D-04, + $ 8.803208679738D-04, + $ 8.811048182426D-04, + $ 8.850282341265D-04, + $ 9.021342299041D-04, + $ 9.010091677105D-04, + $ 9.022692938427D-04, + $ 9.158016174693D-04, + $ 9.131578003189D-04, + $ 9.107813579483D-04, + $ 9.105760258970D-04 / + DATA (D(j,21),j=1,20) + $ / 7.538257859801D-04, + $ 7.483517247053D-04, + $ 7.371763661112D-04, + $ 7.183448895757D-04, + $ 6.895815529822D-04, + $ 6.480105801793D-04, + $ 5.897558896595D-04, + $ 5.095708849247D-04, + $ 7.536906428910D-04, + $ 7.472505965575D-04, + $ 7.343017132280D-04, + $ 7.130871582177D-04, + $ 6.817022032113D-04, + $ 6.380941145604D-04, + $ 7.550381377920D-04, + $ 7.478646640145D-04, + $ 7.335918720601D-04, + $ 7.110120527658D-04, + $ 7.571363978690D-04, + $ 7.489908329079D-04 / + DATA (D(j,22),j=1,25) + $ / 4.078626431856D-04, + $ 4.759933057813D-04, + $ 5.268151186413D-04, + $ 5.643048560507D-04, + $ 5.914501076613D-04, + $ 6.104561257874D-04, + $ 6.230252860708D-04, + $ 6.305618761761D-04, + $ 6.343092767598D-04, + $ 5.176268945738D-04, + $ 5.564840313314D-04, + $ 5.856426671039D-04, + $ 6.066386925777D-04, + $ 6.208824962234D-04, + $ 6.296314297823D-04, + $ 6.340423756792D-04, + $ 5.829627677107D-04, + $ 6.048693376081D-04, + $ 6.202362317732D-04, + $ 6.299005328404D-04, + $ 6.347722390609D-04, + $ 6.203778981239D-04, + $ 6.308414671240D-04, + $ 6.362706466959D-04, + $ 6.375414170333D-04 / + DATA (D(j,23),j=1,30) + $ / 3.316041873197D-04, + $ 3.899113567154D-04, + $ 4.343343327201D-04, + $ 4.679415262319D-04, + $ 4.930847981631D-04, + $ 5.115031867540D-04, + $ 5.245217148457D-04, + $ 5.332041499895D-04, + $ 5.384583126022D-04, + $ 5.411067210799D-04, + $ 4.259797391469D-04, + $ 4.604931368460D-04, + $ 4.871814878255D-04, + $ 5.072242910075D-04, + $ 5.217069845235D-04, + $ 5.315785966280D-04, + $ 5.376833708759D-04, + $ 5.408032092070D-04, + $ 4.842744917905D-04, + $ 5.048926076188D-04, + $ 5.202607980478D-04, + $ 5.309932388326D-04, + $ 5.377419770895D-04, + $ 5.411696331678D-04, + $ 5.197996293282D-04, + $ 5.311120836623D-04, + $ 5.384309319957D-04, + $ 5.421859504052D-04, + $ 5.390948355046D-04, + $ 5.433312705028D-04 / + DATA (D(j,24),j=1,36) + $ / 2.733362800523D-04, + $ 3.235485368464D-04, + $ 3.624908726013D-04, + $ 3.925540070713D-04, + $ 4.156129781116D-04, + $ 4.330644984623D-04, + $ 4.459677725921D-04, + $ 4.551593004457D-04, + $ 4.613341462750D-04, + $ 4.651019618270D-04, + $ 4.670249536101D-04, + $ 3.549555576442D-04, + $ 3.856108245249D-04, + $ 4.098622845757D-04, + $ 4.286328604269D-04, + $ 4.427802198994D-04, + $ 4.530473511489D-04, + $ 4.600805475703D-04, + $ 4.644599059958D-04, + $ 4.667274455713D-04, + $ 4.069360518020D-04, + $ 4.260442819919D-04, + $ 4.408678508029D-04, + $ 4.518748115549D-04, + $ 4.595564875375D-04, + $ 4.643988774316D-04, + $ 4.668827491647D-04, + $ 4.400541823742D-04, + $ 4.514512890194D-04, + $ 4.596198627348D-04, + $ 4.648659016802D-04, + $ 4.675502017158D-04, + $ 4.598494476456D-04, + $ 4.654916955152D-04, + $ 4.684709779505D-04, + $ 4.691445539107D-04 / + DATA (D(j,25),j=1,42) + $ / 2.279907527706D-04, + $ 2.715205490579D-04, + $ 3.057917896704D-04, + $ 3.326913052453D-04, + $ 3.537334711890D-04, + $ 3.700567500783D-04, + $ 3.825245372589D-04, + $ 3.918125171518D-04, + $ 3.984720419938D-04, + $ 4.029746003338D-04, + $ 4.057428632157D-04, + $ 4.071719274115D-04, + $ 2.990236950664D-04, + $ 3.262951734213D-04, + $ 3.482634608242D-04, + $ 3.656596681701D-04, + $ 3.791740467794D-04, + $ 3.894034450157D-04, + $ 3.968600245508D-04, + $ 4.019931351420D-04, + $ 4.052108801279D-04, + $ 4.068978613941D-04, + $ 3.454275351320D-04, + $ 3.629963537008D-04, + $ 3.770187233890D-04, + $ 3.878608613694D-04, + $ 3.959065270221D-04, + $ 4.015286975464D-04, + $ 4.050866785615D-04, + $ 4.069320185052D-04, + $ 3.760120964063D-04, + $ 3.870969564418D-04, + $ 3.955287790534D-04, + $ 4.015361911303D-04, + $ 4.053836986720D-04, + $ 4.073578673299D-04, + $ 3.954628379231D-04, + $ 4.017645508848D-04, + $ 4.059030348651D-04, + $ 4.080565809485D-04, + $ 4.063018753665D-04, + $ 4.087191292800D-04 / + DATA (D(j,26),j=1,49) + $ / 1.921921305789D-04, + $ 2.301458216496D-04, + $ 2.604248549523D-04, + $ 2.845275425871D-04, + $ 3.036870897975D-04, + $ 3.188414832298D-04, + $ 3.307046414722D-04, + $ 3.398330969031D-04, + $ 3.466757899705D-04, + $ 3.516095923230D-04, + $ 3.549645184048D-04, + $ 3.570415969441D-04, + $ 3.581251798496D-04, + $ 2.543491329913D-04, + $ 2.786711051331D-04, + $ 2.985552361084D-04, + $ 3.145867929154D-04, + $ 3.273290662068D-04, + $ 3.372705511944D-04, + $ 3.448274437852D-04, + $ 3.503592783049D-04, + $ 3.541854792663D-04, + $ 3.565995517909D-04, + $ 3.578802078303D-04, + $ 2.958644592861D-04, + $ 3.119548129117D-04, + $ 3.250745225006D-04, + $ 3.355153415935D-04, + $ 3.435847568549D-04, + $ 3.495786831622D-04, + $ 3.537767805535D-04, + $ 3.564459815421D-04, + $ 3.578464061225D-04, + $ 3.239748762836D-04, + $ 3.345491784174D-04, + $ 3.429126177302D-04, + $ 3.492420343097D-04, + $ 3.537399050235D-04, + $ 3.566209152659D-04, + $ 3.581084321920D-04, + $ 3.426522117592D-04, + $ 3.491848770121D-04, + $ 3.539318235231D-04, + $ 3.570231438459D-04, + $ 3.586207335052D-04, + $ 3.541196205164D-04, + $ 3.574296911574D-04, + $ 3.591993279819D-04, + $ 3.595855034662D-04 / + DATA (D(j,27),j=1,56) + $ / 1.635219535870D-04, + $ 1.968109917696D-04, + $ 2.236754342250D-04, + $ 2.453186687017D-04, + $ 2.627551791581D-04, + $ 2.767654860152D-04, + $ 2.879467027766D-04, + $ 2.967639918919D-04, + $ 3.035900684660D-04, + $ 3.087338237298D-04, + $ 3.124608838860D-04, + $ 3.150084294227D-04, + $ 3.165958398598D-04, + $ 3.174320440957D-04, + $ 2.182188909813D-04, + $ 2.399727933921D-04, + $ 2.579796133515D-04, + $ 2.727114052624D-04, + $ 2.846327656281D-04, + $ 2.941491102051D-04, + $ 3.016049492136D-04, + $ 3.072949726176D-04, + $ 3.114768142886D-04, + $ 3.143823673666D-04, + $ 3.162269764662D-04, + $ 3.172164663760D-04, + $ 2.554575398967D-04, + $ 2.701704069136D-04, + $ 2.823693413469D-04, + $ 2.922898463214D-04, + $ 3.001829062162D-04, + $ 3.062890864543D-04, + $ 3.108328279265D-04, + $ 3.140243146201D-04, + $ 3.160638030977D-04, + $ 3.171462882206D-04, + $ 2.812388416032D-04, + $ 2.912137500288D-04, + $ 2.993241256502D-04, + $ 3.057101738984D-04, + $ 3.105319326251D-04, + $ 3.139565514428D-04, + $ 3.161543006806D-04, + $ 3.172985960613D-04, + $ 2.989400336901D-04, + $ 3.054555883948D-04, + $ 3.104764960808D-04, + $ 3.141015825978D-04, + $ 3.164520621160D-04, + $ 3.176652305912D-04, + $ 3.105097161024D-04, + $ 3.143014117891D-04, + $ 3.168172866287D-04, + $ 3.181401865571D-04, + $ 3.170663659156D-04, + $ 3.185447944626D-04 / + DATA (D(j,28),j=1,64) + $ / 1.403063340168D-04, + $ 1.696504125939D-04, + $ 1.935787242745D-04, + $ 2.130614510522D-04, + $ 2.289381265931D-04, + $ 2.418630292816D-04, + $ 2.523400495631D-04, + $ 2.607623973450D-04, + $ 2.674441032689D-04, + $ 2.726432360343D-04, + $ 2.765787685925D-04, + $ 2.794428690642D-04, + $ 2.814099002063D-04, + $ 2.826429531579D-04, + $ 2.832983542551D-04, + $ 1.886695565285D-04, + $ 2.081867882748D-04, + $ 2.245148680601D-04, + $ 2.380370491512D-04, + $ 2.491398041852D-04, + $ 2.581632405881D-04, + $ 2.653965506227D-04, + $ 2.710857216747D-04, + $ 2.754434093904D-04, + $ 2.786579932519D-04, + $ 2.809011080679D-04, + $ 2.823336184561D-04, + $ 2.831101175806D-04, + $ 2.221679970355D-04, + $ 2.356185734271D-04, + $ 2.469228344806D-04, + $ 2.562726348642D-04, + $ 2.638756726753D-04, + $ 2.699311157391D-04, + $ 2.746233268404D-04, + $ 2.781225674455D-04, + $ 2.805881254046D-04, + $ 2.821719877005D-04, + $ 2.830222502333D-04, + $ 2.457995956745D-04, + $ 2.551474407504D-04, + $ 2.629065335195D-04, + $ 2.691900449925D-04, + $ 2.741275485754D-04, + $ 2.778530970123D-04, + $ 2.805010567647D-04, + $ 2.822055834031D-04, + $ 2.831016901243D-04, + $ 2.624474901132D-04, + $ 2.688034163039D-04, + $ 2.738932751288D-04, + $ 2.777944791243D-04, + $ 2.806011661661D-04, + $ 2.824181456597D-04, + $ 2.833585216578D-04, + $ 2.738165236963D-04, + $ 2.778365208203D-04, + $ 2.807852940419D-04, + $ 2.827245949675D-04, + $ 2.837342344830D-04, + $ 2.809233907611D-04, + $ 2.829930809743D-04, + $ 2.841097874111D-04, + $ 2.843455206009D-04 / + DATA (D(j,29),j=1,72) + $ / 1.212879733669D-04, + $ 1.472872881271D-04, + $ 1.686846601011D-04, + $ 1.862698414660D-04, + $ 2.007430956992D-04, + $ 2.126568125395D-04, + $ 2.224394603372D-04, + $ 2.304264522673D-04, + $ 2.368854288424D-04, + $ 2.420352089462D-04, + $ 2.460597113081D-04, + $ 2.491181912258D-04, + $ 2.513528194206D-04, + $ 2.528943096693D-04, + $ 2.538660368488D-04, + $ 2.543868648299D-04, + $ 1.642595537825D-04, + $ 1.818246659849D-04, + $ 1.966565649492D-04, + $ 2.090677905658D-04, + $ 2.193820409511D-04, + $ 2.278870827662D-04, + $ 2.348283192282D-04, + $ 2.404139755581D-04, + $ 2.448227407761D-04, + $ 2.482110455593D-04, + $ 2.507192397774D-04, + $ 2.524765968535D-04, + $ 2.536052388539D-04, + $ 2.542230588033D-04, + $ 1.944817013048D-04, + $ 2.067862362747D-04, + $ 2.172440734649D-04, + $ 2.260125991723D-04, + $ 2.332655008690D-04, + $ 2.391699681532D-04, + $ 2.438801528274D-04, + $ 2.475370504261D-04, + $ 2.502707235641D-04, + $ 2.522031701054D-04, + $ 2.534511269979D-04, + $ 2.541284914955D-04, + $ 2.161509250688D-04, + $ 2.248778513438D-04, + $ 2.322388803405D-04, + $ 2.383265471001D-04, + $ 2.432476675020D-04, + $ 2.471122223751D-04, + $ 2.500291752487D-04, + $ 2.521055942765D-04, + $ 2.534472785576D-04, + $ 2.541599713080D-04, + $ 2.317380975863D-04, + $ 2.378550733720D-04, + $ 2.428884456739D-04, + $ 2.469002655757D-04, + $ 2.499657574266D-04, + $ 2.521676168486D-04, + $ 2.535935662645D-04, + $ 2.543356743363D-04, + $ 2.427353285202D-04, + $ 2.468258039744D-04, + $ 2.500060956440D-04, + $ 2.523238365421D-04, + $ 2.538399260253D-04, + $ 2.546255927268D-04, + $ 2.500583360048D-04, + $ 2.524777638260D-04, + $ 2.540951193861D-04, + $ 2.549524085027D-04, + $ 2.542569507009D-04, + $ 2.552114127580D-04 / + DATA (D(j,30),j=1,81) + $ / 1.006006990267D-04, + $ 1.227676689636D-04, + $ 1.467864280270D-04, + $ 1.644178912101D-04, + $ 1.777664890719D-04, + $ 1.884825664517D-04, + $ 1.973269246454D-04, + $ 2.046767775855D-04, + $ 2.107600125918D-04, + $ 2.157416362267D-04, + $ 2.197557816921D-04, + $ 2.229192611835D-04, + $ 2.253385110213D-04, + $ 2.271137107549D-04, + $ 2.283414092918D-04, + $ 2.291161673130D-04, + $ 2.295313908577D-04, + $ 1.438204721359D-04, + $ 1.607738025495D-04, + $ 1.741483853528D-04, + $ 1.851918467519D-04, + $ 1.944628638071D-04, + $ 2.022495446275D-04, + $ 2.087462382439D-04, + $ 2.141074754818D-04, + $ 2.184640913748D-04, + $ 2.219309165220D-04, + $ 2.246123118341D-04, + $ 2.266062766915D-04, + $ 2.280072952231D-04, + $ 2.289082025203D-04, + $ 2.294012695120D-04, + $ 1.722434488737D-04, + $ 1.830237421455D-04, + $ 1.923855349998D-04, + $ 2.004067861936D-04, + $ 2.071817297354D-04, + $ 2.128250834102D-04, + $ 2.174513719440D-04, + $ 2.211661839150D-04, + $ 2.240665257813D-04, + $ 2.262439516633D-04, + $ 2.277874557232D-04, + $ 2.287854314455D-04, + $ 2.293268499616D-04, + $ 1.912628201530D-04, + $ 1.992499672239D-04, + $ 2.061275533454D-04, + $ 2.119318215969D-04, + $ 2.167416581883D-04, + $ 2.206430730517D-04, + $ 2.237186938700D-04, + $ 2.260480075033D-04, + $ 2.277098884559D-04, + $ 2.287845715110D-04, + $ 2.293547268236D-04, + $ 2.056073839853D-04, + $ 2.114235865832D-04, + $ 2.163175629771D-04, + $ 2.203392158112D-04, + $ 2.235473176848D-04, + $ 2.260024141501D-04, + $ 2.277675929329D-04, + $ 2.289102112285D-04, + $ 2.295027954625D-04, + $ 2.161281589880D-04, + $ 2.201980477395D-04, + $ 2.234952066593D-04, + $ 2.260540098521D-04, + $ 2.279157981900D-04, + $ 2.291296918566D-04, + $ 2.297533752537D-04, + $ 2.234927356466D-04, + $ 2.261288012985D-04, + $ 2.280818160924D-04, + $ 2.293773295180D-04, + $ 2.300528767339D-04, + $ 2.281893855066D-04, + $ 2.295720444841D-04, + $ 2.303227649027D-04, + $ 2.304831913227D-04 / + DATA (D(j,31),j=1,90) + $ / 9.316684484676D-05, + $ 1.116193688683D-04, + $ 1.298623551559D-04, + $ 1.450236832456D-04, + $ 1.572719958150D-04, + $ 1.673234785867D-04, + $ 1.756860118725D-04, + $ 1.826776290439D-04, + $ 1.885116347993D-04, + $ 1.933457860171D-04, + $ 1.973060671902D-04, + $ 2.004987099616D-04, + $ 2.030170909281D-04, + $ 2.049461460119D-04, + $ 2.063653565200D-04, + $ 2.073507927381D-04, + $ 2.079764593256D-04, + $ 2.083150534969D-04, + $ 1.262715121591D-04, + $ 1.414386128546D-04, + $ 1.538740401314D-04, + $ 1.642434942331D-04, + $ 1.729790609237D-04, + $ 1.803505190261D-04, + $ 1.865475350080D-04, + $ 1.917182669679D-04, + $ 1.959851709034D-04, + $ 1.994529548118D-04, + $ 2.022138911147D-04, + $ 2.043518024209D-04, + $ 2.059450313018D-04, + $ 2.070685715318D-04, + $ 2.077955310694D-04, + $ 2.081980387825D-04, + $ 1.521318610378D-04, + $ 1.622772720186D-04, + $ 1.710498139421D-04, + $ 1.785911149449D-04, + $ 1.850125313688D-04, + $ 1.904229703933D-04, + $ 1.949259956122D-04, + $ 1.986161545364D-04, + $ 2.015790585641D-04, + $ 2.038934198707D-04, + $ 2.056334060538D-04, + $ 2.068705959462D-04, + $ 2.076753906106D-04, + $ 2.081179391735D-04, + $ 1.700345216229D-04, + $ 1.774906779990D-04, + $ 1.839659377003D-04, + $ 1.894987462975D-04, + $ 1.941548809453D-04, + $ 1.980078427252D-04, + $ 2.011296284744D-04, + $ 2.035888456967D-04, + $ 2.054516325352D-04, + $ 2.067831033093D-04, + $ 2.076485320285D-04, + $ 2.081141439525D-04, + $ 1.834383015469D-04, + $ 1.889540591778D-04, + $ 1.936677023597D-04, + $ 1.976176495067D-04, + $ 2.008536004561D-04, + $ 2.034280351712D-04, + $ 2.053944466028D-04, + $ 2.068077642882D-04, + $ 2.077250949662D-04, + $ 2.082062440705D-04, + $ 1.934374486547D-04, + $ 1.974107010484D-04, + $ 2.007129290389D-04, + $ 2.033736947471D-04, + $ 2.054287125902D-04, + $ 2.069184936819D-04, + $ 2.078883689809D-04, + $ 2.083886366116D-04, + $ 2.006593275471D-04, + $ 2.033728426135D-04, + $ 2.055008781378D-04, + $ 2.070651783519D-04, + $ 2.080953335094D-04, + $ 2.086284998989D-04, + $ 2.055549387645D-04, + $ 2.071871850268D-04, + $ 2.082856600432D-04, + $ 2.088705858819D-04, + $ 2.083995867536D-04, + $ 2.090509712890D-04 / + DATA T(1,5) + $ / 0.8181818181818181818181818181818182D+00 / + DATA T(1,6) + $ / 5.384615384615D-01 / + DATA (T(j,7),j=1,2) + $ / 0.7267874717859796704165651796807734D+00, + $ 0.3574502702964873455463383113455231D-01 / + DATA (T(j,8),j=1,3) + $ / 0.9314644031018293303224605304347612D+00, + $ 0.6868596818254220443790837922198527D+00, + $ 0.4663755190139312657722805586200992D-01 / + DATA (T(j,9),j=1,3) + $ / 0.9504078675707184426846816938057038D+00, + $ 0.6513939748997038757216963384831041D+00, + $ 0.8485503877651973792968123939638137D-01 / + DATA (T(j,10),j=1,3) + $ / 8.698222012652D-01, + $ 9.047678687586D-02, + $ 6.269402078753D-01 / + DATA (T(j,11),j=1,4) + $ / 0.6044957060804405750447234008859784D+00, + $ 0.8326728518658924875446408288494448D+00, + $ 0.9871975115337203051106504992126892D-01, + $ 0.9662345478896000071306665444955087D+00 / + DATA (T(j,12),j=1,5) + $ / 5.964306905285D-01, + $ 8.729497118674D-01, + $ 2.505958825460D-02, + $ 1.321218431685D-01, + $ 9.967380323911D-01 / + DATA (T(j,13),j=1,5) + $ / 8.944445076768D-03, + $ 9.794958119190D-01, + $ 5.680244067058D-01, + $ 7.851702770073D-01, + $ 1.234223195584D-01 / + DATA (T(j,14),j=1,6) + $ / 0.1670263452397559527894216050589478D-01, + $ 0.1376663615296993115240758106286862D+00, + $ 0.5527209402223704445129158599195226D+00, + $ 0.7528054592119942363108765505527784D+00, + $ 0.9014635004999312167764818860483434D+00, + $ 0.9814976282327591629905429780488349D+00 / + DATA (T(j,15),j=1,6) + $ / 5.945454002988D-04, + $ 5.402203703739D-01, + $ 9.256923187369D-01, + $ 3.940277055740D-02, + $ 7.396031168627D-01, + $ 1.553935521769D-01 / + DATA (T(j,16),j=1,7) + $ / 4.521867205820D-02, + $ 9.369991395852D-01, + $ 5.169847287690D-01, + $ 1.662296171180D-01, + $ 8.362605039899D-01, + $ 9.885448198023D-01, + $ 6.915326150206D-01 / + DATA (T(j,17),j=1,9) + $ / 8.499071157004D-03, + $ 7.309241451287D-02, + $ 1.878129101389D-01, + $ 4.910765962311D-01, + $ 6.445470516095D-01, + $ 7.798280397298D-01, + $ 8.862606172978D-01, + $ 9.574242528006D-01, + $ 9.925701118262D-01 / + DATA (T(j,18),j=1,10) + $ / 9.948240702572D-01, + $ 9.698305546361D-01, + $ 9.178342725293D-01, + $ 8.378069504767D-01, + $ 7.325681115488D-01, + $ 6.078094018620D-01, + $ 4.714805969587D-01, + $ 2.045860732578D-01, + $ 9.766956607994D-02, + $ 2.564988139436D-02 / + DATA (T(j,19),j=1,12) + $ / 9.963140927997D-01, + $ 9.778900314101D-01, + $ 9.387482592540D-01, + $ 8.772246746062D-01, + $ 7.943585455913D-01, + $ 6.932173043199D-01, + $ 5.784863558578D-01, + $ 4.561664690726D-01, + $ 2.179572378274D-01, + $ 1.187585706869D-01, + $ 4.492456248653D-02, + $ 5.130054883064D-03 / + DATA (T(j,20),j=1,13) + $ / 9.972432661185D-01, + $ 9.832918591320D-01, + $ 9.531160121935D-01, + $ 9.048709833904D-01, + $ 8.387022528272D-01, + $ 7.562335791706D-01, + $ 6.602760541723D-01, + $ 5.546219829385D-01, + $ 4.438787406634D-01, + $ 2.288483219154D-01, + $ 1.367748697861D-01, + $ 6.379865467742D-02, + $ 1.646761018263D-02 / + DATA (T(j,21),j=1,15) + $ / 9.979143363622D-01, + $ 9.870821836647D-01, + $ 9.633179740561D-01, + $ 9.248083829058D-01, + $ 8.712377374379D-01, + $ 8.034039688176D-01, + $ 7.230000705325D-01, + $ 6.324652733202D-01, + $ 5.348679212522D-01, + $ 4.338074285872D-01, + $ 2.378818655932D-01, + $ 1.522209580433D-01, + $ 8.135995958492D-02, + $ 3.030214670670D-02, + $ 3.428730539433D-03 / + DATA (T(j,22),j=1,16) + $ / 9.983630237732D-01, + $ 9.897967765640D-01, + $ 9.707567294011D-01, + $ 9.395403165681D-01, + $ 8.956079044098D-01, + $ 8.392773092892D-01, + $ 7.715552422867D-01, + $ 6.940259701211D-01, + $ 6.087661259570D-01, + $ 5.182736014735D-01, + $ 4.254066807507D-01, + $ 2.454906841822D-01, + $ 1.655487699575D-01, + $ 9.735443800302D-02, + $ 4.479239363750D-02, + $ 1.145055801973D-02 / + DATA (T(j,23),j=1,18) + $ / 9.987088311582D-01, + $ 9.918097335390D-01, + $ 9.763133912218D-01, + $ 9.506598648348D-01, + $ 9.142055993122D-01, + $ 8.669840470267D-01, + $ 8.095706458671D-01, + $ 7.429956925500D-01, + $ 6.686799248593D-01, + $ 5.883818288042D-01, + $ 5.041522063181D-01, + $ 4.182948169149D-01, + $ 2.519844086135D-01, + $ 1.771329459727D-01, + $ 1.117955803473D-01, + $ 5.903799592608D-02, + $ 2.178402115775D-02, + $ 2.451992741952D-03 / + DATA (T(j,24),j=1,19) + $ / 9.989511574237D-01, + $ 9.933204314931D-01, + $ 9.805438375683D-01, + $ 9.592074206194D-01, + $ 9.286352335000D-01, + $ 8.886937286268D-01, + $ 8.396828658238D-01, + $ 7.822665416652D-01, + $ 7.174223164050D-01, + $ 6.464012407924D-01, + $ 5.706935220112D-01, + $ 4.919983454862D-01, + $ 4.121975439374D-01, + $ 2.575898262997D-01, + $ 1.872756753374D-01, + $ 1.247993889749D-01, + $ 7.261765804749D-02, + $ 3.312137636649D-02, + $ 8.417236823685D-03 / + DATA (T(j,25),j=1,21) + $ / 9.991466902796D-01, + $ 9.944855716680D-01, + $ 9.838234632028D-01, + $ 9.658860301760D-01, + $ 9.399993362096D-01, + $ 9.059324566313D-01, + $ 8.638072400724D-01, + $ 8.140411316291D-01, + $ 7.573067651943D-01, + $ 6.945004533758D-01, + $ 6.267156986940D-01, + $ 5.552199298894D-01, + $ 4.814338171375D-01, + $ 4.069131375459D-01, + $ 2.624764638322D-01, + $ 1.962187240256D-01, + $ 1.365132316146D-01, + $ 8.535636714473D-02, + $ 4.471687997947D-02, + $ 1.640096644131D-02, + $ 1.840045732112D-03 / + DATA (T(j,26),j=1,22) + $ / 9.992885189311D-01, + $ 9.953915828809D-01, + $ 9.864042520502D-01, + $ 9.711803952656D-01, + $ 9.490701367673D-01, + $ 9.197889831582D-01, + $ 8.833431744669D-01, + $ 8.399822331704D-01, + $ 7.901657878871D-01, + $ 7.345382177116D-01, + $ 6.739077428303D-01, + $ 6.092282380884D-01, + $ 5.415829837787D-01, + $ 4.721701147608D-01, + $ 4.022898149774D-01, + $ 2.667735478837D-01, + $ 2.041557967831D-01, + $ 1.470855543505D-01, + $ 9.720572111608D-02, + $ 5.615089573608D-02, + $ 2.546158767116D-02, + $ 6.445772776470D-03 / + DATA (T(j,27),j=1,24) + $ / 9.994073420632D-01, + $ 9.961123635856D-01, + $ 9.884641646671D-01, + $ 9.754318546307D-01, + $ 9.563979477620D-01, + $ 9.310509351946D-01, + $ 8.993221205576D-01, + $ 8.613454952223D-01, + $ 8.174299827256D-01, + $ 7.680385836004D-01, + $ 7.137714962065D-01, + $ 6.553516400609D-01, + $ 5.936117744635D-01, + $ 5.294828626297D-01, + $ 4.639836046032D-01, + $ 3.982111946111D-01, + $ 2.705812594860D-01, + $ 2.112428880825D-01, + $ 1.566537859453D-01, + $ 1.081813807457D-01, + $ 6.719449812399D-02, + $ 3.500727310883D-02, + $ 1.278754655613D-02, + $ 1.431532615062D-03 / + DATA (T(j,28),j=1,25) + $ / 9.994957296951D-01, + $ 9.966883326993D-01, + $ 9.901273792384D-01, + $ 9.788850620034D-01, + $ 9.623820738475D-01, + $ 9.402970090556D-01, + $ 9.125132210219D-01, + $ 8.790847449096D-01, + $ 8.402127700885D-01, + $ 7.962281729465D-01, + $ 7.475776139174D-01, + $ 6.948117962164D-01, + $ 6.385751144432D-01, + $ 5.795963018215D-01, + $ 5.186799213004D-01, + $ 4.566986870675D-01, + $ 3.945866619032D-01, + $ 2.739783714988D-01, + $ 2.176064094230D-01, + $ 1.653403045802D-01, + $ 1.183298694951D-01, + $ 7.773098966363D-02, + $ 4.466798054937D-02, + $ 2.017192474359D-02, + $ 5.093170320417D-03 / + DATA (T(j,29),j=1,27) + $ / 9.995719869698D-01, + $ 9.971576600497D-01, + $ 9.914856530125D-01, + $ 9.817192019176D-01, + $ 9.673171465902D-01, + $ 9.479584191551D-01, + $ 9.234964401467D-01, + $ 8.939297875880D-01, + $ 8.593820093211D-01, + $ 8.200867705184D-01, + $ 7.763761965513D-01, + $ 7.286711767696D-01, + $ 6.774729173835D-01, + $ 6.233553492065D-01, + $ 5.669581965619D-01, + $ 5.089806415522D-01, + $ 4.501755926475D-01, + $ 3.913445897309D-01, + $ 2.770276760350D-01, + $ 2.233495933818D-01, + $ 1.732520657435D-01, + $ 1.277108517503D-01, + $ 8.770980631329D-02, + $ 5.421499904934D-02, + $ 2.813244088150D-02, + $ 1.024671752643D-02, + $ 1.145352939215D-03 / + DATA (T(j,30),j=1,28) + $ / 9.989088743731D-01, + $ 9.962102993790D-01, + $ 9.917073393298D-01, + $ 9.837857998144D-01, + $ 9.713578655261D-01, + $ 9.542943302118D-01, + $ 9.325833410688D-01, + $ 9.062484628251D-01, + $ 8.753788404822D-01, + $ 8.401387270275D-01, + $ 8.007691896507D-01, + $ 7.575863866917D-01, + $ 7.109771117958D-01, + $ 6.613927586878D-01, + $ 6.093429313239D-01, + $ 5.553894658468D-01, + $ 5.001411954546D-01, + $ 4.442495352346D-01, + $ 3.884048318656D-01, + $ 2.797945214663D-01, + $ 2.285783449909D-01, + $ 1.805015075513D-01, + $ 1.364013229385D-01, + $ 9.712474739578D-02, + $ 6.350928432754D-02, + $ 3.635223834954D-02, + $ 1.636637023025D-02, + $ 4.124219647904D-03 / + DATA (T(j,31),j=1,30) + $ / 9.989389971209D-01, + $ 9.971766766769D-01, + $ 9.932210680541D-01, + $ 9.858774895456D-01, + $ 9.747806632069D-01, + $ 9.596648815557D-01, + $ 9.403911068227D-01, + $ 9.169172562840D-01, + $ 8.892819476318D-01, + $ 8.575967401872D-01, + $ 8.220412264133D-01, + $ 7.828591148688D-01, + $ 7.403541401852D-01, + $ 6.948854820542D-01, + $ 6.468629521677D-01, + $ 5.967423110144D-01, + $ 5.450209571873D-01, + $ 4.922340999168D-01, + $ 4.389514398161D-01, + $ 3.857743293940D-01, + $ 2.822860252999D-01, + $ 2.333147039100D-01, + $ 1.871234394479D-01, + $ 1.444334326043D-01, + $ 1.059750740154D-01, + $ 7.247445615933D-02, + $ 4.463176524570D-02, + $ 2.308962476585D-02, + $ 8.391804478010D-03, + $ 9.369553857840D-04 / + DATA V(1,4) + $ / 0.1666666666666666666666666666666667D+00 / + DATA V(1,6) + $ / 9.230769230769D-02 / + DATA V(1,7) + $ / 0.1204416503145642398318048555452501D+00 / + DATA V(1,8) + $ / 0.1764705882352941176470588235294118D+00 / + DATA V(1,10) + $ / 6.365787851418D-02 / + DATA V(1,11) + $ / 0.1052631578947368421052631578947368D+00 / + DATA (V(j,12),j=1,2) + $ / 2.241341590046D-01, + $ 1.099238120099D-01 / + DATA V(1,13) + $ / 2.000000000000D-01 / + DATA (V(j,14),j=1,2) + $ / 0.2200933352980389748216629900695196D+00, + $ 0.6502727546573595539690409835852654D-01 / + DATA (V(j,15),j=1,2) + $ / 3.596678808994D-02, + $ 1.235753913415D-01 / + DATA (V(j,16),j=1,2) + $ / 1.729411966868D-01, + $ 4.225960886354D-02 / + DATA (V(j,17),j=1,3) + $ / 2.341637248281D-01, + $ 1.324832577106D-01, + $ 2.886374289129D-02 / + DATA (V(j,18),j=1,3) + $ / 2.049596194512D-02, + $ 1.017279217943D-01, + $ 2.036494032906D-01 / + DATA (V(j,19),j=1,4) + $ / 1.506003684306D-02, + $ 7.900261587096D-02, + $ 1.719853162752D-01, + $ 2.402517778395D-01 / + DATA (V(j,20),j=1,4) + $ / 1.136778532904D-02, + $ 6.222580539453D-02, + $ 1.438013602306D-01, + $ 2.193546368679D-01 / + DATA (V(j,21),j=1,5) + $ / 8.792305136058D-03, + $ 4.971678820596D-02, + $ 1.201226934566D-01, + $ 1.951924693303D-01, + $ 2.434103199047D-01 / + DATA (V(j,22),j=1,5) + $ / 6.931793227193D-03, + $ 4.026427008452D-02, + $ 1.006819324273D-01, + $ 1.715283250278D-01, + $ 2.283217882342D-01 / + DATA (V(j,23),j=1,6) + $ / 5.562298027336D-03, + $ 3.301750717439D-02, + $ 8.484487674046D-02, + $ 1.499289480598D-01, + $ 2.096284259050D-01, + $ 2.452528151503D-01 / + DATA (V(j,24),j=1,6) + $ / 4.527512122481D-03, + $ 2.738571398249D-02, + $ 7.194952348015D-02, + $ 1.308804820581D-01, + $ 1.901173218958D-01, + $ 2.338875244150D-01 / + DATA (V(j,25),j=1,7) + $ / 3.735731627098D-03, + $ 2.295065371381D-02, + $ 6.141474850635D-02, + $ 1.143710170433D-01, + $ 1.712602015573D-01, + $ 2.191192968469D-01, + $ 2.464193318434D-01 / + DATA (V(j,26),j=1,7) + $ / 3.116273598316D-03, + $ 1.941497033326D-02, + $ 5.276331953232D-02, + $ 1.001818528622D-01, + $ 1.537591183728D-01, + $ 2.029938620347D-01, + $ 2.375671797837D-01 / + DATA (V(j,27),j=1,8) + $ / 2.627354807340D-03, + $ 1.656404962657D-02, + $ 4.561529461067D-02, + $ 8.802772716296D-02, + $ 1.378848650427D-01, + $ 1.867467953993D-01, + $ 2.256575483187D-01, + $ 2.472038245618D-01 / + DATA (V(j,28),j=1,8) + $ / 2.234379876148D-03, + $ 1.424164112360D-02, + $ 3.967132880296D-02, + $ 7.762064909155D-02, + $ 1.236763051633D-01, + $ 1.710839672061D-01, + $ 2.122104053470D-01, + $ 2.401218883665D-01 / + DATA (V(j,29),j=1,9) + $ / 1.916700390235D-03, + $ 1.233154590152D-02, + $ 3.469648744997D-02, + $ 6.869692636008D-02, + $ 1.110548585874D-01, + $ 1.563770127604D-01, + $ 1.982285434988D-01, + $ 2.303388051827D-01, + $ 2.477564007390D-01 / + DATA (V(j,30),j=1,9) + $ / 2.107454820561D-03, + $ 1.088942170828D-02, + $ 3.046535458878D-02, + $ 6.119972584598D-02, + $ 1.000546103726D-01, + $ 1.428810642988D-01, + $ 1.843759068265D-01, + $ 2.190027552378D-01, + $ 2.419625136213D-01 / + DATA (V(j,31),j=1,10) + $ / 1.472668018817D-03, + $ 9.580098341667D-03, + $ 2.697810682946D-02, + $ 5.452463307450D-02, + $ 9.015147652015D-02, + $ 1.304525252537D-01, + $ 1.709907279210D-01, + $ 2.069300631045D-01, + $ 2.337963076105D-01, + $ 2.481595158077D-01 / + DATA (S(i,1,9),i=1,2) + $ / 1.403553811713D-01, + $ 4.493328323270D-01 / + DATA (S(i,1,10),i=1,2) + $ / 4.990453161796D-01, + $ 1.446630744325D-01 / + DATA (S(i,1,11),i=1,2) + $ / 1.590417105384D-01, + $ 8.360360154825D-01 / + DATA (S(i,1,12),i=1,2) + $ / 2.272181808998D-01, + $ 4.864661535887D-01 / + DATA ((S(i,j,13),i=1,2),j=1,2) + $ / 3.233484542693D-01, + $ 1.153112011010D-01, + $ 2.314790158713D-01, + $ 5.244939240922D-01 / + DATA ((S(i,j,14),i=1,2),j=1,2) + $ / 2.510034751770D-01, + $ 8.000727494074D-01, + $ 1.233548532583D-01, + $ 4.127724083169D-01 / + DATA ((S(i,j,15),i=1,2),j=1,3) + $ / 2.899558825500D-01, + $ 7.934537856582D-01, + $ 9.684121455104D-02, + $ 8.280801506687D-01, + $ 1.833434647042D-01, + $ 9.074658265305D-01 / + DATA ((S(i,j,16),i=1,2),j=1,4) + $ / 2.054823696403D-01, + $ 8.689460322872D-01, + $ 5.905157048925D-01, + $ 7.999278543857D-01, + $ 5.550152361077D-01, + $ 7.717462626916D-01, + $ 9.371809858554D-01, + $ 3.344363145343D-01 / + DATA ((S(i,j,17),i=1,2),j=1,6) + $ / 5.610263808622D-01, + $ 3.518280927734D-01, + $ 4.742392842552D-01, + $ 2.634716655938D-01, + $ 5.984126497885D-01, + $ 1.816640840360D-01, + $ 3.791035407696D-01, + $ 1.720795225657D-01, + $ 2.778673190586D-01, + $ 8.213021581933D-02, + $ 5.033564271075D-01, + $ 8.999205842075D-02 / + DATA ((S(i,j,18),i=1,2),j=1,9) + $ / 6.944024393349D-02, + $ 2.355187894242D-01, + $ 2.269004109529D-01, + $ 4.102182474046D-01, + $ 8.025574607775D-02, + $ 6.214302417482D-01, + $ 1.467999527897D-01, + $ 3.245284345717D-01, + $ 1.571507769825D-01, + $ 5.224482189697D-01, + $ 2.365702993157D-01, + $ 6.017546634090D-01, + $ 7.714815866766D-02, + $ 4.346575516141D-01, + $ 3.062936666211D-01, + $ 4.908826589038D-01, + $ 3.822477379525D-01, + $ 5.648768149100D-01 / + DATA ((S(i,j,19),i=1,2),j=1,12) + $ / 5.974048614181D-02, + $ 2.029128752778D-01, + $ 1.375760408474D-01, + $ 4.602621942484D-01, + $ 3.391016526336D-01, + $ 5.030673999662D-01, + $ 1.271675191440D-01, + $ 2.817606422442D-01, + $ 2.693120740414D-01, + $ 4.331561291720D-01, + $ 1.419786452602D-01, + $ 6.256167358581D-01, + $ 6.709284600738D-02, + $ 3.798395216859D-01, + $ 7.057738183256D-02, + $ 5.517505421424D-01, + $ 2.783888477882D-01, + $ 6.029619156159D-01, + $ 1.979578938917D-01, + $ 3.589606329589D-01, + $ 2.087307061103D-01, + $ 5.348666438135D-01, + $ 4.055122137873D-01, + $ 5.674997546074D-01 / + DATA ((S(i,j,20),i=1,2),j=1,16) + $ / 9.827986018264D-01, + $ 1.771774022615D-01, + $ 9.624249230326D-01, + $ 2.475716463426D-01, + $ 9.402007994129D-01, + $ 3.354616289066D-01, + $ 9.320822040143D-01, + $ 3.173615246612D-01, + $ 9.043674199393D-01, + $ 4.090268427085D-01, + $ 8.912407560075D-01, + $ 3.854291150669D-01, + $ 8.676435628463D-01, + $ 4.932221184851D-01, + $ 8.581979986042D-01, + $ 4.785320675922D-01, + $ 8.396753624050D-01, + $ 4.507422593157D-01, + $ 8.165288564022D-01, + $ 5.632123020762D-01, + $ 8.015469370784D-01, + $ 5.434303569694D-01, + $ 7.773563069070D-01, + $ 5.123518486420D-01, + $ 7.661621213900D-01, + $ 6.394279634749D-01, + $ 7.553584143534D-01, + $ 6.269805509024D-01, + $ 7.344305757560D-01, + $ 6.031161693096D-01, + $ 7.043837184022D-01, + $ 5.693702498468D-01 / + DATA ((S(i,j,21),i=1,2),j=1,20) + $ / 5.707522908892D-01, + $ 4.387028039890D-01, + $ 5.196463388403D-01, + $ 3.858908414763D-01, + $ 4.646337531215D-01, + $ 3.301937372344D-01, + $ 4.063901697558D-01, + $ 2.725423573564D-01, + $ 3.456329466643D-01, + $ 2.139510237495D-01, + $ 2.831395121050D-01, + $ 1.555922309787D-01, + $ 2.197682022925D-01, + $ 9.892878979686D-02, + $ 1.564696098650D-01, + $ 4.598642910676D-02, + $ 6.027356673721D-01, + $ 3.376625140173D-01, + $ 5.496032320255D-01, + $ 2.822301309728D-01, + $ 4.921707755235D-01, + $ 2.248632342593D-01, + $ 4.309422998598D-01, + $ 1.666224723456D-01, + $ 3.664108182314D-01, + $ 1.086964901822D-01, + $ 2.990189057758D-01, + $ 5.251989784120D-02, + $ 6.268724013145D-01, + $ 2.297523657550D-01, + $ 5.707324144835D-01, + $ 1.723080607094D-01, + $ 5.096360901960D-01, + $ 1.140238465391D-01, + $ 4.438729938312D-01, + $ 5.611522095883D-02, + $ 6.419978471082D-01, + $ 1.164174423141D-01, + $ 5.817218061803D-01, + $ 5.797589531445D-02 / + DATA ((S(i,j,22),i=1,2),j=1,25) + $ / 1.394983311832D-01, + $ 4.097581162050D-02, + $ 1.967999180485D-01, + $ 8.851987391293D-02, + $ 2.546183732549D-01, + $ 1.397680182970D-01, + $ 3.121281074714D-01, + $ 1.929452542227D-01, + $ 3.685981078502D-01, + $ 2.467898337062D-01, + $ 4.233760321548D-01, + $ 3.003104124785D-01, + $ 4.758671236059D-01, + $ 3.526684328175D-01, + $ 5.255178579796D-01, + $ 4.031134861146D-01, + $ 5.718025633735D-01, + $ 4.509426448342D-01, + $ 2.686927772723D-01, + $ 4.711322502423D-02, + $ 3.306006819905D-01, + $ 9.784487303943D-02, + $ 3.904906850595D-01, + $ 1.505395810025D-01, + $ 4.479957951904D-01, + $ 2.039728156296D-01, + $ 5.027076848920D-01, + $ 2.571529941121D-01, + $ 5.542087392260D-01, + $ 3.092191375816D-01, + $ 6.020850887375D-01, + $ 3.593807506130D-01, + $ 4.019851409180D-01, + $ 5.063389934379D-02, + $ 4.635614567450D-01, + $ 1.032422269161D-01, + $ 5.215860931592D-01, + $ 1.566322094006D-01, + $ 5.758202499099D-01, + $ 2.098082827491D-01, + $ 6.259893683877D-01, + $ 2.618824114553D-01, + $ 5.313795124812D-01, + $ 5.263245019339D-02, + $ 5.893317955932D-01, + $ 1.061059730982D-01, + $ 6.426246321216D-01, + $ 1.594171564034D-01, + $ 6.511904367376D-01, + $ 5.354789536566D-02 / + DATA ((S(i,j,23),i=1,2),j=1,30) + $ / 1.253901572367D-01, + $ 3.681917226440D-02, + $ 1.775721510384D-01, + $ 7.982487607213D-02, + $ 2.305693358216D-01, + $ 1.264640966592D-01, + $ 2.836502845992D-01, + $ 1.751585683419D-01, + $ 3.361794746233D-01, + $ 2.247995907633D-01, + $ 3.875979172265D-01, + $ 2.745299257422D-01, + $ 4.374019316999D-01, + $ 3.236373482441D-01, + $ 4.851275843340D-01, + $ 3.714967859437D-01, + $ 5.303391803807D-01, + $ 4.175353646322D-01, + $ 5.726197380596D-01, + $ 4.612084406355D-01, + $ 2.431520732565D-01, + $ 4.258040133044D-02, + $ 3.002096800896D-01, + $ 8.869424306723D-02, + $ 3.558554457457D-01, + $ 1.368811706511D-01, + $ 4.097782537049D-01, + $ 1.860739985015D-01, + $ 4.616337666067D-01, + $ 2.354235077396D-01, + $ 5.110707008418D-01, + $ 2.842074921347D-01, + $ 5.577415286164D-01, + $ 3.317784414984D-01, + $ 6.013060431367D-01, + $ 3.775299002041D-01, + $ 3.661596767262D-01, + $ 4.599367887165D-02, + $ 4.237633153507D-01, + $ 9.404893773654D-02, + $ 4.786328454658D-01, + $ 1.431377109092D-01, + $ 5.305702076790D-01, + $ 1.924186388844D-01, + $ 5.793436224232D-01, + $ 2.411590944775D-01, + $ 6.247069017095D-01, + $ 2.886871491584D-01, + $ 4.874315552535D-01, + $ 4.804978774953D-02, + $ 5.427337322059D-01, + $ 9.716857199367D-02, + $ 5.943493747247D-01, + $ 1.465205839795D-01, + $ 6.421314033565D-01, + $ 1.953579449804D-01, + $ 6.020628374714D-01, + $ 4.916375015738D-02, + $ 6.529222529857D-01, + $ 9.861621540127D-02 / + DATA ((S(i,j,24),i=1,2),j=1,36) + $ / 1.135081039844D-01, + $ 3.331954884663D-02, + $ 1.612866626099D-01, + $ 7.247167465437D-02, + $ 2.100786550168D-01, + $ 1.151539110850D-01, + $ 2.592282009460D-01, + $ 1.599491097144D-01, + $ 3.081740561320D-01, + $ 2.058699956028D-01, + $ 3.564289781578D-01, + $ 2.521624953503D-01, + $ 4.035587288241D-01, + $ 2.982090785798D-01, + $ 4.491671196374D-01, + $ 3.434762087236D-01, + $ 4.928854782917D-01, + $ 3.874831357203D-01, + $ 5.343646791959D-01, + $ 4.297814821747D-01, + $ 5.732683216531D-01, + $ 4.699402260944D-01, + $ 2.214131583219D-01, + $ 3.873602040644D-02, + $ 2.741796504750D-01, + $ 8.089496256902D-02, + $ 3.259797439149D-01, + $ 1.251732177621D-01, + $ 3.765441148827D-01, + $ 1.706260286403D-01, + $ 4.255773574531D-01, + $ 2.165115147300D-01, + $ 4.727795117058D-01, + $ 2.622089812225D-01, + $ 5.178546895819D-01, + $ 3.071721431296D-01, + $ 5.605141192097D-01, + $ 3.508998998801D-01, + $ 6.004763319353D-01, + $ 3.929160876167D-01, + $ 3.352842634947D-01, + $ 4.202563457288D-02, + $ 3.891971629815D-01, + $ 8.614309758871D-02, + $ 4.409875565542D-01, + $ 1.314500879380D-01, + $ 4.904893058592D-01, + $ 1.772189657384D-01, + $ 5.375056138770D-01, + $ 2.228277110050D-01, + $ 5.818255708670D-01, + $ 2.677179935014D-01, + $ 6.232334858145D-01, + $ 3.113675035544D-01, + $ 4.489485354492D-01, + $ 4.409162378368D-02, + $ 5.015136875933D-01, + $ 8.939009917748D-02, + $ 5.511300550513D-01, + $ 1.351806029383D-01, + $ 5.976720409858D-01, + $ 1.808370355053D-01, + $ 6.409956378989D-01, + $ 2.257852192302D-01, + $ 5.581222330828D-01, + $ 4.532173421637D-02, + $ 6.074705984162D-01, + $ 9.117488031840D-02, + $ 6.532272537379D-01, + $ 1.369294213140D-01, + $ 6.594761494500D-01, + $ 4.589901487276D-02 / + DATA ((S(i,j,25),i=1,2),j=1,42) + $ / 1.033958573552D-01, + $ 3.034544009064D-02, + $ 1.473521412414D-01, + $ 6.618803044247D-02, + $ 1.924552158706D-01, + $ 1.054431128988D-01, + $ 2.381094362890D-01, + $ 1.468263551239D-01, + $ 2.838121707937D-01, + $ 1.894486108188D-01, + $ 3.291323133373D-01, + $ 2.326374238762D-01, + $ 3.736896978741D-01, + $ 2.758485808486D-01, + $ 4.171406040760D-01, + $ 3.186179331997D-01, + $ 4.591677985257D-01, + $ 3.605329796304D-01, + $ 4.994733831718D-01, + $ 4.012147253587D-01, + $ 5.377731830445D-01, + $ 4.403050025571D-01, + $ 5.737917830001D-01, + $ 4.774565904277D-01, + $ 2.027323586271D-01, + $ 3.544122504976D-02, + $ 2.516942375187D-01, + $ 7.418304388646D-02, + $ 3.000227995257D-01, + $ 1.150502745727D-01, + $ 3.474806691046D-01, + $ 1.571963371209D-01, + $ 3.938103180359D-01, + $ 1.999631877247D-01, + $ 4.387519590456D-01, + $ 2.428073457847D-01, + $ 4.820503960078D-01, + $ 2.852575132906D-01, + $ 5.234573778475D-01, + $ 3.268884208675D-01, + $ 5.627318647235D-01, + $ 3.673033321676D-01, + $ 5.996390607157D-01, + $ 4.061211551830D-01, + $ 3.084780753792D-01, + $ 3.860125523100D-02, + $ 3.589988275920D-01, + $ 7.928938987105D-02, + $ 4.078628415882D-01, + $ 1.212614643030D-01, + $ 4.549287258890D-01, + $ 1.638770827383D-01, + $ 5.000278512957D-01, + $ 2.065965798260D-01, + $ 5.429785044928D-01, + $ 2.489436378852D-01, + $ 5.835939850492D-01, + $ 2.904811368947D-01, + $ 6.216870353445D-01, + $ 3.307941957667D-01, + $ 4.151104662709D-01, + $ 4.064829146053D-02, + $ 4.649804275009D-01, + $ 8.258424547295D-02, + $ 5.124695757010D-01, + $ 1.251841962027D-01, + $ 5.574711100606D-01, + $ 1.679107505976D-01, + $ 5.998597333287D-01, + $ 2.102805057359D-01, + $ 6.395007148517D-01, + $ 2.518418087774D-01, + $ 5.188456224746D-01, + $ 4.194321676078D-02, + $ 5.664190707943D-01, + $ 8.457661551921D-02, + $ 6.110464353283D-01, + $ 1.273652932519D-01, + $ 6.526430302052D-01, + $ 1.698173239076D-01, + $ 6.167551880378D-01, + $ 4.266398851549D-02, + $ 6.607195418355D-01, + $ 8.551925814238D-02 / + DATA ((S(i,j,26),i=1,2),j=1,49) + $ / 9.469870086838D-02, + $ 2.778748387309D-02, + $ 1.353170300568D-01, + $ 6.076569878628D-02, + $ 1.771679481726D-01, + $ 9.703072762711D-02, + $ 2.197066664232D-01, + $ 1.354112458525D-01, + $ 2.624783557375D-01, + $ 1.750996479744D-01, + $ 3.050969521214D-01, + $ 2.154896907450D-01, + $ 3.472252637196D-01, + $ 2.560954625740D-01, + $ 3.885610219026D-01, + $ 2.965070050624D-01, + $ 4.288273776063D-01, + $ 3.363641488734D-01, + $ 4.677662471303D-01, + $ 3.753400029837D-01, + $ 5.051333589553D-01, + $ 4.131297522144D-01, + $ 5.406942145810D-01, + $ 4.494423776082D-01, + $ 5.742204122576D-01, + $ 4.839938958842D-01, + $ 1.865407027225D-01, + $ 3.259144851071D-02, + $ 2.321186453689D-01, + $ 6.835679505297D-02, + $ 2.773159142524D-01, + $ 1.062284864452D-01, + $ 3.219200192237D-01, + $ 1.454404409323D-01, + $ 3.657032593944D-01, + $ 1.854018282583D-01, + $ 4.084376778364D-01, + $ 2.256297412015D-01, + $ 4.499004945751D-01, + $ 2.657104425001D-01, + $ 4.898758141326D-01, + $ 3.052755487632D-01, + $ 5.281547442266D-01, + $ 3.439863920645D-01, + $ 5.645346989814D-01, + $ 3.815229456122D-01, + $ 5.988181252160D-01, + $ 4.175752420967D-01, + $ 2.850425424472D-01, + $ 3.562149509863D-02, + $ 3.324619433028D-01, + $ 7.330318886871D-02, + $ 3.785848333076D-01, + $ 1.123226296008D-01, + $ 4.232891028562D-01, + $ 1.521084193338D-01, + $ 4.664287050830D-01, + $ 1.921844459224D-01, + $ 5.078458493736D-01, + $ 2.321360989678D-01, + $ 5.473779816204D-01, + $ 2.715886486361D-01, + $ 5.848617133811D-01, + $ 3.101924707571D-01, + $ 6.201348281585D-01, + $ 3.476121052891D-01, + $ 3.852191185388D-01, + $ 3.763224880035D-02, + $ 4.325025061073D-01, + $ 7.659581935637D-02, + $ 4.778486229734D-01, + $ 1.163381306084D-01, + $ 5.211663693009D-01, + $ 1.563890598753D-01, + $ 5.623469504854D-01, + $ 1.963320810149D-01, + $ 6.012718188659D-01, + $ 2.357847407259D-01, + $ 6.378179206390D-01, + $ 2.743846121244D-01, + $ 4.836936460215D-01, + $ 3.895902610739D-02, + $ 5.293792562684D-01, + $ 7.871246819313D-02, + $ 5.726281253100D-01, + $ 1.187963808203D-01, + $ 6.133658776169D-01, + $ 1.587914708062D-01, + $ 6.515085491865D-01, + $ 1.983058575228D-01, + $ 5.778692716065D-01, + $ 3.977209689792D-02, + $ 6.207904288086D-01, + $ 7.990157592981D-02, + $ 6.608688171047D-01, + $ 1.199671308754D-01, + $ 6.656263089489D-01, + $ 4.015955957806D-02 / + DATA ((S(i,j,27),i=1,2),j=1,56) + $ / 8.715738780836D-02, 2.557175233368D-02, + $ 1.248383123134D-01, 5.604823383377D-02, + $ 1.638062693383D-01, 8.968568601901D-02, + $ 2.035586203373D-01, 1.254086651976D-01, + $ 2.436798975294D-01, 1.624780150162D-01, + $ 2.838207507774D-01, 2.003422342683D-01, + $ 3.236787502218D-01, 2.385628026255D-01, + $ 3.629849554841D-01, 2.767731148784D-01, + $ 4.014948081992D-01, 3.146542308245D-01, + $ 4.389818379260D-01, 3.519196415895D-01, + $ 4.752331143674D-01, 3.883050984024D-01, + $ 5.100457318374D-01, 4.235613423909D-01, + $ 5.432238388955D-01, 4.574484717196D-01, + $ 5.745758685072D-01, 4.897311639256D-01, + $ 1.723981437593D-01, 3.010630597881D-02, + $ 2.149553257845D-01, 6.326031554205D-02, + $ 2.573256081247D-01, 9.848566980259D-02, + $ 2.993163751238D-01, 1.350835952384D-01, + $ 3.407238005148D-01, 1.725184055442D-01, + $ 3.813454978483D-01, 2.103559279731D-01, + $ 4.209848104423D-01, 2.482278774555D-01, + $ 4.594519699996D-01, 2.858099509983D-01, + $ 4.965640166186D-01, 3.228075659915D-01, + $ 5.321441655572D-01, 3.589459907204D-01, + $ 5.660208438582D-01, 3.939630088864D-01, + $ 5.980264315964D-01, 4.276029922949D-01, + $ 2.644215852351D-01, 3.300939429073D-02, + $ 3.090113743443D-01, 6.803887650079D-02, + $ 3.525871079198D-01, 1.044326136207D-01, + $ 3.950418005354D-01, 1.416751597518D-01, + $ 4.362475663430D-01, 1.793408610505D-01, + $ 4.760661812146D-01, 2.170630750176D-01, + $ 5.143551042512D-01, 2.545145157816D-01, + $ 5.509709026936D-01, 2.913940101707D-01, + $ 5.857711030329D-01, 3.274169910911D-01, + $ 6.186149917404D-01, 3.623081329317D-01, + $ 3.586894569557D-01, 3.497354386450D-02, + $ 4.035266610019D-01, 7.129736739757D-02, + $ 4.467775312333D-01, 1.084758620193D-01, + $ 4.883638346609D-01, 1.460915689242D-01, + $ 5.281908348435D-01, 1.837790832370D-01, + $ 5.661542687149D-01, 2.212075390874D-01, + $ 6.021450102031D-01, 2.580682841161D-01, + $ 6.360520783610D-01, 2.940656362094D-01, + $ 4.521611065087D-01, 3.631055365867D-02, + $ 4.959365651561D-01, 7.348318468484D-02, + $ 5.376815804038D-01, 1.111087643813D-01, + $ 5.773314480244D-01, 1.488226085145D-01, + $ 6.148113245575D-01, 1.862892274135D-01, + $ 6.500407462842D-01, 2.231909701714D-01, + $ 5.425151448707D-01, 3.718201306119D-02, + $ 5.841860556908D-01, 7.483616335067D-02, + $ 6.234632186851D-01, 1.125990834266D-01, + $ 6.602934551849D-01, 1.501303813158D-01, + $ 6.278573968375D-01, 3.767559930246D-02, + $ 6.665611711265D-01, 7.548443301360D-02 / + DATA ((S(i,j,28),i=1,2),j=1,64) + $ / 8.056516651369D-02, 2.363454684003D-02, + $ 1.156476077139D-01, 5.191291632546D-02, + $ 1.520473382760D-01, 8.322715736995D-02, + $ 1.892986699746D-01, 1.165855667994D-01, + $ 2.270194446778D-01, 1.513077167410D-01, + $ 2.648908185093D-01, 1.868882025808D-01, + $ 3.026389259574D-01, 2.229277629776D-01, + $ 3.400220296151D-01, 2.590951840746D-01, + $ 3.768217953336D-01, 2.951047291751D-01, + $ 4.128372900922D-01, 3.307019714170D-01, + $ 4.478807131816D-01, 3.656544101088D-01, + $ 4.817742034089D-01, 3.997448951940D-01, + $ 5.143472814653D-01, 4.327667110812D-01, + $ 5.454346213906D-01, 4.645196123532D-01, + $ 5.748739313170D-01, 4.948063555703D-01, + $ 1.599598738286D-01, 2.792357590049D-02, + $ 1.998097412501D-01, 5.877141038139D-02, + $ 2.396228952566D-01, 9.164573914691D-02, + $ 2.792228341098D-01, 1.259049641963D-01, + $ 3.184251107547D-01, 1.610594823401D-01, + $ 3.570481164426D-01, 1.967151653461D-01, + $ 3.949164710492D-01, 2.325404606175D-01, + $ 4.318617293971D-01, 2.682461141151D-01, + $ 4.677221009932D-01, 3.035720116012D-01, + $ 5.023417939271D-01, 3.382781859197D-01, + $ 5.355701836636D-01, 3.721383065626D-01, + $ 5.672608451329D-01, 4.049346360466D-01, + $ 5.972704202540D-01, 4.364538098634D-01, + $ 2.461687022334D-01, 3.070423166833D-02, + $ 2.881774566287D-01, 6.338034669282D-02, + $ 3.293963604117D-01, 9.742862487068D-02, + $ 3.697303822241D-01, 1.323799532282D-01, + $ 4.090663023135D-01, 1.678497018129D-01, + $ 4.472819355412D-01, 2.035095105326D-01, + $ 4.842513377231D-01, 2.390692566672D-01, + $ 5.198477629963D-01, 2.742649818076D-01, + $ 5.539453011883D-01, 3.088503806580D-01, + $ 5.864196762401D-01, 3.425904245907D-01, + $ 6.171484466668D-01, 3.752562294789D-01, + $ 3.350337830566D-01, 3.261589934635D-02, + $ 3.775773224758D-01, 6.658438928082D-02, + $ 4.188155229849D-01, 1.014565797158D-01, + $ 4.586805892009D-01, 1.368573320844D-01, + $ 4.970895714224D-01, 1.724614851952D-01, + $ 5.339505133961D-01, 2.079779381416D-01, + $ 5.691665792531D-01, 2.431385788322D-01, + $ 6.026387682680D-01, 2.776901883050D-01, + $ 6.342676150163D-01, 3.113881356387D-01, + $ 4.237951119537D-01, 3.394877848664D-02, + $ 4.656918683235D-01, 6.880219556291D-02, + $ 5.058857069186D-01, 1.041946859722D-01, + $ 5.443204666714D-01, 1.398039738736D-01, + $ 5.809298813760D-01, 1.753373381196D-01, + $ 6.156416039447D-01, 2.105215793514D-01, + $ 6.483801351067D-01, 2.450953312157D-01, + $ 5.103616577252D-01, 3.485560643801D-02, + $ 5.506738792581D-01, 7.026308631512D-02, + $ 5.889573040995D-01, 1.059035061296D-01, + $ 6.251641589517D-01, 1.414823925236D-01, + $ 6.592414921570D-01, 1.767207908215D-01, + $ 5.930314017533D-01, 3.542189339562D-02, + $ 6.309812253390D-01, 7.109574040370D-02, + $ 6.666296011353D-01, 1.067259792283D-01, + $ 6.703715271050D-01, 3.569455268821D-02 / + DATA ((S(i,j,29),i=1,2),j=1,72) + $ / 7.476563943166D-02, 2.193168509461D-02, + $ 1.075341482001D-01, 4.826419281534D-02, + $ 1.416344885203D-01, 7.751191883576D-02, + $ 1.766325315389D-01, 1.087558139248D-01, + $ 2.121744174482D-01, 1.413661374253D-01, + $ 2.479669443408D-01, 1.748768214259D-01, + $ 2.837600452294D-01, 2.089216406612D-01, + $ 3.193344933194D-01, 2.431987685546D-01, + $ 3.544935442439D-01, 2.774497054378D-01, + $ 3.890571932288D-01, 3.114460356157D-01, + $ 4.228581214259D-01, 3.449806851913D-01, + $ 4.557387211304D-01, 3.778618641248D-01, + $ 4.875487950542D-01, 4.099086391699D-01, + $ 5.181436529963D-01, 4.409474925854D-01, + $ 5.473824095601D-01, 4.708094517711D-01, + $ 5.751263398976D-01, 4.993275140355D-01, + $ 1.489515746840D-01, 2.599381993267D-02, + $ 1.863656444352D-01, 5.479286532462D-02, + $ 2.238602880356D-01, 8.556763251425D-02, + $ 2.612723375728D-01, 1.177257802267D-01, + $ 2.984332990206D-01, 1.508168456193D-01, + $ 3.351786584663D-01, 1.844801892178D-01, + $ 3.713505522209D-01, 2.184145236088D-01, + $ 4.067981098955D-01, 2.523590641486D-01, + $ 4.413769993688D-01, 2.860812976901D-01, + $ 4.749487182516D-01, 3.193686757809D-01, + $ 5.073798105075D-01, 3.520226949548D-01, + $ 5.385410448879D-01, 3.838544395668D-01, + $ 5.683065353671D-01, 4.146810037641D-01, + $ 5.965527620664D-01, 4.443224094681D-01, + $ 2.299227700856D-01, 2.865757664058D-02, + $ 2.695752998553D-01, 5.923421684486D-02, + $ 3.086178716611D-01, 9.117817776058D-02, + $ 3.469649871659D-01, 1.240593814083D-01, + $ 3.845153566320D-01, 1.575272058259D-01, + $ 4.211600033403D-01, 1.912845163525D-01, + $ 4.567867834330D-01, 2.250710177858D-01, + $ 4.912829319232D-01, 2.586521303441D-01, + $ 5.245364793304D-01, 2.918112242865D-01, + $ 5.564369788916D-01, 3.243439239068D-01, + $ 5.868757697775D-01, 3.560536787835D-01, + $ 6.157458853520D-01, 3.867480821243D-01, + $ 3.138461110672D-01, 3.051374637507D-02, + $ 3.542495872051D-01, 6.237111233731D-02, + $ 3.935751553120D-01, 9.516223952402D-02, + $ 4.317634668111D-01, 1.285467341509D-01, + $ 4.687413842251D-01, 1.622318931656D-01, + $ 5.044274237060D-01, 1.959581153836D-01, + $ 5.387354077926D-01, 2.294888081184D-01, + $ 5.715768898356D-01, 2.626031152714D-01, + $ 6.028627200136D-01, 2.950904075287D-01, + $ 6.325039812653D-01, 3.267458451113D-01, + $ 3.981986708423D-01, 3.183291458750D-02, + $ 4.382791182133D-01, 6.459548193881D-02, + $ 4.769233057218D-01, 9.795757037088D-02, + $ 5.140823911194D-01, 1.316307235127D-01, + $ 5.496977833863D-01, 1.653556486359D-01, + $ 5.837047306513D-01, 1.988931724127D-01, + $ 6.160349566927D-01, 2.320174581439D-01, + $ 6.466185353209D-01, 2.645106562169D-01, + $ 4.810835158795D-01, 3.275917807744D-02, + $ 5.199925041324D-01, 6.612546183967D-02, + $ 5.571717692207D-01, 9.981498331474D-02, + $ 5.925789250836D-01, 1.335687001410D-01, + $ 6.261658523860D-01, 1.671444402896D-01, + $ 6.578811126669D-01, 2.003106382156D-01, + $ 5.609624612998D-01, 3.337500940231D-02, + $ 5.979959659985D-01, 6.708750335902D-02, + $ 6.330523711054D-01, 1.008792126425D-01, + $ 6.660960998104D-01, 1.345050343172D-01, + $ 6.365384364586D-01, 3.372799460737D-02, + $ 6.710994302899D-01, 6.755249309678D-02 / + DATA ((S(i,j,30),i=1,2),j=1,81) + $ / 7.345133894143D-02, 2.177844081486D-02, + $ 1.009859834045D-01, 4.590362185775D-02, + $ 1.324289619749D-01, 7.255063095691D-02, + $ 1.654272109607D-01, 1.017825451961D-01, + $ 1.990767186776D-01, 1.325652320980D-01, + $ 2.330125945523D-01, 1.642765374497D-01, + $ 2.670080611108D-01, 1.965360374338D-01, + $ 3.008753376294D-01, 2.290726770542D-01, + $ 3.344475596168D-01, 2.616645495371D-01, + $ 3.675709724071D-01, 2.941150728843D-01, + $ 4.001000887588D-01, 3.262440400919D-01, + $ 4.318956350436D-01, 3.578835350612D-01, + $ 4.628239056796D-01, 3.888751854044D-01, + $ 4.927563229774D-01, 4.190678003223D-01, + $ 5.215687136708D-01, 4.483151836884D-01, + $ 5.491402346985D-01, 4.764740676088D-01, + $ 5.753520160126D-01, 5.034021310998D-01, + $ 1.388326356418D-01, 2.435436510373D-02, + $ 1.743686900537D-01, 5.118897057343D-02, + $ 2.099737037950D-01, 8.014695048540D-02, + $ 2.454492590909D-01, 1.105117874156D-01, + $ 2.807219257864D-01, 1.417950531571D-01, + $ 3.156842271976D-01, 1.736604945720D-01, + $ 3.502090945178D-01, 2.058466324694D-01, + $ 3.841684849520D-01, 2.381284261196D-01, + $ 4.174372367906D-01, 2.703031270423D-01, + $ 4.498926465012D-01, 3.021845683091D-01, + $ 4.814146229808D-01, 3.335993355166D-01, + $ 5.118863625735D-01, 3.643833735518D-01, + $ 5.411947455119D-01, 3.943789541958D-01, + $ 5.692301500357D-01, 4.234320144404D-01, + $ 5.958857204140D-01, 4.513897947419D-01, + $ 2.156270284786D-01, 2.681225755444D-02, + $ 2.532385054910D-01, 5.557495747806D-02, + $ 2.902564617772D-01, 8.569368062950D-02, + $ 3.266979823143D-01, 1.167367450324D-01, + $ 3.625039627494D-01, 1.483861994003D-01, + $ 3.975838937549D-01, 1.803821503011D-01, + $ 4.318396099010D-01, 2.124962965666D-01, + $ 4.651706555733D-01, 2.445221837806D-01, + $ 4.974752649621D-01, 2.762701224323D-01, + $ 5.286517579628D-01, 3.075627775211D-01, + $ 5.586001195732D-01, 3.382311089827D-01, + $ 5.872229902021D-01, 3.681108834741D-01, + $ 6.144258616235D-01, 3.970397446873D-01, + $ 2.951676508065D-01, 2.867499538750D-02, + $ 3.335085485473D-01, 5.867879341904D-02, + $ 3.709561760636D-01, 8.961099205022D-02, + $ 4.074722861667D-01, 1.211627927626D-01, + $ 4.429923648839D-01, 1.530748903555D-01, + $ 4.774428052722D-01, 1.851176436722D-01, + $ 5.107446539536D-01, 2.170829107658D-01, + $ 5.428151370543D-01, 2.487786689026D-01, + $ 5.735699292557D-01, 2.800239952795D-01, + $ 6.029253794563D-01, 3.106445702878D-01, + $ 6.307998987073D-01, 3.404689500841D-01, + $ 3.752652273693D-01, 2.997145098184D-02, + $ 4.135383879344D-01, 6.086725898678D-02, + $ 4.506113885154D-01, 9.238849548436D-02, + $ 4.864401554606D-01, 1.242786603852D-01, + $ 5.209708076612D-01, 1.563086731483D-01, + $ 5.541422135830D-01, 1.882696509389D-01, + $ 5.858880915114D-01, 2.199672979126D-01, + $ 6.161399390603D-01, 2.512165482925D-01, + $ 6.448296482255D-01, 2.818368701872D-01, + $ 4.544796274918D-01, 3.088970405060D-02, + $ 4.919389072147D-01, 6.240947677637D-02, + $ 5.279313026985D-01, 9.430706144280D-02, + $ 5.624169925571D-01, 1.263547818770D-01, + $ 5.953484627093D-01, 1.583430788823D-01, + $ 6.266730715339D-01, 1.900748462556D-01, + $ 6.563363204279D-01, 2.213599519593D-01, + $ 5.314574716586D-01, 3.152508811515D-02, + $ 5.674614932298D-01, 6.343865291466D-02, + $ 6.017706004970D-01, 9.551503504224D-02, + $ 6.343471270264D-01, 1.275440099801D-01, + $ 6.651494599128D-01, 1.593252037672D-01, + $ 6.050184986006D-01, 3.192538338496D-02, + $ 6.390163550880D-01, 6.402824353962D-02, + $ 6.711199107088D-01, 9.609805077003D-02, + $ 6.741354429572D-01, 3.211853196273D-02 / + DATA ((S(i,j,31),i=1,2),j=1,90) + $ / 6.655644120217D-02, 1.936508874588D-02, + $ 9.446246161270D-02, 4.252442002116D-02, + $ 1.242651925453D-01, 6.806529315354D-02, + $ 1.553438064847D-01, 9.560957491205D-02, + $ 1.871137110543D-01, 1.245931657453D-01, + $ 2.192612628836D-01, 1.545385828779D-01, + $ 2.515682807207D-01, 1.851004249723D-01, + $ 2.838535866287D-01, 2.160182608272D-01, + $ 3.159578817529D-01, 2.470799012277D-01, + $ 3.477370882791D-01, 2.781014208986D-01, + $ 3.790576960891D-01, 3.089172523516D-01, + $ 4.097938317810D-01, 3.393750055472D-01, + $ 4.398256572860D-01, 3.693322470988D-01, + $ 4.690384114718D-01, 3.986541005610D-01, + $ 4.973216048301D-01, 4.272112491409D-01, + $ 5.245681526132D-01, 4.548781735310D-01, + $ 5.506733911804D-01, 4.815315355023D-01, + $ 5.755339829522D-01, 5.070486445802D-01, + $ 1.305472386056D-01, 2.284970375722D-02, + $ 1.637327908216D-01, 4.812254338288D-02, + $ 1.972734634150D-01, 7.531734457512D-02, + $ 2.308694653110D-01, 1.039043639882D-01, + $ 2.643899218338D-01, 1.334526587118D-01, + $ 2.977171599622D-01, 1.636414868936D-01, + $ 3.307293903032D-01, 1.942195406167D-01, + $ 3.633069198219D-01, 2.249752879944D-01, + $ 3.953346955923D-01, 2.557218821820D-01, + $ 4.267018394185D-01, 2.862897925213D-01, + $ 4.573009622572D-01, 3.165224536637D-01, + $ 4.870279559856D-01, 3.462730221636D-01, + $ 5.157819581450D-01, 3.754016870283D-01, + $ 5.434651666465D-01, 4.037733784994D-01, + $ 5.699823887765D-01, 4.312557784139D-01, + $ 5.952403350948D-01, 4.577175367122D-01, + $ 2.025152599210D-01, 2.520253617720D-02, + $ 2.381066653274D-01, 5.223254506119D-02, + $ 2.732823383652D-01, 8.060669688589D-02, + $ 3.080137692611D-01, 1.099335754081D-01, + $ 3.422405614588D-01, 1.399120955960D-01, + $ 3.758808773890D-01, 1.702977801652D-01, + $ 4.088458383439D-01, 2.008799256602D-01, + $ 4.410450550841D-01, 2.314703052181D-01, + $ 4.723879420561D-01, 2.618972111376D-01, + $ 5.027843561874D-01, 2.920013195600D-01, + $ 5.321453674452D-01, 3.216322555191D-01, + $ 5.603839113834D-01, 3.506456615934D-01, + $ 5.874150706875D-01, 3.789007181306D-01, + $ 6.131559381660D-01, 4.062580170573D-01, + $ 2.778497016395D-01, 2.696271276876D-02, + $ 3.143733562262D-01, 5.523469316960D-02, + $ 3.501485810262D-01, 8.445193201626D-02, + $ 3.851430322304D-01, 1.143263119336D-01, + $ 4.193013979470D-01, 1.446177898344D-01, + $ 4.525585960459D-01, 1.751165438438D-01, + $ 4.848447779623D-01, 2.056338306746D-01, + $ 5.160871208277D-01, 2.359965487229D-01, + $ 5.462112185697D-01, 2.660430223139D-01, + $ 5.751425068102D-01, 2.956193664498D-01, + $ 6.028073872854D-01, 3.245763905313D-01, + $ 6.291338275278D-01, 3.527670026207D-01, + $ 3.541797528439D-01, 2.823853479436D-02, + $ 3.908234972075D-01, 5.741296374713D-02, + $ 4.264408450108D-01, 8.724646633650D-02, + $ 4.609949666553D-01, 1.175034422916D-01, + $ 4.944389496536D-01, 1.479755652628D-01, + $ 5.267194884346D-01, 1.784740659484D-01, + $ 5.577787810221D-01, 2.088245700431D-01, + $ 5.875563763537D-01, 2.388628136571D-01, + $ 6.159910016391D-01, 2.684308928769D-01, + $ 6.430219602956D-01, 2.973740761960D-01, + $ 4.300647036214D-01, 2.916399920494D-02, + $ 4.661486308936D-01, 5.898803024756D-02, + $ 5.009658555287D-01, 8.924162698525D-02, + $ 5.344824270448D-01, 1.197185199637D-01, + $ 5.666575997416D-01, 1.502300756161D-01, + $ 5.974457471405D-01, 1.806004191914D-01, + $ 6.267984444117D-01, 2.106621764786D-01, + $ 6.546664713575D-01, 2.402526932672D-01, + $ 5.042711004437D-01, 2.982529203608D-02, + $ 5.392127456774D-01, 6.008728062340D-02, + $ 5.726819437669D-01, 9.058227674571D-02, + $ 6.046469254207D-01, 1.211219235803D-01, + $ 6.350716157435D-01, 1.515286404792D-01, + $ 6.639177679185D-01, 1.816314681256D-01, + $ 5.757276040972D-01, 3.026991752575D-02, + $ 6.090265823140D-01, 6.078402297871D-02, + $ 6.406735344388D-01, 9.135459984177D-02, + $ 6.706397927794D-01, 1.218024155967D-01, + $ 6.435019674427D-01, 3.052608357661D-02, + $ 6.747218676376D-01, 6.112185773983D-02 / + + Pi = ACOS(-1d0) + Pi4 = 4 * Pi + +c Determine if the number of points requested is valid, and, if the +c formula is simple enough, go ahead and put it in now... + + IF (N.eq.1) THEN + Pts(1,1) = 0D0 + Pts(2,1) = 0D0 + Pts(3,1) = 1D0 + Wts (1) = Pi4 + RETURN + ELSEIF (N.eq.4) THEN + CALL VRLoad(Pts,12,SQRT(1D0/3D0)) + CALL VRLoad(Wts,4,Pi) + Pts(1,2) = -Pts(1,2) + Pts(2,2) = -Pts(2,2) + Pts(1,3) = -Pts(1,3) + Pts(3,3) = -Pts(3,3) + Pts(2,4) = -Pts(2,4) + Pts(3,4) = -Pts(3,4) + RETURN + ELSEIF (N.eq.6) THEN + Leb = 1 + ELSEIF (N.eq.18) THEN + Leb = 2 + ELSEIF (N.eq.26) THEN + Leb = 3 + ELSEIF (N.eq.38) THEN + Leb = 4 + ELSEIF (N.eq.50) THEN + Leb = 5 + ELSEIF (N.eq.74) THEN + Leb = 6 + ELSEIF (N.eq.86) THEN + Leb = 7 + ELSEIF (N.eq.110) THEN + Leb = 8 + ELSEIF (N.eq.146) THEN + Leb = 9 + ELSEIF (N.eq.170) THEN + Leb = 10 + ELSEIF (N.eq.194) THEN + Leb = 11 + ELSEIF (N.eq.230) THEN + Leb = 12 + ELSEIF (N.eq.266) THEN + Leb = 13 + ELSEIF (N.eq.302) THEN + Leb = 14 + ELSEIF (N.eq.350) THEN + Leb = 15 + ELSEIF (N.eq.434) THEN + Leb = 16 + ELSEIF (N.eq.590) THEN + Leb = 17 + ELSEIF (N.eq.770) THEN + Leb = 18 + ELSEIF (N.eq.974) THEN + Leb = 19 + ELSEIF (N.eq.1202) THEN + Leb = 20 + ELSEIF (N.eq.1454) THEN + Leb = 21 + ELSEIF (N.eq.1730) THEN + Leb = 22 + ELSEIF (N.eq.2030) THEN + Leb = 23 + ELSEIF (N.eq.2354) THEN + Leb = 24 + ELSEIF (N.eq.2702) THEN + Leb = 25 + ELSEIF (N.eq.3074) THEN + Leb = 26 + ELSEIF (N.eq.3470) THEN + Leb = 27 + ELSEIF (N.eq.3890) THEN + Leb = 28 + ELSEIF (N.eq.4334) THEN + Leb = 29 + ELSEIF (N.eq.4802) THEN + Leb = 30 + ELSEIF (N.eq.5294) THEN + Leb = 31 + ELSE + write(*,*)'Valid Angular Grids are :' + write(*,*)'6, 18, 26, 38, 50, 74, 86, 110, 146, 170, 194, 230' + write(*,*)'266, 302, 434, 590, 770, 974, 1202, 1454, 1730' + write(*,*)'2030, 2354, 2702, 3074, 3470, 3890, 4334, 4802, 5294' + CALL EXIT + ENDIF + +c Construct the Lebedev octahedral sets from their defining +c parameters. See the references given above... + + iPt = 0 + +c First, the special sets... + +c 6-point set (A1)... + + IF (SetTyp(1,Leb).eq.1) THEN + CALL VRLoad(Pts(1,iPt+1),18,0D0) + CALL VRLoad(Wts(iPt+1),6,A(1,Leb)) + z = 1D0 + DO 100 i = 1,6 + Pts((i+1)/2,iPt+i) = z + z = -z + 100 CONTINUE + iPt = iPt + 6 + ENDIF + +c 12-point set (A2)... + + IF (SetTyp(2,Leb).eq.1) THEN + CALL VRLoad(Pts(1,iPt+1),36,0D0) + CALL VRLoad(Wts(iPt+1),12,A(2,Leb)) + z = SQRT(0.5D0) + DO 200 i = 1,2 + DO 210 j = i+1,3 + Pts(i,iPt+1) = z + Pts(j,iPt+1) = z + Pts(i,iPt+2) = z + Pts(j,iPt+2) = -z + Pts(i,iPt+3) = -z + Pts(j,iPt+3) = z + Pts(i,iPt+4) = -z + Pts(j,iPt+4) = -z + iPt = iPt + 4 + 210 CONTINUE + 200 CONTINUE + ENDIF + +c 8-point set (A3)... + + IF (SetTyp(3,Leb).eq.1) THEN + CALL VRLoad(Wts(iPt+1),8,A(3,Leb)) + z = SQRT(1D0/3D0) + DO 300 i1 = 0,1 + DO 310 i2 = 0,1 + DO 320 i3 = 0,1 + Pts(1,iPt+1) = (-1)**i1 * z + Pts(2,iPt+1) = (-1)**i2 * z + Pts(3,iPt+1) = (-1)**i3 * z + iPt = iPt + 1 + 320 CONTINUE + 310 CONTINUE + 300 CONTINUE + ENDIF + +c Next, the general sets... + +c 24-point sets (Bk)... + + DO 400 k = 1,SetTyp(4,Leb) + CALL VRLoad(Wts(iPt+1),24,B(k,Leb)) + mk = SQRT(ABS(T(k,Leb))) + lk = SQRT((1D0-mk**2)/2) + DO 410 j = 1,3 + DO 420 i1 = 0,1 + DO 430 i2 = 0,1 + DO 440 i3 = 0,1 + Pts(Pmt(1,j),iPt+1) = (-1)**i1 * mk + Pts(Pmt(2,j),iPt+1) = (-1)**i2 * lk + Pts(Pmt(3,j),iPt+1) = (-1)**i3 * lk + iPt = iPt + 1 + 440 CONTINUE + 430 CONTINUE + 420 CONTINUE + 410 CONTINUE + 400 CONTINUE + +c 24-point sets (Ck)... + + DO 500 k = 1,SetTyp(5,Leb) + CALL VRLoad(Wts(iPt+1),24,C(k,Leb)) + pk = SQRT(ABS((1D0+SQRT(1D0-4*V(k,Leb)))/2)) + qk = SQRT(1D0-pk**2) + DO 510 j = 1,6 + DO 520 i1 = 0,1 + DO 530 i2 = 0,1 + Pts(Pmt(1,j),iPt+1) = (-1)**i1 * pk + Pts(Pmt(2,j),iPt+1) = (-1)**i2 * qk + Pts(Pmt(3,j),iPt+1) = 0D0 + iPt = iPt + 1 + 530 CONTINUE + 520 CONTINUE + 510 CONTINUE + 500 CONTINUE + +c 48-point sets (Dk)... + + DO 600 k = 1,SetTyp(6,Leb) + CALL VRLoad(Wts(iPt+1),48,D(k,Leb)) + +c To find the base-points r,s,w, we must find the roots +c of a polynomial (See Ref. 2)... + + s1k = S(1,k,Leb) + s2k = S(2,k,Leb) + s3k = SQRT(1-s1k*s1k-s2k*s2k) + + DO j = 1,6 + do i1 = 0,1 + do i2 = 0,1 + do i3 = 0,1 + Pts(Pmt(1,j),iPt+1) = (-1)**i1*s1k + Pts(Pmt(2,j),iPt+1) = (-1)**i2*s3k + Pts(Pmt(3,j),iPt+1) = (-1)**i3*s2k + iPt = iPt + 1 + enddo + enddo + enddo + enddo + 600 CONTINUE + +c Scale the weights by 4*Pi and we're done... + + CALL VRScale(Wts,N,Pi4) + RETURN + END + +c----------------------------------------------------------------------- + + SUBROUTINE VRload(A,N,Value) + IMPLICIT REAL*8 (a-h,o-z) + REAL*8 A(N) + DO i = 1,N + A(i) = Value + END DO + RETURN + END + +c----------------------------------------------------------------------- + + SUBROUTINE VRscale(A,N,Scale) + IMPLICIT REAL*8 (a-h,o-z) + REAL*8 A(N) + DO i = 1, N + A(i) = Scale * A(i) + END DO + RETURN + END diff --git a/src/xcDFT/electron_number.f90 b/src/xcDFT/electron_number.f90 new file mode 100644 index 0000000..6028c05 --- /dev/null +++ b/src/xcDFT/electron_number.f90 @@ -0,0 +1,20 @@ +function electron_number(nGrid,w,rho) result(nEl) + +! Compute the number of electrons via integration of the one-electron density + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: w(nGrid) + double precision,intent(in) :: rho(nGrid) + +! Output variables + + double precision :: nEl + + nEl = 2d0*dot_product(w,rho) + +end function electron_number diff --git a/src/xcDFT/elements.f90 b/src/xcDFT/elements.f90 new file mode 100644 index 0000000..1432c34 --- /dev/null +++ b/src/xcDFT/elements.f90 @@ -0,0 +1,171 @@ +function element_number(element_name) + + implicit none + integer,parameter :: nelement_max = 103 + character(len=2),intent(in) :: element_name + integer :: element_number + character(len=2),parameter :: element_list(nelement_max) = & + (/' H', 'He', & ! 2 + 'Li','Be', ' B',' C',' N',' O',' F','Ne', & ! 10 + 'Na','Mg', 'Al','Si',' P',' S','Cl','Ar', & ! 18 + ' K','Ca','Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr', & ! 36 + 'Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn','Sb','Te',' I','Xe', & ! 54 + 'Cs','Ba', & ! 56 + 'La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb', & ! 70 + 'Lu','Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn', & ! 86 + 'Fr','Ra', & ! 88 + 'Ac','Th','Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es','Fm','Md','No', & ! 102 + 'Lr' & ! 103 + /) + +!===== + integer :: ielement +!===== + + ielement=1 + do while( ADJUSTL(element_name) /= ADJUSTL(element_list(ielement)) ) + if( ielement == nelement_max ) then + write(*,'(a,a)') ' Input symbol ',element_name + write(*,'(a,i3,a)') ' Element symbol is not one of first ',nelement_max,' elements' + write(*,*) '!!! element symbol not understood !!!' + stop + endif + ielement = ielement + 1 + enddo + + element_number = ielement + +end function element_number + +function element_core(zval,zatom) + implicit none + double precision,intent(in) :: zval + double precision,intent(in) :: zatom + integer :: element_core +!===== + + ! + ! If zval /= zatom, this is certainly an effective core potential + ! and no core states should be frozen. + if( ABS(zval - zatom) > 1d0-3 ) then + element_core = 0 + else + + if( zval <= 4.00001d0 ) then ! up to Be + element_core = 0 + else if( zval <= 12.00001d0 ) then ! up to Mg + element_core = 1 + else if( zval <= 30.00001d0 ) then ! up to Ca + element_core = 5 + else if( zval <= 48.00001d0 ) then ! up to Sr + element_core = 9 + else + write(*,*) '!!! not imlemented in element_core !!!' + stop + endif + + endif + + +end function element_core + + + +function element_covalent_radius(zatom) + +! Return covalent radius of an atom + + implicit none + include 'parameters.h' + + integer,intent(in) :: zatom + double precision :: element_covalent_radius + + ! + ! Data from Cambridge Structural Database + ! http://en.wikipedia.org/wiki/Covalent_radius + ! + ! Values are first given in picometer + ! They will be converted in bohr just after + select case(zatom) + case( 1) + element_covalent_radius = 31. + case( 2) + element_covalent_radius = 28. + case( 3) + element_covalent_radius = 128. + case( 4) + element_covalent_radius = 96. + case( 5) + element_covalent_radius = 84. + case( 6) + element_covalent_radius = 73. + case( 7) + element_covalent_radius = 71. + case( 8) + element_covalent_radius = 66. + case( 9) + element_covalent_radius = 57. + case(10) ! Ne. + element_covalent_radius = 58. + case(11) + element_covalent_radius = 166. + case(12) + element_covalent_radius = 141. + case(13) + element_covalent_radius = 121. + case(14) + element_covalent_radius = 111. + case(15) + element_covalent_radius = 107. + case(16) + element_covalent_radius = 105. + case(17) + element_covalent_radius = 102. + case(18) ! Ar. + element_covalent_radius = 106. + case(19) + element_covalent_radius = 203. + case(20) + element_covalent_radius = 176. + case(21) + element_covalent_radius = 170. + case(22) + element_covalent_radius = 160. + case(23) + element_covalent_radius = 153. + case(24) + element_covalent_radius = 139. + case(25) + element_covalent_radius = 145. + case(26) + element_covalent_radius = 145. + case(27) + element_covalent_radius = 140. + case(28) + element_covalent_radius = 124. + case(29) + element_covalent_radius = 132. + case(30) + element_covalent_radius = 122. + case(31) + element_covalent_radius = 120. + case(32) + element_covalent_radius = 119. + case(34) + element_covalent_radius = 120. + case(35) + element_covalent_radius = 120. + case(36) ! Kr. + element_covalent_radius = 116. + case default + write(*,*) '!!! covalent radius not available !!!' + stop + end select + + ! pm to bohr conversion + element_covalent_radius = element_covalent_radius*pmtoau + + +end function element_covalent_radius + diff --git a/src/xcDFT/exchange_energy.f90 b/src/xcDFT/exchange_energy.f90 new file mode 100644 index 0000000..0054274 --- /dev/null +++ b/src/xcDFT/exchange_energy.f90 @@ -0,0 +1,79 @@ +function exchange_energy(rung,nGrid,weight,nBas,P,FxHF,rho,drho) result(Ex) + +! Compute the exchange energy + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: rung + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: FxHF(nBas,nBas) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(3,nGrid) + +! Local variables + + double precision :: ExLDA,ExGGA,ExHF + double precision :: cX,aX,aC + double precision :: Ex + +! Output variables + +! Memory allocation + + Ex = 0d0 + ExLDA = 0d0 + ExGGA = 0d0 + ExHF = 0d0 + + select case (rung) + +! Hartree calculation + case(0) + + Ex = 0d0 + +! LDA functionals + case(1) + + call lda_exchange_energy(nGrid,weight,rho,ExLDA) + + Ex = ExLDA + +! GGA functionals + case(2) + + call gga_exchange_energy(nGrid,weight,rho,drho,ExGGA) + + Ex = ExGGA + +! Hybrid functionals + case(4) + + cX = 0.20d0 + aX = 0.72d0 + aC = 0.81d0 + + call lda_exchange_energy(nGrid,weight,rho,ExLDA) + call gga_exchange_energy(nGrid,weight,rho,drho,ExGGA) + call fock_exchange_energy(nBas,P,FxHF,ExHF) + + Ex = ExLDA & + + cX*(ExHF - ExLDA) & + + aX*(ExGGA - ExLDA) + +! Hartree-Fock calculation + case(666) + + call fock_exchange_energy(nBas,P,FxHF,ExHF) + + Ex = ExHF + + end select + +end function exchange_energy diff --git a/src/xcDFT/exchange_potential.f90 b/src/xcDFT/exchange_potential.f90 new file mode 100644 index 0000000..c634624 --- /dev/null +++ b/src/xcDFT/exchange_potential.f90 @@ -0,0 +1,82 @@ +subroutine exchange_potential(rung,nGrid,weight,nBas,P,ERI,AO,dAO,rho,drho,Fx,FxHF) + +! Compute the exchange potential + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: rung + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(3,nBas,nGrid) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(3,nGrid) + +! Local variables + + double precision,allocatable :: FxLDA(:,:),FxGGA(:,:) + double precision :: cX,aX,aC + +! Output variables + + double precision,intent(out) :: Fx(nBas,nBas),FxHF(nBas,nBas) + +! Memory allocation + + allocate(FxLDA(nBas,nBas),FxGGA(nBas,nBas)) + + FxLDA(:,:) = 0d0 + FxGGA(:,:) = 0d0 + + select case (rung) + +! Hartree calculation + case(0) + + Fx(:,:) = 0d0 + +! LDA functionals + case(1) + + call lda_exchange_potential(nGrid,weight,nBas,AO,rho,FxLDA) + + Fx(:,:) = FxLDA(:,:) + +! GGA functionals + case(2) + + call gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,FxGGA) + + Fx(:,:) = FxGGA(:,:) + +! Hybrid functionals + case(4) + + cX = 0.20d0 + aX = 0.72d0 + aC = 0.81d0 + + call lda_exchange_potential(nGrid,weight,nBas,AO,rho,FxLDA) + call gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,FxGGA) + call fock_exchange_potential(nBas,P,ERI,FxHF) + + Fx(:,:) = FxLDA(:,:) & + + cX*(FxHF(:,:) - FxLDA(:,:)) & + + aX*(FxGGA(:,:) - FxLDA(:,:)) + +! Hartree-Fock calculation + case(666) + + call fock_exchange_potential(nBas,P,ERI,FxHF) + + Fx(:,:) = FxHF(:,:) + + end select + +end subroutine exchange_potential diff --git a/src/xcDFT/fock_exchange_energy.f90 b/src/xcDFT/fock_exchange_energy.f90 new file mode 100644 index 0000000..f019c04 --- /dev/null +++ b/src/xcDFT/fock_exchange_energy.f90 @@ -0,0 +1,25 @@ +subroutine fock_exchange_energy(nBas,P,Fx,Ex) + +! Compute the (exact) Fock exchange energy + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: Fx(nBas,nBas) + +! Local variables + + double precision,external :: trace_matrix + +! Output variables + + double precision,intent(out) :: Ex + +! Compute HF exchange energy + + Ex = trace_matrix(nBas,matmul(P,Fx)) + +end subroutine fock_exchange_energy diff --git a/src/xcDFT/fock_exchange_potential.f90 b/src/xcDFT/fock_exchange_potential.f90 new file mode 100644 index 0000000..483f08a --- /dev/null +++ b/src/xcDFT/fock_exchange_potential.f90 @@ -0,0 +1,34 @@ +subroutine fock_exchange_potential(nBas,P,ERI,Fx) + +! Compute the Fock exchange potential + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: mu,nu,la,si + +! Output variables + + double precision,intent(out) :: Fx(nBas,nBas) + +! Compute HF exchange matrix + + Fx(:,:) = 0d0 + do nu=1,nBas + do si=1,nBas + do la=1,nBas + do mu=1,nBas + Fx(mu,nu) = Fx(mu,nu) - P(la,si)*ERI(mu,la,si,nu) + enddo + enddo + enddo + enddo + +end subroutine fock_exchange_potential diff --git a/src/xcDFT/generate_shell.f90 b/src/xcDFT/generate_shell.f90 new file mode 100644 index 0000000..c6e0ab5 --- /dev/null +++ b/src/xcDFT/generate_shell.f90 @@ -0,0 +1,32 @@ +subroutine generate_shell(atot,nShellFunction,ShellFunction) + +! Generate shells for a given total angular momemtum + + implicit none + +! Input variables + + integer,intent(in) :: atot,nShellFunction + +! Local variables + + integer :: ax,ay,az,ia + +! Output variables + + integer,intent(out) :: ShellFunction(nShellFunction,3) + + ia = 0 + do ax=atot,0,-1 + do az=0,atot + ay = atot - ax - az + if(ay >= 0) then + ia = ia + 1 + ShellFunction(ia,1) = ax + ShellFunction(ia,2) = ay + ShellFunction(ia,3) = az + endif + enddo + enddo + +end subroutine generate_shell diff --git a/src/xcDFT/gga_exchange_energy.f90 b/src/xcDFT/gga_exchange_energy.f90 new file mode 100644 index 0000000..b9773e3 --- /dev/null +++ b/src/xcDFT/gga_exchange_energy.f90 @@ -0,0 +1,44 @@ +subroutine gga_exchange_energy(nGrid,weight,rho,drho,Ex) + +! Compute GGA exchange energy + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(3,nGrid) + +! Local variables + + integer :: iG + double precision :: alpha,beta + double precision :: r,g + +! Output variables + + double precision :: Ex + +! Coefficients for G96 GGA exchange functional + + alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) + beta = 1d0/137d0 + +! Compute GGA exchange energy + + Ex = 0d0 + do iG=1,nGrid + + r = rho(iG) + g = drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2 + + Ex = Ex + weight(iG)*r**(4d0/3d0)*(alpha - beta*g**(3d0/4d0)/r**2) + + enddo + + Ex = 2d0*Ex + +end subroutine gga_exchange_energy diff --git a/src/xcDFT/gga_exchange_potential.f90 b/src/xcDFT/gga_exchange_potential.f90 new file mode 100644 index 0000000..41c50b9 --- /dev/null +++ b/src/xcDFT/gga_exchange_potential.f90 @@ -0,0 +1,62 @@ +subroutine gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) + +! Compute GGA exchange potential + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(3,nBas,nGrid) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(3,nGrid) + +! Local variables + + double precision,parameter :: thresh = 1d-15 + + integer :: mu,nu,iG + double precision :: alpha,beta + double precision :: r,g,vAO,gAO + +! Output variables + + double precision,intent(out) :: Fx(nBas,nBas) + +! Coefficients for G96 GGA exchange functional + + alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) + beta = +1d0/137d0 + beta = 0d0 + +! Compute GGA exchange matrix in the AO basis + + Fx(:,:) = 0d0 + do mu=1,nBas + do nu=1,nBas + do iG=1,nGrid + + r = rho(iG) + g = drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2 + + vAO = weight(iG)*AO(mu,iG)*AO(nu,iG) + Fx(mu,nu) = Fx(mu,nu) & + + vAO*(4d0/3d0*r**(1d0/3d0)*(alpha - beta*g**(3d0/4d0)/r**2) & + + 2d0*beta*g**(3d0/4d0)/r**(5d0/3d0)) + + gAO = drho(1,iG)*(dAO(1,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(1,nu,iG)) & + + drho(2,iG)*(dAO(2,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(2,nu,iG)) & + + drho(3,iG)*(dAO(3,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(3,nu,iG)) + gAO = weight(iG)*gAO + + Fx(mu,nu) = Fx(mu,nu) - 2d0*gAO*3d0/4d0*beta*g**(-1d0/4d0)/r**(2d0/3d0) + + enddo + enddo + enddo + +end subroutine gga_exchange_potential diff --git a/src/xcDFT/gradient_density.f90 b/src/xcDFT/gradient_density.f90 new file mode 100644 index 0000000..7d9e0cd --- /dev/null +++ b/src/xcDFT/gradient_density.f90 @@ -0,0 +1,45 @@ +subroutine gradient_density(nGrid,nBas,P,AO,dAO,drho) + +! Calculate gradient of the one-electron density + + implicit none + include 'parameters.h' + +! Input variables + + double precision,parameter :: thresh = 1d-15 + + integer,intent(in) :: nGrid + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(3,nBas,nGrid) + +! Local variables + + integer :: ixyz,iG,mu,nu + double precision,external :: trace_matrix + +! Output variables + + double precision,intent(out) :: drho(3,nGrid) + + drho(:,:) = 0d0 + do iG=1,nGrid + do mu=1,nBas + do nu=1,nBas + do ixyz=1,3 + drho(ixyz,iG) = drho(ixyz,iG) & + + P(mu,nu)*(dAO(ixyz,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(ixyz,nu,iG)) + enddo + enddo + enddo + enddo + + do iG=1,nGrid + do ixyz=1,3 + if(abs(drho(ixyz,iG)) < thresh) drho(ixyz,iG) = thresh + enddo + enddo + +end subroutine gradient_density diff --git a/src/xcDFT/hartree_coulomb.f90 b/src/xcDFT/hartree_coulomb.f90 new file mode 100644 index 0000000..42f83d7 --- /dev/null +++ b/src/xcDFT/hartree_coulomb.f90 @@ -0,0 +1,33 @@ +subroutine hartree_coulomb(nBas,P,ERI,J) + +! Compute Coulomb matrix + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: mu,nu,la,si + +! Output variables + + double precision,intent(out) :: J(nBas,nBas) + + J = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + J(mu,nu) = J(mu,nu) + P(la,si)*ERI(mu,la,nu,si) + enddo + enddo + enddo + enddo + + +end subroutine hartree_coulomb diff --git a/src/xcDFT/lda_exchange_energy.f90 b/src/xcDFT/lda_exchange_energy.f90 new file mode 100644 index 0000000..dcffb30 --- /dev/null +++ b/src/xcDFT/lda_exchange_energy.f90 @@ -0,0 +1,36 @@ +subroutine lda_exchange_energy(nGrid,weight,rho,Ex) + +! Compute LDA exchange energy + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rho(nGrid) + +! Local variables + + integer :: iG + double precision :: alpha + +! Output variables + + double precision :: Ex + +! Cx coefficient for Slater LDA exchange + + alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) + +! Compute LDA exchange energy + + Ex = 0d0 + do iG=1,nGrid + Ex = Ex + weight(iG)*alpha*rho(iG)**(4d0/3d0) + enddo + + Ex = 2d0*Ex + +end subroutine lda_exchange_energy diff --git a/src/xcDFT/lda_exchange_potential.f90 b/src/xcDFT/lda_exchange_potential.f90 new file mode 100644 index 0000000..ece265f --- /dev/null +++ b/src/xcDFT/lda_exchange_potential.f90 @@ -0,0 +1,46 @@ +subroutine lda_exchange_potential(nGrid,weight,nBas,AO,rho,Fx) + +! Compute LDA exchange potential + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: rho(nGrid) + +! Local variables + + integer :: mu,nu,iG + double precision :: alpha + double precision :: r,vAO + +! Output variables + + double precision,intent(out) :: Fx(nBas,nBas) + +! Cx coefficient for Slater LDA exchange + + alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) + +! Compute LDA exchange matrix in the AO basis + + Fx(:,:) = 0d0 + do mu=1,nBas + do nu=1,nBas + do iG=1,nGrid + r = rho(iG) + + vAO = weight(iG)*AO(mu,iG)*AO(nu,iG) + Fx(mu,nu) = Fx(mu,nu) & + + vAO*4d0/3d0*alpha*r**(1d0/3d0) + + enddo + enddo + enddo + +end subroutine lda_exchange_potential diff --git a/src/xcDFT/obj/AO_values_grid.o b/src/xcDFT/obj/AO_values_grid.o new file mode 100644 index 0000000..5f828e0 Binary files /dev/null and b/src/xcDFT/obj/AO_values_grid.o differ diff --git a/src/xcDFT/obj/DIIS_extrapolation.o b/src/xcDFT/obj/DIIS_extrapolation.o new file mode 100644 index 0000000..4303988 Binary files /dev/null and b/src/xcDFT/obj/DIIS_extrapolation.o differ diff --git a/src/xcDFT/obj/NormCoeff.o b/src/xcDFT/obj/NormCoeff.o new file mode 100644 index 0000000..5c0e45d Binary files /dev/null and b/src/xcDFT/obj/NormCoeff.o differ diff --git a/src/xcDFT/obj/RKS.o b/src/xcDFT/obj/RKS.o new file mode 100644 index 0000000..762b74e Binary files /dev/null and b/src/xcDFT/obj/RKS.o differ diff --git a/src/xcDFT/obj/density.o b/src/xcDFT/obj/density.o new file mode 100644 index 0000000..3ffd7e2 Binary files /dev/null and b/src/xcDFT/obj/density.o differ diff --git a/src/xcDFT/obj/dft_grid.o b/src/xcDFT/obj/dft_grid.o new file mode 100644 index 0000000..c6b967f Binary files /dev/null and b/src/xcDFT/obj/dft_grid.o differ diff --git a/src/xcDFT/obj/electron_number.o b/src/xcDFT/obj/electron_number.o new file mode 100644 index 0000000..8b9e3d3 Binary files /dev/null and b/src/xcDFT/obj/electron_number.o differ diff --git a/src/xcDFT/obj/elements.o b/src/xcDFT/obj/elements.o new file mode 100644 index 0000000..22a9530 Binary files /dev/null and b/src/xcDFT/obj/elements.o differ diff --git a/src/xcDFT/obj/exchange_energy.o b/src/xcDFT/obj/exchange_energy.o new file mode 100644 index 0000000..4575016 Binary files /dev/null and b/src/xcDFT/obj/exchange_energy.o differ diff --git a/src/xcDFT/obj/exchange_potential.o b/src/xcDFT/obj/exchange_potential.o new file mode 100644 index 0000000..351f7df Binary files /dev/null and b/src/xcDFT/obj/exchange_potential.o differ diff --git a/src/xcDFT/obj/fock_exchange_energy.o b/src/xcDFT/obj/fock_exchange_energy.o new file mode 100644 index 0000000..6334bbc Binary files /dev/null and b/src/xcDFT/obj/fock_exchange_energy.o differ diff --git a/src/xcDFT/obj/fock_exchange_potential.o b/src/xcDFT/obj/fock_exchange_potential.o new file mode 100644 index 0000000..560303a Binary files /dev/null and b/src/xcDFT/obj/fock_exchange_potential.o differ diff --git a/src/xcDFT/obj/generate_shell.o b/src/xcDFT/obj/generate_shell.o new file mode 100644 index 0000000..3fe2420 Binary files /dev/null and b/src/xcDFT/obj/generate_shell.o differ diff --git a/src/xcDFT/obj/gga_exchange_energy.o b/src/xcDFT/obj/gga_exchange_energy.o new file mode 100644 index 0000000..3ee1638 Binary files /dev/null and b/src/xcDFT/obj/gga_exchange_energy.o differ diff --git a/src/xcDFT/obj/gga_exchange_potential.o b/src/xcDFT/obj/gga_exchange_potential.o new file mode 100644 index 0000000..3e8e3ee Binary files /dev/null and b/src/xcDFT/obj/gga_exchange_potential.o differ diff --git a/src/xcDFT/obj/gradient_density.o b/src/xcDFT/obj/gradient_density.o new file mode 100644 index 0000000..f3ccbb9 Binary files /dev/null and b/src/xcDFT/obj/gradient_density.o differ diff --git a/src/xcDFT/obj/hartree_coulomb.o b/src/xcDFT/obj/hartree_coulomb.o new file mode 100644 index 0000000..c472fdd Binary files /dev/null and b/src/xcDFT/obj/hartree_coulomb.o differ diff --git a/src/xcDFT/obj/lda_exchange_energy.o b/src/xcDFT/obj/lda_exchange_energy.o new file mode 100644 index 0000000..84f0bb6 Binary files /dev/null and b/src/xcDFT/obj/lda_exchange_energy.o differ diff --git a/src/xcDFT/obj/lda_exchange_potential.o b/src/xcDFT/obj/lda_exchange_potential.o new file mode 100644 index 0000000..d7e82da Binary files /dev/null and b/src/xcDFT/obj/lda_exchange_potential.o differ diff --git a/src/xcDFT/obj/one_electron_density.o b/src/xcDFT/obj/one_electron_density.o new file mode 100644 index 0000000..4074174 Binary files /dev/null and b/src/xcDFT/obj/one_electron_density.o differ diff --git a/src/xcDFT/obj/orthogonalization_matrix.o b/src/xcDFT/obj/orthogonalization_matrix.o new file mode 100644 index 0000000..d6118bc Binary files /dev/null and b/src/xcDFT/obj/orthogonalization_matrix.o differ diff --git a/src/xcDFT/obj/print_RKS.o b/src/xcDFT/obj/print_RKS.o new file mode 100644 index 0000000..1ffa8ee Binary files /dev/null and b/src/xcDFT/obj/print_RKS.o differ diff --git a/src/xcDFT/obj/quadrature_grid.o b/src/xcDFT/obj/quadrature_grid.o new file mode 100644 index 0000000..c72abac Binary files /dev/null and b/src/xcDFT/obj/quadrature_grid.o differ diff --git a/src/xcDFT/obj/read_basis.o b/src/xcDFT/obj/read_basis.o new file mode 100644 index 0000000..8395852 Binary files /dev/null and b/src/xcDFT/obj/read_basis.o differ diff --git a/src/xcDFT/obj/read_geometry.o b/src/xcDFT/obj/read_geometry.o new file mode 100644 index 0000000..c484873 Binary files /dev/null and b/src/xcDFT/obj/read_geometry.o differ diff --git a/src/xcDFT/obj/read_grid.o b/src/xcDFT/obj/read_grid.o new file mode 100644 index 0000000..9a2f7a9 Binary files /dev/null and b/src/xcDFT/obj/read_grid.o differ diff --git a/src/xcDFT/obj/read_integrals.o b/src/xcDFT/obj/read_integrals.o new file mode 100644 index 0000000..a9f7772 Binary files /dev/null and b/src/xcDFT/obj/read_integrals.o differ diff --git a/src/xcDFT/obj/read_molecule.o b/src/xcDFT/obj/read_molecule.o new file mode 100644 index 0000000..92700d1 Binary files /dev/null and b/src/xcDFT/obj/read_molecule.o differ diff --git a/src/xcDFT/obj/read_options.o b/src/xcDFT/obj/read_options.o new file mode 100644 index 0000000..fafcae0 Binary files /dev/null and b/src/xcDFT/obj/read_options.o differ diff --git a/src/xcDFT/obj/select_rung.o b/src/xcDFT/obj/select_rung.o new file mode 100644 index 0000000..51890aa Binary files /dev/null and b/src/xcDFT/obj/select_rung.o differ diff --git a/src/xcDFT/obj/utils.o b/src/xcDFT/obj/utils.o new file mode 100644 index 0000000..84d2a43 Binary files /dev/null and b/src/xcDFT/obj/utils.o differ diff --git a/src/xcDFT/obj/wrap_lapack.o b/src/xcDFT/obj/wrap_lapack.o new file mode 100644 index 0000000..c56d8e6 Binary files /dev/null and b/src/xcDFT/obj/wrap_lapack.o differ diff --git a/src/xcDFT/obj/xcDFT.o b/src/xcDFT/obj/xcDFT.o new file mode 100644 index 0000000..8914553 Binary files /dev/null and b/src/xcDFT/obj/xcDFT.o differ diff --git a/src/xcDFT/one_electron_density.f90 b/src/xcDFT/one_electron_density.f90 new file mode 100644 index 0000000..ee6a654 --- /dev/null +++ b/src/xcDFT/one_electron_density.f90 @@ -0,0 +1,47 @@ +subroutine one_electron_density(nGrid,nBas,P,AO,dAO,rho,drho) + +! Calculate one-electron density + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(3,nBas,nGrid) + +! Local variables + + integer :: ixyz,iG,mu,nu + double precision,external :: trace_matrix + +! Output variables + + double precision,intent(out) :: rho(nGrid) + double precision,intent(out) :: drho(3,nGrid) + + rho(:) = 0d0 + do iG=1,nGrid + do mu=1,nBas + do nu=1,nBas + rho(iG) = rho(iG) + AO(mu,iG)*P(mu,nu)*AO(nu,iG) + enddo + enddo + enddo + + drho(:,:) = 0d0 + do ixyz=1,3 + do iG=1,nGrid + do mu=1,nBas + do nu=1,nBas + drho(ixyz,iG) = drho(ixyz,iG) & + + P(mu,nu)*(dAO(ixyz,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(ixyz,nu,iG)) + enddo + enddo + enddo + enddo + +end subroutine one_electron_density diff --git a/src/xcDFT/orthogonalization_matrix.f90 b/src/xcDFT/orthogonalization_matrix.f90 new file mode 100644 index 0000000..ed837d4 --- /dev/null +++ b/src/xcDFT/orthogonalization_matrix.f90 @@ -0,0 +1,63 @@ +subroutine orthogonalization_matrix(nBas,S,X) + +! Compute the orthogonalization matrix X = S^(-1/2) + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: S(nBas,nBas) + +! Local variables + + logical :: debug + double precision,allocatable :: UVec(:,:),Uval(:) + double precision,parameter :: thresh = 1d-6 + + integer :: i + +! Output variables + + double precision,intent(out) :: X(nBas,nBas) + + debug = .false. + + allocate(Uvec(nBas,nBas),Uval(nBas)) + + write(*,*) + write(*,*) ' *** Lowdin orthogonalization X = S^(-1/2) *** ' + write(*,*) + + Uvec = S + call diagonalize_matrix(nBas,Uvec,Uval) + + do i=1,nBas + + if(Uval(i) > thresh) then + + Uval(i) = 1d0/sqrt(Uval(i)) + + else + + write(*,*) 'Eigenvalue',i,'too small for Lowdin orthogonalization' + + endif + + enddo + + call ADAt(nBas,Uvec,Uval,X) + +! Print results + + if(debug) then + + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Orthogonalization matrix' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,X) + write(*,*) + + endif + +end subroutine orthogonalization_matrix diff --git a/src/xcDFT/print_RKS.f90 b/src/xcDFT/print_RKS.f90 new file mode 100644 index 0000000..5082fa9 --- /dev/null +++ b/src/xcDFT/print_RKS.f90 @@ -0,0 +1,61 @@ +subroutine print_RKS(nBas,nO,e,C,ENuc,ET,EV,EJ,Ex,Ec,EKS) + +! Print one- and two-electron energies and other stuff for RKS calculation + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: e(nBas),c(nBas,nBas),ENuc,ET,EV,EJ,Ex,Ec,EKS + + integer :: HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = e(LUMO) - e(HOMO) + +! Dump results + + + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' Summary ' + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' One-electron energy ',ET + EV + write(*,'(A32,1X,F16.10)') ' Kinetic energy ',ET + write(*,'(A32,1X,F16.10)') ' Potential energy ',EV + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' Two-electron energy ',EJ + Ex + Ec + write(*,'(A32,1X,F16.10)') ' Coulomb energy ',EJ + write(*,'(A32,1X,F16.10)') ' Exchange energy ',Ex + write(*,'(A32,1X,F16.10)') ' Correlation energy ',Ec + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' Electronic energy ',EKS + write(*,'(A32,1X,F16.10)') ' Nuclear repulsion ',ENuc + write(*,'(A32,1X,F16.10)') ' Kohn-Sham energy ',EKS + ENuc + write(*,'(A50)') '---------------------------------------' + write(*,'(A36,F13.6)') ' KS HOMO energy (eV):',e(HOMO)*HatoeV + write(*,'(A36,F13.6)') ' KS LUMO energy (eV):',e(LUMO)*Hatoev + write(*,'(A36,F13.6)') ' KS HOMO-LUMO gap (eV):',Gap*Hatoev + write(*,'(A50)') '---------------------------------------' + write(*,*) + +! Print results + + write(*,'(A50)') '---------------------------------------' + write(*,'(A50)') 'Kohn-Sham orbital coefficients ' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,nBas,C) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A50)') ' Kohn-Sham orbital energies ' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,e) + write(*,*) + +end subroutine print_RKS + + diff --git a/src/xcDFT/quadrature_grid.f90 b/src/xcDFT/quadrature_grid.f90 new file mode 100644 index 0000000..420e80a --- /dev/null +++ b/src/xcDFT/quadrature_grid.f90 @@ -0,0 +1,77 @@ +subroutine quadrature_grid(nRad,nAng,nGrid,root,weight) + +! Build roots and weights of quadrature grid + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nRad,nAng,nGrid + +! Local variables + + integer :: i,j,k + double precision :: scale + double precision,allocatable :: Radius(:) + double precision,allocatable :: RadWeight(:) + double precision,allocatable :: XYZ(:,:) + double precision,allocatable :: XYZWeight(:) + +! Output variables + + double precision,intent(out) :: root(3,nGrid) + double precision,intent(out) :: weight(nGrid) + +! Memory allocation + + allocate(Radius(nRad),RadWeight(nRad),XYZ(3,nAng),XYZWeight(nAng)) + +! Findthe radial grid + + scale = 1d0 + call EulMac(Radius,RadWeight,nRad,scale) + + write(*,20) + write(*,30) + write(*,20) + do i = 1,nRad + write(*,40) i,Radius(i),RadWeight(i) + end do + write(*,20) + write(*,*) + +! Find the angular grid + + call Lebdev(XYZ,XYZWeight,nAng) + + write(*,20) + write(*,50) + write(*,20) + do j = 1,nAng + write(*,60) j,(XYZ(k,j),k=1,3), XYZWeight(j) + end do + write(*,20) + +! Form the roots and weights + + k = 0 + do i=1,nRad + do j=1,nAng + k = k + 1 + root(:,k) = Radius(i)*XYZ(:,j) + weight(k) = RadWeight(i)*XYZWeight(j) + enddo + enddo + +! Compute values of the basis functions (and the its gradient if required) at each grid point + +20 format(T2,58('-')) +30 format(T20,'Radial Quadrature',/, & + T6,'I',T26,'Radius',T50,'Weight') +40 format(T3,I4,T18,F17.10,T35,F25.10) +50 format(T20,'Angular Quadrature',/, & + T6,'I',T19,'X',T29,'Y',T39,'Z',T54,'Weight') +60 format(T3,I4,T13,3F10.5,T50,F10.5) + +end subroutine quadrature_grid diff --git a/src/xcDFT/read_basis.f90 b/src/xcDFT/read_basis.f90 new file mode 100644 index 0000000..403368d --- /dev/null +++ b/src/xcDFT/read_basis.f90 @@ -0,0 +1,117 @@ +subroutine read_basis(nAt,rAt,nBas,nO,nV,nShell,TotAngMomShell,CenterShell,KShell,DShell,ExpShell) + +! Read basis set information + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nAt,nO + double precision,intent(in) :: rAt(nAt,3) + +! Local variables + + integer :: nShAt,iAt,iShell + integer :: i,j,k + character :: shelltype + +! Output variables + + integer,intent(out) :: nShell,nBas,nV + double precision,intent(out) :: CenterShell(maxShell,3) + integer,intent(out) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(out) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +!------------------------------------------------------------------------ +! Primary basis set information +!------------------------------------------------------------------------ + +! Open file with basis set specification + + open(unit=2,file='input/basis') + +! Read basis information + + write(*,'(A28)') 'Gaussian basis set' + write(*,'(A28)') '------------------' + + nShell = 0 + do i=1,nAt + read(2,*) iAt,nShAt + write(*,'(A28,1X,I16)') 'Atom n. ',iAt + write(*,'(A28,1X,I16)') 'number of shells ',nShAt + write(*,'(A28)') '------------------' + +! Basis function centers + + do j=1,nShAt + nShell = nShell + 1 + do k=1,3 + CenterShell(nShell,k) = rAt(iAt,k) + enddo + +! Shell type and contraction degree + + read(2,*) shelltype,KShell(nShell) + if(shelltype == "S") then + TotAngMomShell(nShell) = 0 + write(*,'(A28,1X,I16)') 's-type shell with K = ',KShell(nShell) + elseif(shelltype == "P") then + TotAngMomShell(nShell) = 1 + write(*,'(A28,1X,I16)') 'p-type shell with K = ',KShell(nShell) + elseif(shelltype == "D") then + TotAngMomShell(nShell) = 2 + write(*,'(A28,1X,I16)') 'd-type shell with K = ',KShell(nShell) + elseif(shelltype == "F") then + TotAngMomShell(nShell) = 3 + write(*,'(A28,1X,I16)') 'f-type shell with K = ',KShell(nShell) + elseif(shelltype == "G") then + TotAngMomShell(nShell) = 4 + write(*,'(A28,1X,I16)') 'g-type shell with K = ',KShell(nShell) + elseif(shelltype == "H") then + TotAngMomShell(nShell) = 5 + write(*,'(A28,1X,I16)') 'h-type shell with K = ',KShell(nShell) + elseif(shelltype == "I") then + TotAngMomShell(nShell) = 6 + write(*,'(A28,1X,I16)') 'i-type shell with K = ',KShell(nShell) + endif + +! Read exponents and contraction coefficients + + write(*,'(A28,1X,A16,A16)') '','Exponents','Contraction' + do k=1,Kshell(nShell) + read(2,*) ExpShell(nShell,k),DShell(nShell,k) + write(*,'(A28,1X,F16.10,F16.10)') '',ExpShell(nShell,k),DShell(nShell,k) + enddo + enddo + write(*,'(A28)') '------------------' + enddo + +! Total number of shells + + write(*,'(A28,1X,I16)') 'Number of shells',nShell + write(*,'(A28)') '------------------' + write(*,*) + +! Close file with basis set specification + + close(unit=2) + +! Calculate number of basis functions + + nBas = 0 + do iShell=1,nShell + nBas = nBas + (TotAngMomShell(iShell)*TotAngMomShell(iShell) + 3*TotAngMomShell(iShell) + 2)/2 + enddo + + write(*,'(A28)') '------------------' + write(*,'(A28,1X,I16)') 'Number of basis functions',NBas + write(*,'(A28)') '------------------' + write(*,*) + +! Number of virtual orbitals + + nV = nBas - nO + +end subroutine read_basis diff --git a/src/xcDFT/read_geometry.f90 b/src/xcDFT/read_geometry.f90 new file mode 100644 index 0000000..8f0fc56 --- /dev/null +++ b/src/xcDFT/read_geometry.f90 @@ -0,0 +1,58 @@ +subroutine read_geometry(nAt,ZNuc,rA,ENuc) + +! Read molecular geometry + + implicit none + +! Ouput variables + integer,intent(in) :: nAt + +! Local variables + integer :: i,j + double precision :: RAB + +! Ouput variables + double precision,intent(out) :: ZNuc(NAt),rA(nAt,3),ENuc + + +! Open file with geometry specification + open(unit=1,file='input/molecule') + +! Read number of atoms + read(1,*) + read(1,*) + read(1,*) + + do i=1,nAt + read(1,*) ZNuc(i),rA(i,1),rA(i,2),rA(i,3) + enddo + +! Compute nuclear repulsion energy + ENuc = 0 + + do i=1,nAt-1 + do j=i+1,nAt + RAB = (rA(i,1)-rA(j,1))**2 + (rA(i,2)-rA(j,2))**2 + (rA(i,3)-rA(j,3))**2 + ENuc = ENuc + ZNuc(i)*ZNuc(j)/sqrt(RAB) + enddo + enddo + +! Close file with geometry specification + close(unit=1) + +! Print geometry + write(*,'(A28)') '------------------' + write(*,'(A28)') 'Molecular geometry' + write(*,'(A28)') '------------------' + do i=1,NAt + write(*,'(A28,1X,I16)') 'Atom n. ',i + write(*,'(A28,1X,F16.10)') 'Z = ',ZNuc(i) + write(*,'(A28,1X,F16.10,F16.10,F16.10)') 'Atom coordinates:',(rA(i,j),j=1,3) + enddo + write(*,*) + write(*,'(A28)') '------------------' + write(*,'(A28,1X,F16.10)') 'Nuclear repulsion energy = ',ENuc + write(*,'(A28)') '------------------' + write(*,*) + +end subroutine read_geometry diff --git a/src/xcDFT/read_grid.f90 b/src/xcDFT/read_grid.f90 new file mode 100644 index 0000000..fb2eb3d --- /dev/null +++ b/src/xcDFT/read_grid.f90 @@ -0,0 +1,47 @@ +subroutine read_grid(SGn,nRad,nAng,nGrid) + +! Read grid type + + implicit none + +! Input variables + + integer,intent(in) :: SGn + +! Output variables + + integer,intent(out) :: nRad + integer,intent(out) :: nAng + integer,intent(out) :: nGrid + + write(*,*)'----------------------------------------------------------' + write(*,'(A22,I1)')' Quadrature grid: SG-',SGn + write(*,*)'----------------------------------------------------------' + + select case (SGn) + + case(0) + nRad = 23 + nAng = 170 + + case(1) + nRad = 50 + nAng = 194 + + case(2) + nRad = 75 + nAng = 302 + + case(3) + nRad = 99 + nAng = 590 + + case default + write(*,*) '!!! Quadrature grid not available !!!' + stop + + end select + + nGrid = nRad*nAng + +end subroutine read_grid diff --git a/src/xcDFT/read_integrals.f90 b/src/xcDFT/read_integrals.f90 new file mode 100644 index 0000000..0644a99 --- /dev/null +++ b/src/xcDFT/read_integrals.f90 @@ -0,0 +1,114 @@ +subroutine read_integrals(nBas,S,T,V,Hc,G) + +! Read one- and two-electron integrals from files + + implicit none + +! Input variables + + integer,intent(in) :: nBas + +! Local variables + + logical :: debug + integer :: mu,nu,la,si + double precision :: Ov,Kin,Nuc,ERI + +! Output variables + + double precision,intent(out) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),G(nBas,nBas,nBas,nBas) + +! Open file with integrals + + debug = .false. + + open(unit=8 ,file='int/Ov.dat') + open(unit=9 ,file='int/Kin.dat') + open(unit=10,file='int/Nuc.dat') + open(unit=11,file='int/ERI.dat') + +! Read overlap integrals + + S = 0d0 + do + read(8,*,end=8) mu,nu,Ov + S(mu,nu) = Ov + enddo + 8 close(unit=8) + +! Read kinetic integrals + + T = 0d0 + do + read(9,*,end=9) mu,nu,Kin + T(mu,nu) = Kin + enddo + 9 close(unit=9) + +! Read nuclear integrals + + V = 0d0 + do + read(10,*,end=10) mu,nu,Nuc + V(mu,nu) = Nuc + enddo + 10 close(unit=10) + +! Define core Hamiltonian + + Hc = T + V + +! Read nuclear integrals + + G = 0d0 + do + read(11,*,end=11) mu,nu,la,si,ERI +! <12|34> + G(mu,nu,la,si) = ERI +! <32|14> + G(la,nu,mu,si) = ERI +! <14|32> + G(mu,si,la,nu) = ERI +! <34|12> + G(la,si,mu,nu) = ERI +! <41|23> + G(si,mu,nu,la) = ERI +! <23|41> + G(nu,la,si,mu) = ERI +! <21|43> + G(nu,mu,si,la) = ERI +! <43|21> + G(si,la,nu,mu) = ERI + enddo + 11 close(unit=11) + + +! Print results + if(debug) then + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Overlap integrals' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,S) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Kinetic integrals' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,T) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Nuclear integrals' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,V) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Electron repulsion integrals' + write(*,'(A28)') '----------------------' + do la=1,nBas + do si=1,nBas + call matout(nBas,nBas,G(1,1,la,si)) + enddo + enddo + write(*,*) + endif + +end subroutine read_integrals diff --git a/src/xcDFT/read_molecule.f90 b/src/xcDFT/read_molecule.f90 new file mode 100644 index 0000000..3094c80 --- /dev/null +++ b/src/xcDFT/read_molecule.f90 @@ -0,0 +1,42 @@ +subroutine read_molecule(nAt,nEl,nO) + +! Read number of atoms nAt and number of electrons nEl + + implicit none + +! Input variables + integer,intent(out) :: nAt,nEl,nO + +! Open file with geometry specification + + open(unit=1,file='input/molecule') + +! Read number of atoms and number of electrons + + read(1,*) + read(1,*) nAt,nEl + +! Number of occupied orbitals + + if(mod(nEl,2) /= 0) then + write(*,*) 'closed-shell system required!' + stop + endif + nO = nEl/2 + +! Print results + + write(*,'(A28)') '----------------------' + write(*,'(A28,1X,I16)') 'Number of atoms',nAt + write(*,'(A28)') '----------------------' + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28,1X,I16)') 'Number of electrons',nEl + write(*,'(A28)') '----------------------' + write(*,*) + +! Close file with geometry specification + + close(unit=1) + +end subroutine read_molecule diff --git a/src/xcDFT/read_options.f90 b/src/xcDFT/read_options.f90 new file mode 100644 index 0000000..2f414e3 --- /dev/null +++ b/src/xcDFT/read_options.f90 @@ -0,0 +1,31 @@ +subroutine read_options(rung,SGn) + +! Read DFT options + + implicit none + +! Input variables + + integer,intent(out) :: rung + integer,intent(out) :: SGn + +! Open file with method specification + + open(unit=1,file='input/options') + +! Default values + + rung = 1 + SGn = 0 + +! Read rung of Jacob's ladder + + read(1,*) + read(1,*) rung + +! Read SG-n grid + + read(1,*) + read(1,*) SGn + +end subroutine read_options diff --git a/src/xcDFT/select_rung.f90 b/src/xcDFT/select_rung.f90 new file mode 100644 index 0000000..60c988f --- /dev/null +++ b/src/xcDFT/select_rung.f90 @@ -0,0 +1,45 @@ +subroutine select_rung(rung) + +! Select rung of Jacob's ladder + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: rung + + select case (rung) + +! Hartree calculation + case(0) + write(*,*) " *** 0th rung of Jacob's ladder: Hartree calculation *** " + +! LDA functionals + case(1) + write(*,*) " *** 1st rung of Jacob's ladder: local-density approximation (LDA) *** " + +! GGA functionals + case(2) + write(*,*) " *** 2nd rung of Jacob's ladder: generalized gradient approximation (GGA) *** " + +! meta-GGA functionals + case(3) + write(*,*) " *** 3rd rung of Jacob's ladder: meta-GGA functional (MGGA) *** " + +! Hybrid functionals + case(4) + write(*,*) " *** 4th rung of Jacob's ladder: hybrid functional *** " + +! Hartree-Fock calculation + case(666) + write(*,*) " *** rung 666: Hartree-Fock calculation *** " + +! Default + case default + write(*,*) "!!! rung not available !!!" + stop + + end select + +end subroutine select_rung diff --git a/src/xcDFT/utils.f90 b/src/xcDFT/utils.f90 new file mode 100644 index 0000000..19df907 --- /dev/null +++ b/src/xcDFT/utils.f90 @@ -0,0 +1,246 @@ +!------------------------------------------------------------------------ +subroutine matout(m,n,A) + +! Print the MxN array A + + implicit none + + integer,parameter :: ncol = 5 + double precision,parameter :: small = 1d-10 + integer,intent(in) :: m,n + double precision,intent(in) :: A(m,n) + double precision :: B(ncol) + integer :: ilower,iupper,num,i,j + + do ilower=1,n,ncol + iupper = min(ilower + ncol - 1,n) + num = iupper - ilower + 1 + write(*,'(3X,10(9X,I6))') (j,j=ilower,iupper) + do i=1,m + do j=ilower,iupper + B(j-ilower+1) = A(i,j) + enddo + do j=1,num + if(abs(B(j)) < small) B(j) = 0d0 + enddo + write(*,'(I7,10F15.8)') i,(B(j),j=1,num) + enddo + enddo + +end subroutine matout +!------------------------------------------------------------------------ +function trace_matrix(n,A) result(Tr) + +! Calculate the trace of the square matrix A + + implicit none + +! Input variables + + integer,intent(in) :: n + double precision,intent(in) :: A(n,n) + +! Local variables + + integer :: i + +! Output variables + + double precision :: Tr + + Tr = 0d0 + do i=1,n + Tr = Tr + A(i,i) + enddo + +end function trace_matrix +!------------------------------------------------------------------------ +subroutine prepend(N,M,A,b) + +! Prepend the vector b of size N into the matrix A of size NxM + + implicit none + +! Input variables + + integer,intent(in) :: N,M + double precision,intent(in) :: b(N) + +! Local viaruabkes + + integer :: i,j + +! Output variables + + double precision,intent(out) :: A(N,M) + + +! print*,'b in append' +! call matout(N,1,b) + + do i=1,N + do j=M-1,1,-1 + A(i,j+1) = A(i,j) + enddo + A(i,1) = b(i) + enddo + +end subroutine prepend +!------------------------------------------------------------------------ +subroutine append(N,M,A,b) + +! Append the vector b of size N into the matrix A of size NxM + + implicit none + +! Input variables + + integer,intent(in) :: N,M + double precision,intent(in) :: b(N) + +! Local viaruabkes + + integer :: i,j + +! Output variables + + double precision,intent(out) :: A(N,M) + + do i=1,N + do j=2,M + A(i,j-1) = A(i,j) + enddo + A(i,M) = b(i) + enddo + +end subroutine append +!------------------------------------------------------------------------ +subroutine AtDA(N,A,D,B) + +! Perform B = At.D.A where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + +! Input variables + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),D(N) + +! Local viaruabkes + + integer :: i,j,k + +! Output variables + + double precision,intent(out) :: B(N,N) + + B = 0d0 + + do i=1,N + do j=1,N + do k=1,N + B(i,k) = B(i,k) + A(j,i)*D(j)*A(j,k) + enddo + enddo + enddo + +end subroutine AtDA +!------------------------------------------------------------------------ +subroutine ADAt(N,A,D,B) + +! Perform B = A.D.At where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + +! Input variables + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),D(N) + +! Local viaruabkes + + integer :: i,j,k + +! Output variables + + double precision,intent(out) :: B(N,N) + + B = 0d0 + + do i=1,N + do j=1,N + do k=1,N + B(i,k) = B(i,k) + A(i,j)*D(j)*A(k,j) + enddo + enddo + enddo + +end subroutine ADAt +!------------------------------------------------------------------------ +subroutine DA(N,D,A) + +! Perform A <- D.A where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + + integer,intent(in) :: N + integer :: i,j + double precision,intent(in) :: D(N) + double precision,intent(inout):: A(N,N) + + do i=1,N + do j=1,N + A(i,j) = D(i)*A(i,j) + enddo + enddo + +end subroutine DA + +!------------------------------------------------------------------------ +subroutine AD(N,A,D) + +! Perform A <- A.D where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + + integer,intent(in) :: N + integer :: i,j + double precision,intent(in) :: D(N) + double precision,intent(inout):: A(N,N) + + do i=1,N + do j=1,N + A(i,j) = A(i,j)*D(j) + enddo + enddo + +end subroutine AD +!------------------------------------------------------------------------ +recursive function fac(n) result(fact) + + implicit none + integer :: fact + integer, intent(in) :: n + + if (n == 0) then + fact = 1 + else + fact = n * fac(n-1) + end if + +end function fac + +function dfac(n) result(fact) + + implicit none + double precision :: fact + integer, intent(in) :: n + integer :: fac + + fact = dble(fac(n)) + +end function dfac diff --git a/src/xcDFT/wrap_lapack.f90 b/src/xcDFT/wrap_lapack.f90 new file mode 100644 index 0000000..aff8f60 --- /dev/null +++ b/src/xcDFT/wrap_lapack.f90 @@ -0,0 +1,147 @@ +subroutine diagonalize_matrix(N,A,e) + +! Diagonalize a square matrix + + implicit none + +! Input variables + + integer,intent(in) :: N + double precision,intent(inout):: A(N,N) + double precision,intent(out) :: e(N) + +! Local variables + + integer :: lwork,info + double precision,allocatable :: work(:) + +! Memory allocation + + allocate(work(3*N)) + lwork = size(work) + + call dsyev('V','U',N,A,N,e,work,lwork,info) + + if(info /= 0) then + print*,'Problem in diagonalize_matrix (dsyev)!!' + stop + endif + +end subroutine diagonalize_matrix + +subroutine svd(N,A,U,D,Vt) + + ! Compute A = U.D.Vt + ! Dimension of A is NxN + + implicit none + + integer, intent(in) :: N + double precision,intent(in) :: A(N,N) + double precision,intent(out) :: U(N,N) + double precision,intent(out) :: Vt(N,N) + double precision,intent(out) :: D(N) + double precision,allocatable :: work(:) + integer :: info,lwork + + double precision,allocatable :: scr(:,:) + + allocate (scr(N,N)) + + scr(:,:) = A(:,:) + + ! Find optimal size for temporary arrays + + allocate(work(1)) + + lwork = -1 + call dgesvd('A','A',N,N,scr,N,D,U,N,Vt,N,work,lwork,info) + lwork = int(work(1)) + + deallocate(work) + + allocate(work(lwork)) + + call dgesvd('A','A',N,N,scr,N,D,U,N,Vt,N,work,lwork,info) + + deallocate(work,scr) + + if (info /= 0) then + print *, info, ': SVD failed' + stop + endif + +end + +subroutine inverse_matrix(N,A,B) + +! Returns the inverse of the square matrix A in B + + implicit none + + integer,intent(in) :: N + double precision, intent(in) :: A(N,N) + double precision, intent(out) :: B(N,N) + + integer :: info,lwork + integer, allocatable :: ipiv(:) + double precision,allocatable :: work(:) + + allocate (ipiv(N),work(N*N)) + lwork = size(work) + + B(1:N,1:N) = A(1:N,1:N) + + call dgetrf(N,N,B,N,ipiv,info) + + if (info /= 0) then + + print*,info + stop 'error in inverse (dgetrf)!!' + + endif + + call dgetri(N,B,N,ipiv,work,lwork,info) + + if (info /= 0) then + + print *, info + stop 'error in inverse (dgetri)!!' + + endif + + deallocate(ipiv,work) + +end subroutine inverse_matrix + +subroutine linear_solve(N,A,b,x) + +! Solve the linear system A.x = b where A is a NxN matrix +! and x and x are vectors of size N + + implicit none + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),b(N) + double precision,intent(out) :: x(N) + + integer :: info,lwork + integer,allocatable :: ipiv(:) + double precision,allocatable :: work(:) + + allocate(ipiv(N),work(N*N)) + lwork = size(work) + + x = b + + call dsysv('U',N,1,A,N,ipiv,x,N,work,lwork,info) + + if (info /= 0) then + + print *, info + stop 'error in linear_solve (dsysv)!!' + + endif + +end subroutine linear_solve + diff --git a/src/xcDFT/xcDFT.f90 b/src/xcDFT/xcDFT.f90 new file mode 100644 index 0000000..e20e046 --- /dev/null +++ b/src/xcDFT/xcDFT.f90 @@ -0,0 +1,120 @@ +program xcDFT + +! exchange-correlation density-functional theory calculations + + include 'parameters.h' + + integer :: nAt,nBas,nEl,nO,nV + double precision :: ENuc,EKS + + double precision,allocatable :: ZNuc(:),rAt(:,:) + + integer :: nShell + integer,allocatable :: TotAngMomShell(:) + integer,allocatable :: KShell(:) + double precision,allocatable :: CenterShell(:,:) + double precision,allocatable :: DShell(:,:) + double precision,allocatable :: ExpShell(:,:) + + double precision,allocatable :: S(:,:),T(:,:),V(:,:),Hc(:,:),X(:,:) + double precision,allocatable :: ERI(:,:,:,:) + + integer :: rung + integer :: SGn + integer :: nRad,nAng,nGrid + double precision,allocatable :: root(:,:) + double precision,allocatable :: weight(:) + double precision,allocatable :: AO(:,:) + double precision,allocatable :: dAO(:,:,:) + + double precision :: start_KS,end_KS,t_KS + +! Hello World + + write(*,*) + write(*,*) '********************************' + write(*,*) '* TCCM winter school 2008: DFT *' + write(*,*) '********************************' + write(*,*) + +!------------------------------------------------------------------------ +! Read input information +!------------------------------------------------------------------------ + +! Read number of atoms, number of electrons of the system +! nO = number of occupied orbitals +! nV = number of virtual orbitals (see below) +! nBas = number of basis functions (see below) +! = nO + nV + + call read_molecule(nAt,nEl,nO) + allocate(ZNuc(nAt),rAt(nAt,3)) + +! Read geometry + + call read_geometry(nAt,ZNuc,rAt,ENuc) + + allocate(CenterShell(maxShell,3),TotAngMomShell(maxShell),KShell(maxShell), & + DShell(maxShell,maxK),ExpShell(maxShell,maxK)) + +!------------------------------------------------------------------------ +! Read basis set information +!------------------------------------------------------------------------ + + call read_basis(nAt,rAt,nBas,nO,nV,nShell,TotAngMomShell,CenterShell,KShell,DShell,ExpShell) + +!------------------------------------------------------------------------ +! Read one- and two-electron integrals +!------------------------------------------------------------------------ + +! Memory allocation for one- and two-electron integrals + + allocate(S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),X(nBas,nBas), & + ERI(nBas,nBas,nBas,nBas)) + +! Read integrals + + call read_integrals(nBas,S,T,V,Hc,ERI) + +! Orthogonalization X = S^(-1/2) + + call orthogonalization_matrix(nBas,S,X) + +!------------------------------------------------------------------------ +! DFT options +!------------------------------------------------------------------------ + + call read_options(rung,SGn) + +!------------------------------------------------------------------------ +! Construct quadrature grid +!------------------------------------------------------------------------ + call read_grid(SGn,nRad,nAng,nGrid) + + allocate(root(3,nGrid),weight(nGrid)) + call quadrature_grid(nRad,nAng,nGrid,root,weight) + +!------------------------------------------------------------------------ +! Calculate AO values at grid points +!------------------------------------------------------------------------ + + allocate(AO(nBas,nGrid),dAO(3,nBas,nGrid)) + call AO_values_grid(nBas,nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + nGrid,root,AO,dAO) + +!------------------------------------------------------------------------ +! Compute KS energy +!------------------------------------------------------------------------ + + call cpu_time(start_KS) + call RKS(rung,nGrid,weight,nBas,AO,dAO,nO,S,T,V,Hc,ERI,X,ENuc,EKS) + call cpu_time(end_KS) + + t_KS = end_KS - start_KS + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for KS = ',t_KS,' seconds' + write(*,*) + +!------------------------------------------------------------------------ +! End of xcDFT +!------------------------------------------------------------------------ +end program xcDFT diff --git a/utils/cp2input b/utils/cp2input new file mode 100755 index 0000000..2d1ee76 --- /dev/null +++ b/utils/cp2input @@ -0,0 +1,17 @@ +#! /bin/bash + +if [ $# -lt 2 ] +then + echo "At least 2 arguments required [Molecule] [Basis] [AuxBasis] !!" +fi +if [ $# = 2 ] +then + cp molecule."$1" ../input/molecule + cp basis."$1"."$2" ../input/basis +elif [ $# = 3 ] +then + cp molecule."$1" ../input/molecule + cp basis."$1"."$2" ../input/basis + cp auxbasis."$1"."$3" ../input/auxbasis +fi + diff --git a/utils/create_function.sh b/utils/create_function.sh new file mode 100755 index 0000000..1c124ff --- /dev/null +++ b/utils/create_function.sh @@ -0,0 +1,42 @@ +#!/bin/bash + +if [ $# != 2 ] +then + echo "Two arguments required [name of function] [name of result]" +fi +if [ $# = 2 ] +then + + NAME=$1 + +echo "function ${NAME}() result(${RES}) + +! Description of the function + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: + double precision,intent(in) :: + +! Local variables + + integer :: + double precision :: + +! Output variables + + integer,intent(out) :: + double precision,intent(out) :: + +! Initalization + +end function ${NAME}" > ${NAME}.f90 + +fi + + + diff --git a/utils/create_subroutine.sh b/utils/create_subroutine.sh new file mode 100755 index 0000000..e2f2a49 --- /dev/null +++ b/utils/create_subroutine.sh @@ -0,0 +1,42 @@ +#!/bin/bash + +if [ $# != 1 ] +then + echo "One argument required [name of subroutine]" +fi +if [ $# = 1 ] +then + + NAME=$1 + +echo "subroutine ${NAME}() + +! Description of the subroutine + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: + double precision,intent(in) :: + +! Local variables + + integer :: + double precision :: + +! Output variables + + integer,intent(out) :: + double precision,intent(out) :: + +! Initalization + +end subroutine ${NAME}" > ${NAME}.f90 + +fi + + + diff --git a/utils/fsplit b/utils/fsplit new file mode 100755 index 0000000..e967b15 Binary files /dev/null and b/utils/fsplit differ diff --git a/utils/install_lapack.sh b/utils/install_lapack.sh new file mode 100755 index 0000000..203d7fb --- /dev/null +++ b/utils/install_lapack.sh @@ -0,0 +1,7 @@ +#!/bin/bash -x + +git clone https://github.com/Reference-LAPACK/lapack-release.git +cd lapack-release +cp make.inc.example make.inc +make -j 8 +mv librefblas.a liblapack.a libtmglib.a /Users/loos/Dropbox/quack/lib diff --git a/utils/lapack-release b/utils/lapack-release new file mode 160000 index 0000000..ba3779a --- /dev/null +++ b/utils/lapack-release @@ -0,0 +1 @@ +Subproject commit ba3779a6813d84d329b73aac86afc4e041170609 diff --git a/utils/reblock.f90 b/utils/reblock.f90 new file mode 100644 index 0000000..063344b --- /dev/null +++ b/utils/reblock.f90 @@ -0,0 +1,2764 @@ +!--------------------------------------------------------------------! +! REBLOCK ! +! ======= ! +! Neil Drummond, 8.2005 ! +! (Based on earlier MDT reblock utility for old-style .hist files) ! +! ! +! This utility performs a statistical analysis of the raw QMC data ! +! held in the .hist file. The reblocking procedure is ! +! necessary in order to obtain reliable statistical error bars for ! +! the mean values of serially correlated data. Please refer to the ! +! CASINO manual for further information about the procedure. ! +! ! +! Changes ! +! NDD 9.05 Data files renamed vmc.hist, etc. Check for old format.! +! Other new checks on files. ! +! NDD 9.05 Changed format of .hist files (again). ! +! AB 5.06 Add reblocking analysis for future walking estimators. ! +! AB 11.07 Add reblocking analysis of forces and introduce a line ! +! break in the .hist file to allow storing many items. ! +! NDD 05.08 Rearranged output, to put important stuff at end. ! +! NDD 05.10 Allow for FISQ data in qmc.hist. ! +!--------------------------------------------------------------------! + + +MODULE stats_calcs +!-------------------------------------------------------------------! +! A collection of subroutines for performing various statistical ! +! analyses of data. ! +!-------------------------------------------------------------------! + IMPLICIT NONE + + +CONTAINS + + + SUBROUTINE compute_stats_unweighted(want_skew_kurt,n,data_arr,av,var,skew, & + &kurt,max_val,min_val) +!-------------------------------------------------------------------! +! Compute mean, variance, skewness, kurtosis and max and min of a ! +! set of data. ! +!-------------------------------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: n + DOUBLE PRECISION,INTENT(in) :: data_arr(n) + LOGICAL,INTENT(in) :: want_skew_kurt + DOUBLE PRECISION,INTENT(out) :: av,var,skew,kurt,max_val,min_val + INTEGER i + DOUBLE PRECISION sum_delta_x2,sum_delta_x3,sum_delta_x4 + + if(n<2)then + write(6,*)'Can''t compute variance with fewer than two points.' + stop + endif + +! Compute average. + av=sum(data_arr(1:n))/dble(n) + +! Compute max and min. + max_val=maxval(data_arr(1:n)) + min_val=minval(data_arr(1:n)) + + if(want_skew_kurt)then +! Compute variance, skewness and kurtosis. + sum_delta_x2=0.d0 ; sum_delta_x3=0.d0 ; sum_delta_x4=0.d0 + do i=1,n + sum_delta_x2=sum_delta_x2+(data_arr(i)-av)**2 + sum_delta_x3=sum_delta_x3+(data_arr(i)-av)**3 + sum_delta_x4=sum_delta_x4+(data_arr(i)-av)**4 + enddo ! i + var=sum_delta_x2/dble(n-1) + if(var>0.d0)then + skew=((sqrt(dble(n-1))*dble(n))/dble(n-2))*sum_delta_x3/sum_delta_x2**1.5d0 + kurt=((dble(n+1)*dble(n)*dble(n-1))/(dble(n-2)*dble(n-3)))*& + &sum_delta_x4/sum_delta_x2**2-& + &((dble(n-1)*dble(n-1))/(dble(n-2)*dble(n-3)))*3.d0 + else + skew=0.d0 + kurt=0.d0 + endif + else +! Compute variance. + sum_delta_x2=0.d0 + do i=1,n + sum_delta_x2=sum_delta_x2+(data_arr(i)-av)**2 + enddo ! i + var=sum_delta_x2/dble(n-1) + skew=0.d0 + kurt=0.d0 + endif ! want_skew_kurt + + END SUBROUTINE compute_stats_unweighted + + + SUBROUTINE reblock_unweighted(no_pts,data_array,block_length,av, & + &std_err,delta_std_err) +!---------------------------------------------------------------! +! Compute the unweighted average of the data, and calculate the ! +! error bar for a given block length. ! +!---------------------------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: no_pts,block_length + DOUBLE PRECISION,INTENT(in) :: data_array(:) + DOUBLE PRECISION,INTENT(out) :: av,std_err,delta_std_err + INTEGER i,k,no_blocks,no_pts_in_last_block,j + DOUBLE PRECISION last_block_weight,var,tot_weight, & + &tot_weight_sq,block_av,red_tot_weight,rec_block_length + +! Compute average of data. + av=sum(data_array(1:no_pts))/dble(no_pts) + +! Number of blocks. + no_blocks=no_pts/block_length + rec_block_length=1.d0/dble(block_length) + +! Evaluate the sum of the squares of the deviations from the average. +! Weight the last, incomplete block by its size as a fraction of the others. + var=0.d0 + k=0 + do i=1,no_blocks + block_av=0.d0 + do j=1,block_length + k=k+1 + block_av=block_av+data_array(k) + enddo ! j + block_av=block_av*rec_block_length + var=var+(block_av-av)**2 + enddo ! i + block_av=0.d0 + no_pts_in_last_block=0 + do + k=k+1 + if(k>no_pts)exit + no_pts_in_last_block=no_pts_in_last_block+1 + block_av=block_av+data_array(k) + enddo ! k + last_block_weight=dble(no_pts_in_last_block)*rec_block_length + if(no_pts_in_last_block>0)then + block_av=block_av/dble(no_pts_in_last_block) + var=var+(block_av-av)**2*last_block_weight + endif ! last block nonzero + +! Evaluate variance, standard error in mean and error in standard error. + tot_weight=dble(no_blocks)+last_block_weight + tot_weight_sq=dble(no_blocks)+last_block_weight**2 + red_tot_weight=tot_weight-tot_weight_sq/tot_weight + var=var/red_tot_weight + std_err=sqrt(var/tot_weight) + if(tot_weight>1.d0)then + delta_std_err=std_err/sqrt(2.d0*(tot_weight-1.d0)) + else + delta_std_err=0.d0 + endif + + END SUBROUTINE reblock_unweighted + + + SUBROUTINE reblock_weighted(no_pts,data_array,weight_array,block_length, & + &av,std_err,delta_std_err) +!--------------------------------------------------------------! +! Compute the weighted average of the data, and calculate the ! +! error bar for a given block length. ! +!--------------------------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: no_pts,block_length + DOUBLE PRECISION,INTENT(in) :: weight_array(no_pts),data_array(no_pts) + DOUBLE PRECISION,INTENT(out) :: av,std_err,delta_std_err + INTEGER i,k,no_blocks,no_pts_in_last_block,j + DOUBLE PRECISION var,tot_weight, & + &tot_weight_sq,block_av,red_tot_weight,block_weight, & + &eff_no_blocks + +! Compute average of data. + av=0.d0 + tot_weight=0.d0 + do i=1,no_pts + av=av+data_array(i)*weight_array(i) + tot_weight=tot_weight+weight_array(i) + enddo ! i + av=av/tot_weight + +! Number of blocks + no_blocks=no_pts/block_length + +! Evaluate the sum of the squares of the deviations from the average. +! Last, incomplete block has fewer data points and hence a smaller weight. + var=0.d0 + tot_weight_sq=0.d0 + k=0 + do i=1,no_blocks + block_av=0.d0 + block_weight=0.d0 + do j=1,block_length + k=k+1 + block_av=block_av+data_array(k)*weight_array(k) + block_weight=block_weight+weight_array(k) + enddo ! j + block_av=block_av/block_weight + var=var+(block_av-av)**2*block_weight + tot_weight_sq=tot_weight_sq+block_weight**2 + enddo ! i + block_av=0.d0 + block_weight=0.d0 + no_pts_in_last_block=0 + do + k=k+1 + if(k>no_pts)exit + no_pts_in_last_block=no_pts_in_last_block+1 + block_av=block_av+data_array(k)*weight_array(k) + block_weight=block_weight+weight_array(k) + enddo ! k + if(no_pts_in_last_block>0)then + block_av=block_av/block_weight + var=var+(block_av-av)**2*block_weight + tot_weight_sq=tot_weight_sq+block_weight**2 + endif ! last block nonzero + +! Evaluate variance, standard error in mean and error in standard error. + red_tot_weight=tot_weight-tot_weight_sq/tot_weight + var=var/red_tot_weight + + eff_no_blocks=dble(no_blocks)+dble(no_pts_in_last_block)/dble(block_length) + + std_err=sqrt(var/eff_no_blocks) + if(eff_no_blocks>1.d0)then + delta_std_err=std_err/sqrt(2.d0*(eff_no_blocks-1.d0)) + else + delta_std_err=0.d0 + endif + + END SUBROUTINE reblock_weighted + + + SUBROUTINE correlation_time(n,Odata,Otau,Otau_err,Oave_in,Ovar_in) +!------------------------------------------------------------------------! +! Obtain correlation time from a set of data ! +!------------------------------------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: n + DOUBLE PRECISION,INTENT(in) :: Odata(n) + DOUBLE PRECISION,INTENT(in),OPTIONAL :: Oave_in,Ovar_in + DOUBLE PRECISION,INTENT(out) :: Otau,Otau_err + DOUBLE PRECISION Oave,Oave2,O2ave,Ovar,invOvar,Oacorr,ri,invn + DOUBLE PRECISION,PARAMETER :: tol=1.d-100 + INTEGER i,sqrtn + + Otau=-1.d0 ; Otau_err=-1.d0 + if(n<10)return + invn=1.d0/dble(n) + sqrtn=nint(sqrt(dble(n))) + +! , **2, , variance + if(present(Oave_in))then + Oave=Oave_in + else + Oave=sum(Odata)*invn + endif + if(present(Ovar_in))then + Ovar=Ovar_in*invn*(n-1) + else + Oave2=Oave**2 + O2ave=sum(Odata**2)*invn + Ovar=O2ave-Oave2 + endif + if(Ovar tau + Otau=1.d0 + do i=1,n-1 + Oacorr=sum((Odata(1:n-i)-Oave)*(Odata(1+i:n)-Oave))*invOvar/dble(n-i) + Otau=Otau+2*Oacorr + if(i>=nint(3*Otau))then + ri=dble(i) ; exit + endif + enddo + +! Error in tau + Otau_err=Otau*sqrt((4*ri+2.d0)*invn) + + END SUBROUTINE correlation_time + + +END MODULE stats_calcs + + +MODULE analysis +!-------------------------------------------------------------! +! Miscellaneous subroutines for reading & analysing the data. ! +!-------------------------------------------------------------! + USE stats_calcs + IMPLICIT NONE + +! Tags for the columns of the data file, specifying where each data item +! is held. If a tag is negative, the data item isn't present. + INTEGER tag_step,tag_energy,tag_etotalt,tag_esqr,tag_popavgsqr,tag_K,tag_T, & + &tag_fisq,tag_Ewald,tag_local,tag_nonlocal,tag_short,tag_long,tag_cppei, & + &tag_cppe,tag_cppee,tag_masspol,tag_massvel,tag_darwinen,tag_darwinee, & + &tag_retard,tag_weight,tag_nconf,tag_eref,tag_ebest,tag_acc,tag_teff, & + &tag_dipole1,tag_dipole2,tag_dipole3,tag_dipole_sq,tag_contact_den, & + &tag_future0,tag_future1,tag_future2,tag_future3,tag_future4,tag_future5, & + &tag_future6,tag_future7,tag_future8,tag_future9,tag_future10 + +! Number of columns of data in .hist file. + INTEGER no_cols_qmc + +! Title of .hist file + CHARACTER(72) title + +! File version number + INTEGER version + +! CASINO input keywords: interaction type and basis type. + CHARACTER(20) interaction,atom_basis_type + +! Do we have Ewald/Coulomb interaction? Do we have MPC interaction? + LOGICAL coul_mpc,coul_ewald + +! Ion-ion energy + DOUBLE PRECISION constant_energy + +! Total number of electrons; no. of atoms per prim cell; no. primitive cells + INTEGER netot,nbasis,npcells + +! Number of parts in simulation cell: +! =npcells for periodic systems +! =netot for electron gas +! =1 otherwise + INTEGER nparts_per_simcell + +! Is the system periodic? + LOGICAL isperiodic + +! QMC method used + CHARACTER(3) qmc_method + +! Number of lines of data. + INTEGER Nlines + +! Number of equilibration lines. + INTEGER Nequil + +! Name of .hist file. + CHARACTER(8) filename + +! Number of initial lines to discard. + INTEGER Nskip + +! Array with the hist data from the files. + DOUBLE PRECISION,ALLOCATABLE :: data_array(:,:) + +! Energy units + CHARACTER(15) e_units + +! Units conversion: a.u.->eV and a.u.->kcal. + DOUBLE PRECISION,PARAMETER :: htoev=27.2113962d0,htokcal=627.507541278d0 + +! Are forces to be calculated? + INTEGER iion,iaxis,item,nitot_forces,naxis_forces,nitem_forces,& + &nitot_max_forces + INTEGER,ALLOCATABLE :: tag_forces(:,:,:) + DOUBLE PRECISION,ALLOCATABLE :: forces_array(:,:) + LOGICAL forces + + ! Use weights when calculating average energy, etc. + LOGICAL,PARAMETER :: use_weights=.true. + + +CONTAINS + + + SUBROUTINE read_header(io,dmc) +!----------------------------------------------------------------------! +! Read in the data in the .hist file header and count the lines, etc. ! +!----------------------------------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: io + LOGICAL,INTENT(in) :: dmc + INTEGER ierr,i,s,isper_flag,nbreak,ialloc + CHARACTER(1) temp + CHARACTER(72) datastring + CHARACTER(500) checkline + LOGICAL,PARAMETER :: verbose=.false. + +! Check we don't have an old-style .hist file. + rewind(io) + read(io,'(a)',iostat=ierr)checkline + call check_ierr(ierr) + checkline=adjustl(checkline) + if(index(checkline,'Block')>0)then + write(6,*)'You appear to be analyzing a CASINO version 1 vmc.hist file. & + &Please use the' + write(6,*)'UPDATE_HIST utility to update it to the new format.' + stop + endif ! Old-style vmc.hist + if(index(checkline,'#')==0)then + write(6,*)'Your data file does not seem to start with a header. & + &This may be because you' + write(6,*)'are using an old-format file. If this is the case then & + &please use UPDATE_HIST' + write(6,*)'to update your file.' + stop + endif ! No header. + +! Count the data lines. Ignore comments. + rewind(io) + Nlines=0 + Nequil=0 + forces=.false. + do + read(io,'(a)',iostat=ierr)datastring + if(ierr>0)then + write(6,*)'Error reading data file.' + stop + endif + if(ierr<0)exit + if(index(datastring,'#')==0)then + Nlines=Nlines+1 + else + if(trim(adjustl(datastring))=='#### START STATS')Nequil=Nlines + endif ! Line not a comment. + if(.not.forces)then + if(index(datastring,'FOR')>0)forces=.true. ! atomic forces present + endif + enddo ! lines + if(dmc.and.Nequil==0)Nequil=Nlines + rewind(io) + if(verbose)then + if(Nlines/=1)then + write(6,*)'There are '//trim(i2s(Nlines))//' lines of data in ' & + &//trim(filename)//'.' + else + write(6,*)'There is 1 line of data in '//trim(filename)//'.' + endif ! Singular / plural + if(Nequil>1)then + write(6,*)'Of these, '//trim(i2s(Nlines))//' lines are marked as & + &equilibration data.' + elseif(Nequil==1)then + write(6,*)'Of these, 1 line is marked as equilibration data.' + else + write(6,*)'No data are marked as equilibration data.' + endif ! Nequil + endif ! verbose + if(Nlines<2)then + write(6,*)'There are less than two lines of data in '//trim(filename)//'.' + write(6,*)'One cannot obtain error bars with fewer than 2 data points.' + stop + endif + +! Get title. + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + read(io,'(a)',iostat=ierr)datastring + call check_ierr(ierr) + s=index(datastring,'#') + if(s>0)then + title=datastring(s+1:len_trim(datastring)) + else + write(6,*)'Header line does not have a "#" in front. Stopping.' + stop + endif + title=adjustl(title) + if(verbose)write(6,*)'Title: '//trim(title) + +! Get version number. + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + read(io,*,iostat=ierr)temp,version + call check_ierr(ierr) + call check_hash(temp) + if(verbose)write(6,*)'File version number is '//trim(i2s(version))//'.' + if(version/=1)then + write(6,*)'Version number of '//trim(filename)//' must be 1.' + stop + endif ! version/=1 + +! Get QMC method. + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + read(io,*,iostat=ierr)temp,qmc_method + call check_ierr(ierr) + call check_hash(temp) + qmc_method=adjustl(qmc_method) + if(verbose)write(6,*)'The data were generated using '//trim(qmc_method)//'.' + if(trim(qmc_method)/='VMC'.and.trim(qmc_method)/='DMC')then + write(6,*)'Method in '//trim(filename)//' should be either VMC or DMC.' + stop + endif ! method + if(trim(filename)=='vmc.hist'.and.trim(qmc_method)/='VMC')then + write(6,*)'Warning: you appear to have non-VMC data in a file called & + &vmc.hist.' + write(6,*) + endif + if(trim(filename)=='dmc.hist'.and.trim(qmc_method)/='DMC')then + write(6,*)'Warning: you appear to have non-DMC data in a file called & + &dmc.hist.' + write(6,*) + endif + +! Get interaction-type (interaction). + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + read(io,*,iostat=ierr)temp,interaction + call check_ierr(ierr) + call check_hash(temp) + coul_ewald=.false. ; coul_mpc=.false. + select case(trim(interaction)) + case('none','coulomb','ewald','mpc','ewald_mpc','mpc_ewald','manual') + continue + case('1') ; interaction='default' + case('2') ; interaction='mpc' + case('3') ; interaction='ewald_mpc' + case('4') ; interaction='mpc_ewald' + case default + write(6,*)'Value of INTERACTION=',trim(interaction),' not recognized. & + &Stopping.' + stop + end select + select case(trim(interaction)) + case('none') ; continue + case('coulomb','ewald','default','manual') ; coul_ewald=.true. + case('mpc') ; coul_mpc=.true. + case('ewald_mpc','mpc_ewald') ; coul_ewald=.true. ; coul_mpc=.true. + end select + if(verbose)write(6,*)'The value of the interaction parameter is ',& + &trim(interaction),'.' + +! Get constant (ion-ion) energy. + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + read(io,*,iostat=ierr)temp,constant_energy + call check_ierr(ierr) + call check_hash(temp) + if(verbose)write(6,*)'Have got constant energy component.' + +! Get total number of electrons. + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + read(io,*,iostat=ierr)temp,netot + call check_ierr(ierr) + call check_hash(temp) + if(verbose)then + if(netot/=1)then + write(6,*)'There are '//trim(i2s(netot))//' particles in the simulation.' + else + write(6,*)'There is 1 particle in the simulation.' + endif + endif ! verbose + if(netot<1)then + write(6,*)'Should be more than one particle!' + stop + endif + +! Get number of atoms per primitive cell. + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + read(io,*,iostat=ierr)temp,nbasis + call check_ierr(ierr) + call check_hash(temp) + if(verbose)then + if(nbasis/=1)then + write(6,*)'The primitive cell contains '//trim(i2s(nbasis))//' atoms.' + else + write(6,*)'The primitive cell contains 1 atom.' + endif + endif ! verbose + if(nbasis<0)then + write(6,*)'There should be at least zero atoms...' + stop + endif + +! Get number of primitive cells. + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + read(io,*,iostat=ierr)temp,npcells + call check_ierr(ierr) + call check_hash(temp) + if(verbose)then + if(npcells/=1)then + write(6,*)'There are '//trim(i2s(npcells))//' primitive cells.' + else + write(6,*)'There is 1 primitive cell.' + endif + endif ! verbose + if(npcells<1)then + write(6,*)'There should be at least one primitive cell.' + stop + endif + +! When forces are present, allocate force array. + if(forces)then + nitot_max_forces=nbasis*npcells + allocate(tag_forces(22,3,nitot_max_forces),stat=ialloc) + if(ialloc/=0)then + write(6,*)'Force array allocation problem.' + stop + endif ! ialloc/=0 + endif ! forces + +! Basis-type keyword. + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + read(io,*,iostat=ierr)temp,atom_basis_type + call check_ierr(ierr) + call check_hash(temp) + select case(trim(atom_basis_type)) + case('0') ; atom_basis_type='none' + case('1') ; atom_basis_type='plane-wave' + case('2') ; atom_basis_type='gaussian' + case('3') ; atom_basis_type='numerical' + case('4') ; atom_basis_type='blip' + case('5') ; atom_basis_type='non_int_he' + case default + continue + end select + if(verbose)write(6,*)'The value of the atom_basis_type parameter is ' & + &//trim(atom_basis_type)//'.' + +! Get periodicity. + read(io,*,iostat=ierr) + call check_ierr(ierr) + call check_hash(temp) + read(io,*,iostat=ierr)temp,isper_flag + call check_ierr(ierr) + call check_hash(temp) + if(isper_flag==1)then + isperiodic=.true. ; if(verbose)write(6,*)'The system is periodic.' + select case(trim(interaction)) + case('default','coulomb') ; interaction='ewald' + end select + elseif(isper_flag==0)then + isperiodic=.false. ; if(verbose)write(6,*)'The system is not periodic.' + select case(trim(interaction)) + case('default','ewald') ; interaction='coulomb' + case('mpc','mpc_ewald','ewald_mpc') + write(6,*)'Interaction type should be ''coulomb'' or ''none'' for finite & + &systems. Contradiction in header.' + stop + end select + else + write(6,*)'Periodicity flag must be 0 or 1.' + stop + endif ! periodicity. + +! Get number of data columns. Increase it by 1, since the line-numbers will +! also be read. + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + read(io,*,iostat=ierr)temp,no_cols_qmc + call check_ierr(ierr) + call check_hash(temp) + if(verbose)then + if(no_cols_qmc/=1)then + write(6,*)'There are '//trim(i2s(no_cols_qmc))//' columns of data in ' & + &//trim(filename)//'.' + else + write(6,*)'There is 1 column of data in '//trim(filename)//'.' + endif ! Singular/plural + endif ! verbose + if(no_cols_qmc<1)then + write(6,*)'No data to analyse. Stopping.' + stop + endif + no_cols_qmc=no_cols_qmc+1 +! Account for line breaking as the maximum number of items per line is 25 + nbreak=no_cols_qmc/25 + if(modulo(no_cols_qmc,25)>0)nbreak=nbreak+1 + Nlines=Nlines/nbreak + Nequil=Nequil/nbreak + +! Get items in .hist file + tag_step=1 ! Move number + tag_energy=-1 ! Total energy + tag_etotalt=-1 ! Alternative total energy + tag_esqr=-1 ! Square of total energy + tag_popavgsqr=-1 ! Square of population average over total energy + tag_K=-1 ! KEI kinetic-energy estimator + tag_T=-1 ! TI kinetic-energy estimator + tag_fisq=-1 ! FISQ kinetic-energy estimator + tag_Ewald=-1 ! 1/r or Ewald e-e interaction + tag_local=-1 ! Local electron-ion energy + tag_nonlocal=-1 ! Nonlocal electron-ion energy + tag_short=-1 ! Short-range part of MPC + tag_long=-1 ! Long-range part of MPC + tag_cppei=-1 ! Electron-ion CPP term + tag_cppe=-1 ! Electron CPP term + tag_cppee=-1 ! Electron-electron CPP term + tag_masspol=-1 ! Mass-polarization term + tag_future0=-1 ! Future-walking estimator + tag_future1=-1 ! " + tag_future2=-1 ! " + tag_future3=-1 ! " + tag_future4=-1 ! " + tag_future5=-1 ! " + tag_future6=-1 ! " + tag_future7=-1 ! " + tag_future8=-1 ! " + tag_future9=-1 ! " + tag_future10=-1 ! " + tag_massvel=-1 ! Mass-velocity term + tag_darwinen=-1 ! Darwin e-n term + tag_darwinee=-1 ! Darwin e-e term + tag_retard=-1 ! Retardation term. + tag_weight=-1 ! Total weight of configs + tag_nconf=-1 ! Number of configs + tag_eref=-1 ! Reference energy + tag_ebest=-1 ! Best estimate of energy + tag_acc=-1 ! Acceptance ratio + tag_teff=-1 ! Effective time step + tag_dipole1=-1 ! Electric dipole moment + tag_dipole2=-1 ! " " " + tag_dipole3=-1 ! " " " + tag_dipole_sq=-1 ! " " " + tag_contact_den=-1 ! Electron-positron contact density + if(forces)then + tag_forces(1:22,1:3,1:nitot_max_forces)=-1 + nitem_forces=0 ; naxis_forces=0 ; nitot_forces=0 + endif ! forces + + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + do i=2,no_cols_qmc + read(io,*,iostat=ierr)temp,datastring + call check_ierr(ierr) + call check_hash(temp) + datastring=adjustl(datastring) + if(trim(datastring)=='ETOT')then + call check_tag_free(tag_energy) + tag_energy=i + elseif(trim(datastring)=='ETOTALT')then + call check_tag_free(tag_etotalt) + tag_etotalt=i + elseif(trim(datastring)=='ESQR')then + call check_tag_free(tag_esqr) + tag_esqr=i + elseif(trim(datastring)=='POPAVGSQR')then + call check_tag_free(tag_popavgsqr) + tag_popavgsqr=i + elseif(trim(datastring)=='KEI')then + call check_tag_free(tag_K) + tag_K=i + elseif(trim(datastring)=='TI')then + call check_tag_free(tag_T) + tag_T=i + elseif(trim(datastring)=='FISQ')then + call check_tag_free(tag_fisq) + tag_fisq=i + elseif(trim(datastring)=='EWALD')then + call check_tag_free(tag_Ewald) + tag_Ewald=i + elseif(trim(datastring)=='LOCAL')then + call check_tag_free(tag_local) + tag_local=i + elseif(trim(datastring)=='NONLOCAL')then + call check_tag_free(tag_nonlocal) + tag_nonlocal=i + elseif(trim(datastring)=='SHORT')then + call check_tag_free(tag_short) + tag_short=i + elseif(trim(datastring)=='LONG')then + call check_tag_free(tag_long) + tag_long=i + elseif(trim(datastring)=='CPPEI')then + call check_tag_free(tag_cppei) + tag_cppei=i + elseif(trim(datastring)=='CPPE')then + call check_tag_free(tag_cppe) + tag_cppe=i + elseif(trim(datastring)=='CPPEE')then + call check_tag_free(tag_cppee) + tag_cppee=i + elseif(trim(datastring)=='MASSPOL')then + call check_tag_free(tag_masspol) + tag_masspol=i + elseif(trim(datastring(1:3))=='FOR')then + call generate_tag_forces(datastring,i) + elseif(trim(datastring)=='FUTURE0')then + call check_tag_free(tag_future0) + tag_future0=i + elseif(trim(datastring)=='FUTURE1')then + call check_tag_free(tag_future1) + tag_future1=i + elseif(trim(datastring)=='FUTURE2')then + call check_tag_free(tag_future2) + tag_future2=i + elseif(trim(datastring)=='FUTURE3')then + call check_tag_free(tag_future3) + tag_future3=i + elseif(trim(datastring)=='FUTURE4')then + call check_tag_free(tag_future4) + tag_future4=i + elseif(trim(datastring)=='FUTURE5')then + call check_tag_free(tag_future5) + tag_future5=i + elseif(trim(datastring)=='FUTURE6')then + call check_tag_free(tag_future6) + tag_future6=i + elseif(trim(datastring)=='FUTURE7')then + call check_tag_free(tag_future7) + tag_future7=i + elseif(trim(datastring)=='FUTURE8')then + call check_tag_free(tag_future8) + tag_future8=i + elseif(trim(datastring)=='FUTURE9')then + call check_tag_free(tag_future9) + tag_future9=i + elseif(trim(datastring)=='FUTURE10')then + call check_tag_free(tag_future10) + tag_future10=i + elseif(trim(datastring)=='MASSVEL')then + call check_tag_free(tag_massvel) + tag_massvel=i + elseif(trim(datastring)=='DARWINEN')then + call check_tag_free(tag_darwinen) + tag_darwinen=i + elseif(trim(datastring)=='DARWINEE')then + call check_tag_free(tag_darwinee) + tag_darwinee=i + elseif(trim(datastring)=='RETARD')then + call check_tag_free(tag_retard) + tag_retard=i + elseif(trim(datastring)=='WEIGHT')then + call check_tag_free(tag_weight) + tag_weight=i + elseif(trim(datastring)=='NCONF')then + call check_tag_free(tag_nconf) + tag_nconf=i + elseif(trim(datastring)=='EREF')then + call check_tag_free(tag_eref) + tag_eref=i + elseif(trim(datastring)=='EBEST')then + call check_tag_free(tag_ebest) + tag_ebest=i + elseif(trim(datastring)=='ACC')then + call check_tag_free(tag_acc) + tag_acc=i + elseif(trim(datastring)=='TEFF')then + call check_tag_free(tag_teff) + tag_teff=i + elseif(trim(datastring)=='DIPOLE1')then + call check_tag_free(tag_dipole1) + tag_dipole1=i + elseif(trim(datastring)=='DIPOLE2')then + call check_tag_free(tag_dipole2) + tag_dipole2=i + elseif(trim(datastring)=='DIPOLE3')then + call check_tag_free(tag_dipole3) + tag_dipole3=i + elseif(trim(datastring)=='DIPOLESQ')then + call check_tag_free(tag_dipole_sq) + tag_dipole_sq=i + elseif(trim(datastring)=='CONTACT_DEN')then + call check_tag_free(tag_contact_den) + tag_contact_den=i + else + write(6,*)'Column label not recognised.' + write(6,*)'Label is: '//trim(datastring) + stop + endif ! Label + enddo ! i + if(verbose)then + write(6,*)'Have read in column labels.' + write(6,*) + endif ! verbose + +! Warn about missing data, etc. + if(tag_energy<=0)then + write(6,*)'Warning: total energy data are not present!' + write(6,*) + endif + if(tag_K<=0)then + write(6,*)'Warning: kinetic energy (K) data are not present!' + write(6,*) + endif + if((tag_short>0.or.tag_long>0).and..not.coul_mpc)then + write(6,*)'Warning: MPC data are inexplicably present.' + write(6,*) + endif + if(tag_ewald>0.and..not.coul_ewald)then + write(6,*)'Warning: Ewald data are inexplicably present.' + write(6,*) + endif + if(tag_short>0.and.tag_long<=0)then + write(6,*)'Warning: only have short-ranged part of MPC interaction.' + write(6,*) + endif + if(tag_short<=0.and.tag_long>0)then + write(6,*)'Warning: only have long-ranged part of MPC interaction.' + write(6,*) + endif + +! Read final comment line in header. + read(io,*,iostat=ierr)temp + call check_ierr(ierr) + call check_hash(temp) + + END SUBROUTINE read_header + + + SUBROUTINE check_hash(char) +!---------------------------------------------------------------------------! +! This sub is used to check that the 1st char in each header line is a "#". ! +!---------------------------------------------------------------------------! + IMPLICIT NONE + CHARACTER(1),INTENT(in) :: char + if(char/='#')then + write(6,*)'Header line does not have a "#" in front. Stopping.' + stop + endif + END SUBROUTINE check_hash + + + SUBROUTINE check_ierr(ierr,nline) +!------------------------------------------------------! +! Complain if there has been a problem reading a file. ! +!------------------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: ierr + INTEGER,INTENT(in),OPTIONAL :: nline + if(ierr/=0)then + if(present(nline))then + write(6,*)'Problem reading '//trim(filename)//' at line '//trim(i2s(nline))//'.' + else + write(6,*)'Problem reading '//trim(filename)//'.' + endif + stop + endif + END SUBROUTINE check_ierr + + + SUBROUTINE check_tag_free(tag) +!----------------------------------------------! +! Complain if a tag has already been assigned. ! +!----------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: tag + if(tag/=-1)then + write(6,*)'Tag assigned twice. Two column labels must be the same.' + stop + endif + END SUBROUTINE check_tag_free + + + SUBROUTINE read_data(dmc) +!--------------------------------------------------! +! Read in the raw QMC data from the .hist file. ! +!--------------------------------------------------! + IMPLICIT NONE + LOGICAL,INTENT(in) :: dmc + INTEGER ierr,i,ialloc,nbreak,nleft,in,im + INTEGER,PARAMETER :: io=8 + CHARACTER(640) char640 + +! Open the data file. + open(unit=io,file=trim(filename),status='old',iostat=ierr) + if(ierr/=0)then + write(6,*)'Sorry, cannot open '//trim(filename)//'.' + stop + endif + +! Count the columns and rows of data, establish which data are present, etc. + call read_header(io,dmc) + +! Allocate the data array. + allocate(data_array(Nlines,no_cols_qmc),stat=ialloc) + if(ialloc/=0)then + write(6,*)'Allocation problem (1).' + stop + endif + +! Read in the data. Ignore comments. + i=0 + do + read(io,'(a)',iostat=ierr)char640 + call check_ierr(ierr,i+1) + if(index(char640,'#')==0)then + i=i+1 +! When reading from .hist file, account for maximum number of items +! (=25 per line). + nbreak=no_cols_qmc/25 + nleft=modulo(no_cols_qmc,25) + im=0 + if(nbreak>0)then + do in=1,nbreak + im=in + read(char640,*,iostat=ierr)data_array(i,(im-1)*25+1:im*25) + read(io,'(a)',iostat=ierr)char640 + enddo + endif + if(nleft>0)then + read(char640,*,iostat=ierr)data_array(i,im*25+1:no_cols_qmc) + endif + call check_ierr(ierr,i+1) + if(i>=Nlines)exit + endif ! Line not a comment. + enddo ! i + close(io) + + END SUBROUTINE read_data + + + SUBROUTINE check_data +!------------------------------------------------------------------------! +! This subroutine checks that the raw data in data_array are consistent. ! +! It checks that adding up the energy components gives the total energy, ! +! and that the ion-ion energy in the header is correct. It looks for ! +! Ewald and MPC data and decides which is to be used in the total energy.! +! The number of equilibration steps to be discarded are chosen and the ! +! energy units are selected. ! +!------------------------------------------------------------------------! + IMPLICIT NONE + INTEGER i,ierr,units_choice + DOUBLE PRECISION econst_check,econst_hist,escale,tot_weight + LOGICAL econst_is_const +! Tolerance for checking that total energy is sum of components. + DOUBLE PRECISION,PARAMETER :: tol=1.d-6 + +! Check move numbers + if(tag_step>0)then + do i=1,Nlines + if(nint(data_array(i,tag_step))/=i)then + write(6,*)'WARNING: iteration number behaves oddly at line ' & + &//trim(i2s(i))//' in '//trim(filename)//'.' + write(6,*) + exit + endif ! Problem with move number + enddo ! i + endif ! tag_step>0 + +! Check weights. + if(tag_weight>0)then + tot_weight=0.d0 + do i=1,Nlines + if(data_array(i,tag_weight)<0.d0)then + write(6,*)'Found a negative weight at line '//trim(i2s(i)) & + &//' of '//trim(filename)//'.' + stop + endif ! weight<0 + tot_weight=tot_weight+data_array(i,tag_weight) + enddo ! i + if(tot_weight<=0.d0)then + write(6,*)'Sum of weights is 0. Stopping.' + stop + endif ! total weight=0 + if(.not.use_weights)then + write(6,*)'Weights are present, but will not be used.' + write(6,*) + endif ! weights not to be used. + endif ! weights present. + +! Check that total energy minus KE, e-i pot E, and e-e pot E is a constant: +! the ion-ion energy. + if(tag_energy>0)then + econst_is_const=.true. + do i=1,Nlines + econst_check=data_array(i,tag_energy) + if(tag_K>0)econst_check=econst_check-data_array(i,tag_K) + if(trim(interaction)=='coulomb'.or.trim(interaction)=='ewald'.or.& + &trim(interaction)=='ewald_mpc'.or.trim(interaction)=='manual')then + if(tag_ewald>0)econst_check=econst_check-data_array(i,tag_ewald) + elseif(trim(interaction)=='mpc'.or.trim(interaction)=='mpc_ewald')then + if(tag_short>0)econst_check=econst_check-data_array(i,tag_short) + if(tag_long>0)econst_check=econst_check-data_array(i,tag_long) + endif ! MPC or Ewald present. + if(tag_local>0)econst_check=econst_check-data_array(i,tag_local) + if(tag_nonlocal>0)econst_check=econst_check-data_array(i,tag_nonlocal) + if(tag_cppei>0)econst_check=econst_check-data_array(i,tag_cppei) + if(tag_cppe>0)econst_check=econst_check-data_array(i,tag_cppe) + if(tag_cppee>0)econst_check=econst_check-data_array(i,tag_cppee) + if(i==1)then + econst_hist=econst_check + else + if(abs(econst_hist-econst_check)>tol)then + write(6,*)'Warning: some component of energy is not accounted for!' + write(6,*)'First evaluation of ion-ion energy: ',econst_hist + write(6,*)'Later evaluation of ion-ion energy: ',econst_check + write(6,*) + econst_is_const=.false. + exit + endif ! constanet_energy not constant. + endif ! i=1 + enddo ! i + if(abs(econst_hist)tol)then + write(6,*)'Warning: value of ion-ion energy obtained from raw data & + &differs from the value' + write(6,*)'in the header. Missing constant energy component?' + write(6,*) + endif ! Difference in constant_energy + endif ! Can compare constant_energy values + endif ! Components for check present? + +! Check that FISQ=2*TI-KEI. + if(tag_K>0.and.tag_T>0.and.tag_fisq>0)then + do i=1,Nlines + if(abs(data_array(i,tag_fisq)+data_array(i,tag_K) & + &-2.d0*data_array(i,tag_T))>tol)then + write(6,*)'Warning: problem with kinetic-energy estimators. & + &FISQ /= 2.TI-KEI.' + write(6,*)' KEI at line '//trim(i2s(i))//' : ',data_array(i,tag_K) + write(6,*)' TI at line '//trim(i2s(i))//' : ',data_array(i,tag_T) + write(6,*)'FISQ at line '//trim(i2s(i))//' : ',data_array(i,tag_fisq) + write(6,*) + exit + endif ! Problem with KE estimators. + enddo ! i + endif ! All KE estimators present. + +! Find out how many lines are to be skipped. + if(trim(qmc_method)=='DMC')then + do + write(6,*)'There are '//trim(i2s(Nlines))//' lines of data in total.' + write(6,*)'There are '//trim(i2s(Nequil))//' lines of equilibration data.' + write(6,*)'How many initial lines of data do you wish to discard?' + read(5,*,iostat=ierr)Nskip + if(ierr/=0)Nskip=-1 + if(Nskip<0.or.Nskip>Nlines-2)then + write(6,*)'Number of lines to skip must be between 0 and '// & + &trim(i2s(Nlines-2))//'.' + else + exit + endif ! Problem with Nskip + enddo ! Loop asking for Nskip + if(Nskip=1.and.units_choice<=2)then + exit + else + write(6,*)'Please try again. Choose a number between 1 and 2.' + write(6,*) + endif + enddo ! choice loop + if(units_choice==1)then + escale=1.d0 + e_units='au/particle' + else + escale=htoev + e_units='eV/particle' + endif ! units choice + elseif(isperiodic.and.nbasis>0)then +! Periodic system. + do + write(6,*)'Your data are for a periodic system with atoms.' + write(6,*)'Please select units for your energy data.' + write(6,*)'Choose one of: (1) au per prim cell; (2) eV per & + &prim cell;' + write(6,*)'(3) kcal per prim cell; (4) au per atom; (5) eV per atom; & + &(6) kcal per atom.' + read(5,*,iostat=ierr)units_choice + if(ierr/=0)units_choice=-1 + if(units_choice>=1.and.units_choice<=6)then + exit + else + write(6,*)'Please try again. Choose a number between 1 and 6.' + write(6,*) + endif + enddo ! choice loop + if(units_choice==1)then + escale=1.d0 + e_units='au/prim cell' + elseif(units_choice==2)then + escale=htoev + e_units='eV/prim cell' + elseif(units_choice==3)then + escale=htokcal + e_units='kcal/prim cell' + elseif(units_choice==4)then + escale=1.d0/dble(nbasis) + e_units='au/atom' + elseif(units_choice==5)then + escale=htoev/dble(nbasis) + e_units='eV/atom' + else + escale=htokcal/dble(nbasis) + e_units='kcal/atom' + endif + elseif(.not.isperiodic.and.nbasis>0)then +! Finite system. + do + write(6,*)'Your data are for a finite system with atoms.' + write(6,*)'Please select units for your energy data.' + write(6,*)'Choose one of: (1) au; (2) eV; (3) kcal; (4) au per atom; & + &(5) eV per atom;' + write(6,*)'(6) kcal per atom.' + read(5,*,iostat=ierr)units_choice + if(ierr/=0)units_choice=-1 + if(units_choice>=1.and.units_choice<=6)then + exit + else + write(6,*)'Please try again. Choose a number between 1 and 6.' + write(6,*) + endif + enddo ! choice loop + if(units_choice==1)then + escale=1.d0 + e_units='au' + elseif(units_choice==2)then + escale=htoev + e_units='eV' + elseif(units_choice==3)then + escale=htokcal + e_units='kcal' + elseif(units_choice==4)then + escale=1.d0/dble(nbasis) + e_units='au/atom' + elseif(units_choice==5)then + escale=htoev/dble(nbasis) + e_units='eV/atom' + else + escale=htokcal/dble(nbasis) + e_units='kcal/atom' + endif + else +! Default. + do + write(6,*)'Please select units for your energy data.' + write(6,*)'Choose one of: (1) au; (2) eV; (3) kcal.' + read(5,*,iostat=ierr)units_choice + if(ierr/=0)units_choice=-1 + if(units_choice>=1.and.units_choice<=3)then + exit + else + write(6,*)'Please try again. Choose a number between 1 and 3.' + write(6,*) + endif + enddo ! choice loop + if(units_choice==1)then + escale=1.d0 + e_units='au' + elseif(units_choice==2)then + escale=htoev + e_units='eV' + else + escale=htokcal + e_units='kcal' + endif + write(6,*)'For finite systems, energies are quoted for the whole system.' + write(6,*)'For real crystals, energies are quoted per primitive cell.' + write(6,*)'For electron(-hole) systems, energies are quoted per particle.' + endif + write(6,*) + +! Rescale energy data. (Easier just to rescale the raw data than to rescale +! each result quoted.) + if(escale/=1.d0)then + if(tag_energy>0)data_array(:,tag_energy)=data_array(:,tag_energy)*escale + if(tag_etotalt>0)data_array(:,tag_etotalt)=data_array(:,tag_etotalt)*escale + if(tag_esqr>0)data_array(:,tag_esqr)=data_array(:,tag_esqr)*escale*escale + if(tag_popavgsqr>0)data_array(:,tag_popavgsqr)=data_array(:,tag_popavgsqr) & + &*escale*escale + if(tag_K>0)data_array(:,tag_K)=data_array(:,tag_K)*escale + if(tag_T>0)data_array(:,tag_T)=data_array(:,tag_T)*escale + if(tag_fisq>0)data_array(:,tag_fisq)=data_array(:,tag_fisq)*escale + if(tag_Ewald>0)data_array(:,tag_Ewald)=data_array(:,tag_Ewald)*escale + if(tag_local>0)data_array(:,tag_local)=data_array(:,tag_local)*escale + if(tag_nonlocal>0)data_array(:,tag_nonlocal)=data_array(:,tag_nonlocal) & + &*escale + if(tag_short>0)data_array(:,tag_short)=data_array(:,tag_short)*escale + if(tag_long>0)data_array(:,tag_long)=data_array(:,tag_long)*escale + if(tag_cppei>0)data_array(:,tag_cppei)=data_array(:,tag_cppei)*escale + if(tag_cppe>0)data_array(:,tag_cppe)=data_array(:,tag_cppe)*escale + if(tag_cppee>0)data_array(:,tag_cppee)=data_array(:,tag_cppee)*escale + if(tag_masspol>0)data_array(:,tag_masspol)=data_array(:,tag_masspol)*escale + if(forces)then + do iion=1,nitot_forces + do iaxis=1,3 + do item=1,22 + if(tag_forces(item,iaxis,iion)/=-1)then + data_array(:,tag_forces(item,iaxis,iion))=& + &data_array(:,tag_forces(item,iaxis,iion))*escale + endif + enddo + enddo + enddo + endif ! if forces + if(tag_future0>0)data_array(:,tag_future0)=data_array(:,tag_future0)*escale + if(tag_future1>0)data_array(:,tag_future1)=data_array(:,tag_future1)*escale + if(tag_future2>0)data_array(:,tag_future2)=data_array(:,tag_future2)*escale + if(tag_future3>0)data_array(:,tag_future3)=data_array(:,tag_future3)*escale + if(tag_future4>0)data_array(:,tag_future4)=data_array(:,tag_future4)*escale + if(tag_future5>0)data_array(:,tag_future5)=data_array(:,tag_future5)*escale + if(tag_future6>0)data_array(:,tag_future6)=data_array(:,tag_future6)*escale + if(tag_future7>0)data_array(:,tag_future7)=data_array(:,tag_future7)*escale + if(tag_future8>0)data_array(:,tag_future8)=data_array(:,tag_future8)*escale + if(tag_future9>0)data_array(:,tag_future9)=data_array(:,tag_future9)*escale + if(tag_future10>0)data_array(:,tag_future10)=data_array(:,tag_future10)*& + &escale + if(tag_massvel>0)data_array(:,tag_massvel)=data_array(:,tag_massvel)*escale + if(tag_darwinen>0)data_array(:,tag_darwinen)=data_array(:,tag_darwinen) & + &*escale + if(tag_darwinee>0)data_array(:,tag_darwinee)=data_array(:,tag_darwinee) & + &*escale + if(tag_retard>0)data_array(:,tag_retard)=data_array(:,tag_retard)*escale + if(tag_eref>0)data_array(:,tag_eref)=data_array(:,tag_eref)*escale + if(tag_ebest>0)data_array(:,tag_ebest)=data_array(:,tag_ebest)*escale + constant_energy=constant_energy*escale + endif ! Data needs rescaling. + + END SUBROUTINE check_data + + + SUBROUTINE compute_stats +!--------------------------------------------------------------------------! +! In this subroutine, the various columns of data are subjected to various ! +! statistical analyses. ! +!--------------------------------------------------------------------------! + IMPLICIT NONE + INTEGER ierr,block_length,Nstudy,startline,nthird,nthirdstart, & + &ialloc,nthirdstop,i + DOUBLE PRECISION av,av_energy,std_err,std_err_energy,delta_std_err,var, & + &max_val,min_val,skew,kurt,corr_tau,corr_tau_err,sqrt_tau,err_sqrt_tau, & + &raw_var,raw_var_err,pop_var,pop_var_err + DOUBLE PRECISION,ALLOCATABLE :: temp_data(:) + + Nstudy=Nlines-Nskip + startline=Nskip+1 + +! Write out some information about the more important DMC simulation params. +! Do this first, so that important data appears at end of output. + if(tag_nconf>0)then + + write(6,*)'ANALYSIS OF CONFIGURATION POPULATION' + write(6,*)'====================================' + call compute_stats_unweighted(.false.,Nstudy,data_array(startline:Nlines, & + &tag_nconf),av,var,skew,kurt,max_val,min_val) + write(6,*)'Minimum population : ',min_val + write(6,*)' Mean population : ',av + write(6,*)'Maximum population : ',max_val + write(6,*)' Std error : ',sqrt(var/dble(Nstudy)) + if(av-min_val>0.25d0*av.or.max_val-av>0.25d0*av)write(6,*) & + &'Warning: Population fluctuated by more than 25% of mean.' + write(6,*) + + endif ! Config population data present. + + if(tag_acc>0)then + + write(6,*)'ANALYSIS OF ACCEPTANCE RATIO' + write(6,*)'============================' + call compute_stats_unweighted(.false.,Nstudy,data_array(startline:Nlines, & + &tag_acc),av,var,skew,kurt,max_val,min_val) + write(6,*)'Minimum acceptance ratio : ',min_val + write(6,*)' Mean acceptance ratio : ',av + write(6,*)'Maximum acceptance ratio : ',max_val + write(6,*)' Std error : ',sqrt(var/dble(Nstudy)) + write(6,*) + + endif ! Acceptance-ratio data present. + + if(tag_teff>0)then + + write(6,*)'ANALYSIS OF EFFECTIVE TIME STEP' + write(6,*)'===============================' + call compute_stats_unweighted(.false.,Nstudy,data_array(startline:Nlines, & + &tag_teff),av,var,skew,kurt,max_val,min_val) + write(6,*)'Minimum time step (au) : ',min_val + write(6,*)' Mean time step (au) : ',av + write(6,*)'Maximum time step (au) : ',max_val + write(6,*)' Std error (au) : ',sqrt(var/dble(Nstudy)) + write(6,*) + + endif ! Effective time step data present. + + if(tag_energy>0)then + +! Compute lots of information about the total energy data. + write(6,*)'ANALYSIS OF TOTAL-ENERGY DATA' + write(6,*)'=============================' + call compute_stats_unweighted(.true.,Nstudy,data_array(startline:Nlines, & + &tag_energy),av,var,skew,kurt,max_val,min_val) + write(6,*)'Minimum energy (',trim(e_units),') : ',min_val + write(6,*)' Mean energy (',trim(e_units),') : ',av + write(6,*)'Maximum energy (',trim(e_units),') : ',max_val + write(6,*)' Variance (',trim(e_units),') : ',var + write(6,*)' Std error (',trim(e_units),') : ',sqrt(var/dble(Nstudy)) + write(6,*)repeat(' ',len_trim(e_units))//' Skewness : ',skew + write(6,*)repeat(' ',len_trim(e_units))//'Normal sk. fluct. : ',& + &sqrt(6.d0/dble(Nstudy)) + write(6,*)repeat(' ',len_trim(e_units))//' Kurtosis : ',kurt + write(6,*)repeat(' ',len_trim(e_units))//'Normal ku. fluct. : ',& + &sqrt(24.d0/dble(Nstudy)) + write(6,*)'(NB, the var of the energy data is not an estimate & + &of the actual var.)' + write(6,*) +! Analyse total energy by thirds if there is enough data. + if(Nstudy>=6)then + write(6,*)'ANALYSIS OF TOTAL-ENERGY DATA BY THIRDS' + write(6,*)'=======================================' + write(6,*)'(Energy data in units of '//trim(e_units)//'.)' + nthird=Nstudy/3 + write(6,*)' Data range Av energy Std error Maximum & + &Minimum' + do i=1,3 + nthirdstart=startline+(i-1)*nthird + nthirdstop=nthirdstart+nthird-1 + call compute_stats_unweighted(.false.,nthird, & + &data_array(nthirdstart:nthirdstop,tag_energy),av,var,skew,kurt, & + &max_val,min_val) + write(6,'(" ",a16,4(" ",es12.5))')trim(i2s(nthirdstart)) & + &//'->'//trim(i2s(nthirdstop)),av,sqrt(var/dble(nthird)),max_val,min_val + enddo ! i + else + write(6,*)'Not enough data to analyse by thirds: need at least 6 points.' + endif ! Enough data? + write(6,*) + write(6,*)'CORRELATION-TIME ANALYSIS OF TOTAL-ENERGY DATA' + write(6,*)'==============================================' + call correlation_time(Nstudy,data_array(startline:Nlines,tag_energy), & + &corr_tau,corr_tau_err,av,var) + if(corr_tau/=-1.d0)then + write(6,*)' Correlation time (steps) : ',corr_tau + write(6,*)' Error in correlation time (steps) : ',corr_tau_err + write(6,*) + if(corr_tau>0.d0)then + sqrt_tau=sqrt(corr_tau) + err_sqrt_tau=corr_tau_err/(2*sqrt_tau) + write(6,*)' Error-bar factor : ',sqrt_tau + write(6,*)' Error in error-bar factor : ',err_sqrt_tau + write(6,*) + if(tag_weight>0.and.use_weights)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_energy), & + &data_array(startline:Nlines,tag_weight),1,av,std_err,delta_std_err) + else + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_energy), & + &1,av,std_err,delta_std_err) + endif + write(6,*)' Mean energy (',trim(e_units),') : ',av + write(6,*)' Correlation-corrected error (',trim(e_units),') : ',& + &std_err*sqrt(corr_tau) + write(6,*)' Error in error (',trim(e_units),') : ',& + &sqrt((std_err*err_sqrt_tau)**2+(sqrt_tau*delta_std_err)**2) + else + write(6,*)'The correlation time appears to be negative.' + endif + else + write(6,*)'The correlation time could not be computed.' + endif ! corr_tau calculated. + write(6,*) + + write(6,*)'REBLOCKING ANALYSIS OF TOTAL-ENERGY DATA' + write(6,*)'========================================' +! Print out reblocking analysis of energy + write(6,*)'(Energy data in units of '//trim(e_units)//'.)' + if(tag_weight>0.and.use_weights)then + call reblock_analysis(Nstudy,data_array(startline:Nlines,tag_energy), & + &data_array(startline:Nlines,tag_weight)) + else + call reblock_analysis(Nstudy,data_array(startline:Nlines,tag_energy)) + endif ! weights + + endif ! energy data available + + do + write(6,*)'Please choose a block length for reblocking all energy & + &components.' + read(5,*,iostat=ierr)block_length + if(ierr/=0)block_length=-1 + if(block_length>=1.and.block_length<=Nstudy/2)then + exit + else + write(6,*)'Please try again. Block length should be between 1 and ' & + &//trim(i2s(Nstudy/2))//'.' + endif + enddo ! get block length + write(6,*)'Chosen block length: '//trim(i2s(block_length))//'.' + write(6,*) + +! Write out the energy components with reblocked error bars. + + write(6,*)'ENERGY COMPONENTS WITH REBLOCKED ERROR BARS' + write(6,*)'===========================================' + +5 format(" ",a30,2(" ",es22.14)) +10 format(" ",a30," ",es22.14) +15 format(32x,a23,a) + write(6,15)' Mean ('//trim(e_units)//') ',' Err (' & + &//trim(e_units)//')' + + allocate(temp_data(startline:Nlines),stat=ialloc) + if(ialloc/=0)then + write(6,*)'Allocation problem.' + stop + endif + + if(tag_weight>0.and.use_weights)then + + if(tag_energy>0)then + + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_energy), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + av_energy=av ; std_err_energy=std_err + if(trim(interaction)=='mpc'.or.trim(interaction)=='mpc_ewald')then + write(6,5)'Total energy (using MPC) :',av,std_err + if(trim(interaction)=='mpc_ewald'.and.tag_ewald>0.and.tag_short>0.and.& + &tag_long>0)then + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_energy) & + &-data_array(startline:Nlines,tag_short)-data_array(startline:Nlines, & + &tag_long)+data_array(startline:Nlines,tag_ewald) + call reblock_weighted(Nstudy,temp_data(startline:Nlines), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Total energy (using Ewald) :',av,std_err + endif ! ewald present + else + if(isperiodic)then + write(6,5)'Total energy (using Ewald) :',av,std_err + else + write(6,5)'Total energy :',av,std_err + endif ! periodic + if(trim(interaction)=='ewald_mpc'.and.tag_ewald>0.and.tag_short>0.and.& + &tag_long>0)then + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_energy) & + &+data_array(startline:Nlines,tag_short)+data_array(startline:Nlines, & + &tag_long)-data_array(startline:Nlines,tag_ewald) + call reblock_weighted(Nstudy,temp_data(startline:Nlines), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Total energy (using MPC) :',av,std_err + endif ! MPC present + endif ! use_mpc_energy + + if(tag_esqr>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_esqr), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Total energy squared:',av,std_err + raw_var=av-av_energy*av_energy + raw_var_err=sqrt(std_err**2+(av_energy*std_err_energy)**2) + write(6,5)'Variance of total energy:',raw_var,raw_var_err + endif + + if(tag_popavgsqr>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_popavgsqr), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Population avg of total energy squared:',av,std_err + pop_var=av-av_energy*av_energy + pop_var_err=sqrt(std_err**2+(av_energy*std_err_energy)**2) + write(6,5)'Variance of population avg of energy:',pop_var,pop_var_err + endif + + if(tag_esqr>0.and.tag_popavgsqr>0)then + write(6,5)'Effective population size:',raw_var/pop_var,& + &sqrt((raw_var_err/pop_var)**2+(pop_var_err*raw_var/pop_var**2)**2) + endif + + if(tag_masspol>0.and.tag_massvel>0.and.tag_darwinen>0.and.tag_darwinee>0 & + &.and.tag_retard>0)then +! At present, only have relativistic data for atoms. + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_energy) & + &+data_array(startline:Nlines,tag_masspol) & + &+data_array(startline:Nlines,tag_massvel) & + &+data_array(startline:Nlines,tag_darwinen) & + &+data_array(startline:Nlines,tag_darwinee) & + &+data_array(startline:Nlines,tag_retard) + call reblock_weighted(Nstudy,temp_data(startline:Nlines), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Total energy (inc rel) :',av,std_err + endif ! rel_present + + if(tag_K>0)then + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_energy) & + &-data_array(startline:Nlines,tag_K) + call reblock_weighted(Nstudy,temp_data(startline:Nlines), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + if(trim(interaction)=='mpc'.or.trim(interaction)=='mpc_ewald')then + write(6,5)'Total pot energy (using MPC) :',av,std_err + else + if(isperiodic)then + write(6,5)'Tot pot energy (using Ewald) :',av,std_err + else + write(6,5)'Total potential energy :',av,std_err + endif ! periodic + endif ! use_mpc_energy + endif ! K present + + endif ! energy present. + + if(tag_K>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_K), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Kinetic energy (K) :',av,std_err + endif ! K present + if(tag_T>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_T), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Kinetic energy (T) :',av,std_err + endif ! T present + if(tag_fisq>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_fisq), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Kinetic energy (FISQ) :',av,std_err + elseif(tag_K>0.and.tag_T>0)then + temp_data(startline:Nlines)=2.d0*data_array(startline:Nlines,tag_T) & + &-data_array(startline:Nlines,tag_K) + call reblock_weighted(Nstudy,temp_data(startline:Nlines), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Kinetic energy (FISQ) :',av,std_err + endif ! FISQ present. + if(tag_ewald>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_ewald), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + if(isperiodic)then + write(6,5)'Ewald interaction :',av,std_err + else + write(6,5)'Coulomb interaction :',av,std_err + endif ! periodic + endif ! Ewald present. + if(tag_local>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_local), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Local e-i energy :',av,std_err + endif ! local present + if(tag_nonlocal>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines, & + &tag_nonlocal),data_array(startline:Nlines,tag_weight),block_length, & + &av,std_err,delta_std_err) + write(6,5)'Nonlocal e-i energy :',av,std_err + endif ! nonlocal e-i pot present + + else + + if(tag_energy>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_energy), & + &block_length,av,std_err,delta_std_err) + av_energy=av ; std_err_energy=std_err + if(trim(interaction)=='mpc'.or.trim(interaction)=='mpc_ewald')then + write(6,5)'Total energy (using MPC) :',av,std_err + if(trim(interaction)=='mpc_ewald'.and.tag_ewald>0.and.tag_long>0.and.& + &tag_short>0)then + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_energy) & + &-data_array(startline:Nlines,tag_short)-data_array(startline:Nlines, & + &tag_long)+data_array(startline:Nlines,tag_ewald) + call reblock_unweighted(Nstudy,temp_data(startline:Nlines), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Total energy (using Ewald) :',av,std_err + endif ! Ewald present. + else + if(isperiodic)then + write(6,5)'Total energy (using Ewald) :',av,std_err + else + write(6,5)'Total energy :',av,std_err + endif ! periodic + if(trim(interaction)=='ewald_mpc'.and.tag_ewald>0.and.tag_long>0.and.& + &tag_short>0)then + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_energy) & + &+data_array(startline:Nlines,tag_short)+data_array(startline:Nlines, & + &tag_long)-data_array(startline:Nlines,tag_ewald) + call reblock_unweighted(Nstudy,temp_data(startline:Nlines), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Total energy (using MPC) :',av,std_err + endif ! MPC present. + endif ! use_mpc_energy + if(tag_esqr>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_esqr), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Total energy squared:',av,std_err + write(6,10)'Raw variance of total energy:',& + &(av-av_energy*av_energy)*dble(nparts_per_simcell) + endif + if(tag_masspol>0.and.tag_massvel>0.and.tag_darwinen>0.and.tag_darwinee>0 & + &.and.tag_retard>0)then +! At present, only have relativistic data for atoms. + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_energy) & + &+data_array(startline:Nlines,tag_masspol) & + &+data_array(startline:Nlines,tag_massvel) & + &+data_array(startline:Nlines,tag_darwinen) & + &+data_array(startline:Nlines,tag_darwinee) & + &+data_array(startline:Nlines,tag_retard) + call reblock_unweighted(Nstudy,temp_data(startline:Nlines),block_length, & + &av,std_err,delta_std_err) + write(6,5)'Total energy (inc rel) :',av,std_err + endif ! rel_present + if(tag_K>0)then + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_energy) & + &-data_array(startline:Nlines,tag_K) + call reblock_unweighted(Nstudy,temp_data(startline:Nlines),block_length, & + &av,std_err,delta_std_err) + if(trim(interaction)=='mpc'.or.trim(interaction)=='mpc_ewald')then + write(6,5)'Total pot energy (using MPC) :',av,std_err + else + if(isperiodic)then + write(6,5)'Tot pot energy (using Ewald) :',av,std_err + else + write(6,5)'Total potential energy :',av,std_err + endif ! periodic + endif ! use_mpc_energy + endif ! K present + endif ! Energy data present. + if(tag_K>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_K), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Kinetic energy (K) :',av,std_err + endif ! K present. + if(tag_T>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_T), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Kinetic energy (T) :',av,std_err + endif ! T present + if(tag_fisq>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_fisq), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Kinetic energy (FISQ) :',av,std_err + elseif(tag_K>0.and.tag_T>0)then + temp_data(startline:Nlines)=2.d0*data_array(startline:Nlines,tag_T) & + &-data_array(startline:Nlines,tag_K) + call reblock_unweighted(Nstudy,temp_data(startline:Nlines),block_length, & + &av,std_err,delta_std_err) + write(6,5)'Kinetic energy (FISQ) :',av,std_err + endif ! K & T present. + if(tag_ewald>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_ewald), & + &block_length,av,std_err,delta_std_err) + if(isperiodic)then + write(6,5)'Ewald interaction :',av,std_err + else + write(6,5)'Coulomb interaction :',av,std_err + endif ! periodic + endif ! Ewald present. + if(tag_local>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_local), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Local e-i energy :',av,std_err + endif ! local present + if(tag_nonlocal>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines, & + &tag_nonlocal),block_length,av,std_err,delta_std_err) + write(6,5)'Nonlocal e-i energy :',av,std_err + endif ! nonlocal e-i pot present + + endif ! weighted + + if(tag_weight>0.and.use_weights)then + if(tag_short>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_short), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Short-range MPC energy :',av,std_err + endif ! short present + if(tag_long>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_long), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Long-range MPC energy :',av,std_err + endif ! long present. + if(tag_short>0.and.tag_long>0)then + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_short)+ & + &data_array(startline:Nlines,tag_long) + call reblock_weighted(Nstudy,temp_data(startline:Nlines), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Total MPC energy :',av,std_err + endif ! MPC data present + if(tag_cppei>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_cppei), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'CPP energy (e-i) :',av,std_err + endif ! CPPEI present + if(tag_cppe>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_cppe), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'CPP energy (e) :',av,std_err + endif ! CPPE present + if(tag_cppee>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_cppee), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'CPP energy (e-e) :',av,std_err + endif ! CPP data present + if(tag_masspol>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_masspol), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Mass-polarization energy :',av,std_err + endif ! masspol present + if(tag_massvel>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_massvel), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Mass-velocity energy :',av,std_err + endif ! massvel present. + if(tag_darwinen>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_darwinen), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Electron-nucleus Darwin :',av,std_err + endif ! darawin e-n present. + if(tag_darwinee>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_darwinee), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Electron-electron Darwin :',av,std_err + endif ! darwin e-e present. + if(tag_retard>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_retard), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Retardation term :',av,std_err + endif ! Duh. + if(tag_masspol>0.and.tag_massvel>0.and.tag_darwinen>0.and.tag_darwinee>0 & + &.and.tag_retard>0)then + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_masspol) & + &+data_array(startline:Nlines,tag_massvel) & + &+data_array(startline:Nlines,tag_darwinen) & + &+data_array(startline:Nlines,tag_darwinee) & + &+data_array(startline:Nlines,tag_retard) + call reblock_weighted(Nstudy,temp_data(startline:Nlines), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Total rel correction :',av,std_err + endif ! Relativistic data present + + else + + if(tag_short>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_short), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Short-range MPC energy :',av,std_err + endif ! short present. + if(tag_long>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_long), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Long-range MPC energy :',av,std_err + endif ! long present. + if(tag_short>0.and.tag_long>0)then + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_short) & + &+data_array(startline:Nlines,tag_long) + call reblock_unweighted(Nstudy,temp_data(startline:Nlines),block_length, & + &av,std_err,delta_std_err) + write(6,5)'Total MPC energy :',av,std_err + endif ! MPC data present + if(tag_cppei>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_cppei), & + &block_length,av,std_err,delta_std_err) + write(6,5)'CPP energy (e-i) :',av,std_err + endif ! CPPEI present + if(tag_cppe>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_cppe), & + &block_length,av,std_err,delta_std_err) + write(6,5)'CPP energy (e) :',av,std_err + endif ! CPPE present. + if(tag_cppee>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_cppee), & + &block_length,av,std_err,delta_std_err) + write(6,5)'CPP energy (e-e) :',av,std_err + endif ! CPPEE data present + if(tag_masspol>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_masspol), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Mass-polarization energy :',av,std_err + endif ! masspol present. + if(tag_massvel>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_massvel), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Mass-velocity energy :',av,std_err + endif ! massvel present. + if(tag_darwinen>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_darwinen), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Electron-nucleus Darwin :',av,std_err + endif ! darwinen present. + if(tag_darwinee>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_darwinee), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Electron-electron Darwin :',av,std_err + endif ! darwinee present. + if(tag_retard>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_retard), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Retardation term :',av,std_err + endif ! Duh. + if(tag_masspol>0.and.tag_massvel>0.and.tag_darwinen>0.and.tag_darwinee>0 & + &.and.tag_retard>0)then + temp_data(startline:Nlines)=data_array(startline:Nlines,tag_masspol) & + &+data_array(startline:Nlines,tag_massvel) & + &+data_array(startline:Nlines,tag_darwinen) & + &+data_array(startline:Nlines,tag_darwinee) & + &+data_array(startline:Nlines,tag_retard) + call reblock_unweighted(Nstudy,temp_data(startline:Nlines), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Total rel correction :',av,std_err + endif ! Relativistic data present + + endif ! weighted. + + deallocate(temp_data) + + if(constant_energy/=0.d0)write(6,10)'Constant energy :',constant_energy + write(6,*) + +! Calculate and write out forces + if(forces)call construct_write_forces(startline,Nstudy,block_length) + +! Write out future-walking estimates + if(tag_future1>0)then + write(6,*)'FUTURE-WALKING ESTIMATES WITH REBLOCKED ERROR BAR' + write(6,*)'=================================================' + write(6,*)'Future-walking estimates of the observable pureitems(1) & + &from the dmc_main' + write(6,*)'routine. Temporarily, pureitems(1) is the Hellmann-Feynman & + &forces in the' + write(6,*)'x-direction of the 1st atom as ordered in the gwfn.data & + &file. To estimate' + write(6,*)'a different observable, alter the assignment after line:' + write(6,*)"'Change next line when future-walking estimates are required'" + write(6,*)' Mean (au) Err (au)' + + if(tag_weight>0.and.use_weights)then + if(tag_future0>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future0), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (1st) :',av,std_err + endif + if(tag_future1>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future1), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (2nd) :',av,std_err + endif + if(tag_future2>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future2), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (3rd) :',av,std_err + endif + if(tag_future3>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future3), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (4th) :',av,std_err + endif + if(tag_future4>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future4), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (5th) :',av,std_err + endif + if(tag_future5>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future5), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (6th) :',av,std_err + endif + if(tag_future6>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future6), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (7th) :',av,std_err + endif + if(tag_future7>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future7), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (8th) :',av,std_err + endif + if(tag_future8>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future8), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (9th) :',av,std_err + endif + if(tag_future9>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future9), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (10th) :',av,std_err + endif + if(tag_future10>0) then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_future10), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'FW Estimator (11th) :',av,std_err + endif + write(6,*) + write(6,*)'The 1st estimator corresponds to future-walking projection & + &time T=0 1/Ha,' + write(6,*)'the 2nd to T=0.5 1/Ha, the 3rd to T=1 1/Ha..., and the & + &11th to T=10 1/Ha.' + write(6,*) + + endif ! tag_weight + + endif ! future + + if(tag_dipole1>0.or.tag_dipole2>0.or.tag_dipole3>0.or.tag_dipole_sq>0)then + write(6,*)'ELECTRIC DIPOLE MOMENT WITH REBLOCKED ERROR BARS' + write(6,*)'================================================' + write(6,15)' Mean (au) ',' Err (au)' + + if(tag_weight>0.and.use_weights)then + if(tag_dipole1>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_dipole1), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Dipole moment (x cpt) :',av,std_err + endif ! tag_dipole1 + if(tag_dipole2>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_dipole2), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Dipole moment (y cpt) :',av,std_err + endif ! tag_dipole2 + if(tag_dipole3>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_dipole3), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Dipole moment (z cpt) :',av,std_err + endif ! tag_dipole3 + if(tag_dipole_sq>0)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_dipole_sq), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Dipole moment squared :',av,std_err + endif ! tag_dipole_sq + else + if(tag_dipole1>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_dipole1), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Dipole moment (x cpt) :',av,std_err + endif ! tag_dipole1 + if(tag_dipole2>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_dipole2), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Dipole moment (y cpt) :',av,std_err + endif ! tag_dipole2 + if(tag_dipole3>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines,tag_dipole3), & + &block_length,av,std_err,delta_std_err) + write(6,5)'Dipole moment (z cpt) :',av,std_err + endif ! tag_dipole3 + if(tag_dipole_sq>0)then + call reblock_unweighted(Nstudy,data_array(startline:Nlines, & + &tag_dipole_sq),block_length,av,std_err,delta_std_err) + write(6,5)'Dipole moment squared :',av,std_err + endif ! tag_dipole_sq + endif ! weighted. + write(6,*) + endif ! Dipole moment + + if(tag_contact_den>0)then + write(6,*)'CONTACT DENSITY' + write(6,*)'===============' + write(6,15)' Mean (au) ',' Err (au)' + if(tag_weight>0.and.use_weights)then + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_contact_den), & + &data_array(startline:Nlines,tag_weight),block_length,av,std_err, & + &delta_std_err) + write(6,5)'Elec-pos contact density :',av,std_err + else + call reblock_unweighted(Nstudy,data_array(startline:Nlines, & + &tag_contact_den),block_length,av,std_err,delta_std_err) + write(6,5)'Elec-pos contact density :',av,std_err + endif ! weighted. + write(6,*) + endif ! Contact density + + END SUBROUTINE compute_stats + + + SUBROUTINE reblock_analysis(no_pts,data_array,weight_array) +!--------------------------------------------------------------! +! Compute the weighted average of the data, and calculate the ! +! error bar as a function of reblocking transformation number. ! +!--------------------------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: no_pts + DOUBLE PRECISION,INTENT(in) :: data_array(no_pts) + DOUBLE PRECISION,INTENT(in),OPTIONAL :: weight_array(no_pts) + INTEGER no_rtns,rtn,block_length,ierr + DOUBLE PRECISION av,std_err,delta_std_err + + open(unit=10,file='reblock.plot',status='replace',iostat=ierr) + if(ierr/=0)then + write(6,*)'Problem opening reblock.plot.' + stop + endif + +! Number of reblocking transformations + no_rtns=floor(log(dble(no_pts))/log(2.d0)) + +! Initial block length + block_length=1 + +! Write out results of reblocking analysis + write(6,*)' RTN Blk leng Std error in mean Error in std error' + do rtn=0,no_rtns-1 + if(present(weight_array))then + call reblock_weighted(no_pts,data_array,weight_array,block_length, & + &av,std_err,delta_std_err) + else + call reblock_unweighted(no_pts,data_array,block_length,av,std_err, & + &delta_std_err) + endif ! weights present + write(6,'(" ",i4," ",i10," ",es23.15," ",es23.15)')rtn,block_length, & + &std_err,delta_std_err + write(10,*)rtn,std_err,delta_std_err + block_length=2*block_length + enddo ! rtn + write(6,*) + + write(6,*)'Reblocked error bar against reblocking transformation number & + &(RTN) has been' + write(6,*)'written to reblock.plot. Please use "plot_reblock" to view & + &these data.' + write(6,*) + close(10) + + END SUBROUTINE reblock_analysis + + + SUBROUTINE reblock_forces_analysis(no_pts,data_array,plotname,weight_array) +!--------------------------------------------------------------! +! Compute the weighted average of the data, and calculate the ! +! error bar as a function of reblocking transformation number. ! +! This routine is an extension of routine reblock_analysis ! +! to allow specifying the name of the file to be written out. ! +! ! +! AB 11.2007 ! +!--------------------------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: no_pts + DOUBLE PRECISION,INTENT(in) :: data_array(no_pts) + DOUBLE PRECISION,INTENT(in),OPTIONAL :: weight_array(no_pts) + CHARACTER(20),INTENT(in) :: plotname + INTEGER no_rtns,rtn,block_length,ierr + DOUBLE PRECISION av,std_err,delta_std_err + + open(unit=10,file=plotname ,status='replace',iostat=ierr) + if(ierr/=0)then + write(6,*)'Problem opening plotname.' + stop + endif + +! Number of reblocking transformations + no_rtns=floor(log(dble(no_pts))/log(2.d0)) + +! Initial block length + block_length=1 + +! Write out results of reblocking analysis + write(6,*)' RTN Blk leng Std error in mean Error in std error' + do rtn=0,no_rtns-1 + if(present(weight_array))then + call reblock_weighted(no_pts,data_array,weight_array,block_length, & + &av,std_err,delta_std_err) + else + call reblock_unweighted(no_pts,data_array,block_length,av,std_err, & + &delta_std_err) + endif ! weights present + write(6,'(" ",i4," ",i10," ",es23.15," ",es23.15)')rtn,block_length, & + &std_err,delta_std_err + write(10,*)rtn,std_err,delta_std_err + block_length=2*block_length + enddo ! rtn + write(6,*) + + close(10) + + END SUBROUTINE reblock_forces_analysis + + + CHARACTER(12) FUNCTION i2s(n) +!-----------------------------------------------------------------------! +! I2S ! +! === ! +! Convert integers to left justified strings that can be printed in the ! +! middle of a sentence without introducing large amounts of white space.! +! ! +! Calling routine is intended to include something like: ! +! USE utilities ! +! INTEGER i ! +! i=12 ! +! write(6,*)'Integer number ',trim(i2s(i)),' with words at the end.' ! +!-----------------------------------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: n + INTEGER i,j + INTEGER,PARAMETER :: ichar0=ichar('0') + i2s='' + i=abs(n) + do j=len(i2s),1,-1 + i2s(j:j)=achar(ichar0+mod(i,10)) + i=i/10 ; if(i==0)exit + enddo ! j + if(n<0)then + i2s='-'//adjustl(i2s) + else + i2s=adjustl(i2s) + endif ! n<0 + END FUNCTION i2s + + + SUBROUTINE generate_tag_forces(datastring,i) +!------------------------------------------------------------------! +! This subroutine generates tags for forces from tags read in from ! +! the .hist file. It also determines the number of atoms and axes ! +! for which forces data are available. ! +! ! +! AB 11.2007 ! +!------------------------------------------------------------------! + IMPLICIT NONE + CHARACTER(72),INTENT(in) :: datastring + INTEGER,INTENT(in) :: i + CHARACTER(1) :: axis(3)=(/'X','Y','Z'/) + CHARACTER(1) :: atem(22)=(/'A','B','C','D','E','F','G','H','I','J','K',& + &'L','M','N','O','P','Q','R','S','T','U','V'/) + CHARACTER(1) iaxis_char,item_char + INTEGER iaxis,item,iion,ion_tmp + + read(datastring(6:),*)ion_tmp + do iion=1,nitot_max_forces + if(ion_tmp==iion)then +! Generate the number of atoms for which forces are calculated. + if(iion>nitot_forces)nitot_forces=iion + do iaxis=1,3 + iaxis_char=axis(iaxis) + if(datastring(5:5)==iaxis_char)then +! Generate the number of axis for which forces are calculated. + if(iaxis>naxis_forces)naxis_forces=iaxis + do item=1,22 + item_char=atem(item) + if(datastring(4:4)==item_char)then +! Generate the number of items. + if(item>nitem_forces)nitem_forces=item + call check_tag_free(tag_forces(item,iaxis,iion)) +! Generate label for forces + tag_forces(item,iaxis,iion)=i + endif ! item_char + enddo ! item + endif ! datastring=iaxis_char + enddo ! iaxis + endif ! iion + enddo ! iion + + END SUBROUTINE generate_tag_forces + + + SUBROUTINE construct_write_forces(startline,Nstudy,block_length) +!----------------------------------------------------------------! +! This routine calculates VMC/DMC forces from available data and ! +! performs a reblocking analysis. ! +! ! +! AB 11.2007 ! +!----------------------------------------------------------------! + IMPLICIT NONE + INTEGER,INTENT(in) :: startline,Nstudy,block_length + CHARACTER(20) plotname + INTEGER i,n,ialloc,nthird,nthirdstart,nthirdstop,ierr + DOUBLE PRECISION etot,std_err,delta_std_err,etot_dmc,etot_dmc_SE + DOUBLE PRECISION av,var,skew,kurt,max_val,min_val + LOGICAL forces_reblock,ltemp + +! Do we want to reblock forces? + forces_reblock=.false. + do + write(6,*)'Forces data are detected. When you like to reblock the forces da& + &ta with the' + write(6,*)'same block length as the total energy, choose F. When you like t& + &o investigate' + write(6,*)'reblocked forces error bars, choose T and use gnuplot to look at& + & error bars.' + write(6,*)'Choose F or T:' + read(5,*,iostat=ierr)forces_reblock + if(ierr/=0)forces_reblock=.false. + if((forces_reblock).or.(.not.forces_reblock))then + exit + else + write(6,*)'Please try again. Choose T or F.' + endif + enddo ! choice loop + + + write(6,*)'FORCES COMPONENTS WITH REBLOCKED ERROR BARS' + write(6,*)'===========================================' + +!------------------ reblock VMC forces ------------------------- + + if(trim(qmc_method)=='VMC')then + + allocate(forces_array(Nlines,11),stat=ialloc) + if(ialloc/=0)then + write(6,*)'Allocation problem (1).' + stop + endif + +! Need energy estimate + call reblock_unweighted(Nstudy,data_array(startline:Nlines,& + &tag_energy),1,etot,std_err,delta_std_err) + + inquire(file='DMC_energy',exist=ltemp) + if(ltemp)then + open(11,file='DMC_energy') + read(11,*)etot_dmc,etot_dmc_SE + close(11) + else + etot_dmc=0.d0 + endif + + do iion=1,nitot_forces + do iaxis=1,naxis_forces + write(6,*)'Forces on atom ',trim(i2s(iion)),' along axis ',& + &trim(i2s(iaxis)),' Mean (au) Err (au)' + +! Construct various VMC estimators for the forces + do n=1,Nlines +! 1. Total forces (d-loc) + forces_array(n,1)=data_array(n,tag_forces(9,iaxis,iion))& + &-2.d0*data_array(n,tag_forces(2,iaxis,iion))& + &+2.d0*etot*data_array(n,tag_forces(1,iaxis,iion)) +! HFT forces (d-loc) + forces_array(n,2)=data_array(n,tag_forces(9,iaxis,iion)) + if(data_array(n,tag_forces(10,iaxis,iion))/=0.d0)then +! HFT forces (p-loc) + forces_array(n,3)=data_array(n,tag_forces(10,iaxis,iion)) +! HFT forces (s-loc) + forces_array(n,4)=data_array(n,tag_forces(11,iaxis,iion)) + endif +! Wavefunction Pulay term + forces_array(n,5)=& + &-2.d0*data_array(n,tag_forces(2,iaxis,iion))& + &+2.d0*etot*data_array(n,tag_forces(1,iaxis,iion)) +! Pseudopotential Pulay term + forces_array(n,6)=-data_array(n,tag_forces(7,iaxis,iion))& + &+data_array(n,tag_forces(4,iaxis,iion)) +! 2. Total forces zero-variance corrected (class 1,d-loc) + forces_array(n,7)=data_array(n,tag_forces(9,iaxis,iion))& ! HFT + &-2.d0*data_array(n,tag_forces(2,iaxis,iion))& ! Pulay + &+2.d0*etot*data_array(n,tag_forces(1,iaxis,iion))& ! " + &-data_array(n,tag_forces(6,iaxis,iion))& ! -H Psi' + &-data_array(n,tag_forces(7,iaxis,iion))& ! " + &+data_array(n,tag_forces(3,iaxis,iion))& ! " + &+data_array(n,tag_forces(4,iaxis,iion)) ! " +! Zero-variance term + forces_array(n,8)=& + &-data_array(n,tag_forces(6,iaxis,iion))& !- H Psi' + &-data_array(n,tag_forces(7,iaxis,iion))& ! " + &+data_array(n,tag_forces(3,iaxis,iion))& ! " + &+data_array(n,tag_forces(4,iaxis,iion)) ! " + ! E_l Psi' term cancelled +! VMC nodal term, added to Total Forces (purHFT,purNT,d-loc) + if(etot_dmc/=0.d0)then + forces_array(n,9)=& ! + &-data_array(n,tag_forces(6,iaxis,iion))& ! -H Psi' + &-data_array(n,tag_forces(7,iaxis,iion))& ! " + &-data_array(n,tag_forces(2,iaxis,iion))& ! " + &+data_array(n,tag_forces(3,iaxis,iion))& ! " + &+data_array(n,tag_forces(4,iaxis,iion))& ! " + &+etot_dmc*data_array(n,tag_forces(1,iaxis,iion)) ! E*Psi' + else + forces_array(n,9)=0.d0 + endif + enddo ! Nlines + +! Write out the various estimators for the forces +! 1. Total forces + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,1),& + &block_length,av,std_err,delta_std_err) + write(6,9) 'Total Force(dloc) :',av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,2),& + &block_length,av,std_err,delta_std_err) + write(6,9) 'HFT Force(dloc) :',av,std_err + if(data_array(n,tag_forces(10,iaxis,iion))/=0.d0)then + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,3),& + &block_length,av,std_err,delta_std_err) + write(6,9) 'HFT Force(ploc) :',av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,4),& + &block_length,av,std_err,delta_std_err) + write(6,9) 'HFT Force(sloc) :',av,std_err + endif + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,5),& + &block_length,av,std_err,delta_std_err) + write(6,9) 'Wavefunction Pulay term :',av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,6),& + &block_length,av,std_err,delta_std_err) + write(6,9) 'Pseudopotential Pulay term :',av,std_err + +! 2. Total forces zero-variance corrected + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,7),& + &block_length,av,std_err,delta_std_err) + write(6,9) 'Total Force+ZV(dloc) :',av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,8),& + &block_length,av,std_err,delta_std_err) + write(6,9) 'Zero-variance term :',av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,9),& + &block_length,av,std_err,delta_std_err) + write(6,9) 'VMC NT(add to last DMC est) :',av,std_err + + if(forces_reblock)then + plotname='forces'//'.tot.'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:& + &Nlines,1),plotname) + plotname='forces'//'.HFT.'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:& + &Nlines,2),plotname) + plotname='forces'//'.totZV.'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:& + &Nlines,7),plotname) + plotname='forces'//'.vmcNT.'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:& + &Nlines,9),plotname) +! Analyse total forces by thirds if there is enough data. + if(Nstudy>=6)then + write(6,*) + write(6,*)'ANALYSIS OF TOTAL FORCES DATA BY THIRDS' + nthird=Nstudy/3 + write(6,*)' Data range Av forces Variance Maximum & + &Minimum' + do i=1,3 + nthirdstart=startline+(i-1)*nthird + nthirdstop=nthirdstart+nthird-1 + call compute_stats_unweighted(.false.,nthird, & + &forces_array(nthirdstart:nthirdstop,1),av,var,skew,kurt, & + &max_val,min_val) + write(6,'(" ",a16,4(" ",es12.5))')trim(i2s(nthirdstart)) & + &//'->'//trim(i2s(nthirdstop)),av,var,max_val,min_val + enddo ! i + else + write(6,*)'Not enough data to analyse by thirds: need at least 6 points.' + endif ! Enough data? + endif ! reblock + write(6,*) + + enddo ! iaxis + enddo ! iion + write(6,*) "The last estimator 'VMC NT' is zero (not used), unless a 'DMC_en& + &ergy' file is " + write(6,*) "provided in the working directory during the reblocking process & + &which contains" + write(6,*) "the DMC energy followed by its error bar. After this estimator V& + &MC NT is " + write(6,*) "calculated by the reblocking routine, please add it by hand to t& + &he 'Total" + write(6,*) "Force(purHFT/NT,dloc)' estimator to obtain another force estimat& + &or." + write(6,*) + endif ! VMC + +!------------------- reblock DMC forces --------------------- + + if(trim(qmc_method)=='DMC')then + allocate(forces_array(Nlines,10),stat=ialloc) + if(ialloc/=0)then + write(6,*)'Allocation problem (1).' + stop + endif + +! Need energy estimate + call reblock_weighted(Nstudy,data_array(startline:Nlines,tag_energy),& + &data_array(startline:Nlines,tag_weight),1,etot,std_err,delta_std_err) + +! Construct various DMC estimators for the forces + do iion=1,nitot_forces + do iaxis=1,naxis_forces + write(6,*)'Forces on atom ',trim(i2s(iion)),' along axis ',& + &trim(i2s(iaxis)),' Mean (au) Err (au)' + + do n=1,Nlines +! 1. Pure total forces (mixNT,dloc) + forces_array(n,1)=data_array(n,tag_forces(20,iaxis,iion))& ! HFT + &-data_array(n,tag_forces(18,iaxis,iion))& ! PPT + &+data_array(n,tag_forces(15,iaxis,iion))& ! " + &-2.d0*(data_array(n,tag_forces(6,iaxis,iion))& ! NT + & +data_array(n,tag_forces(8,iaxis,iion))& ! " + & +data_array(n,tag_forces(2,iaxis,iion))& ! " + & -data_array(n,tag_forces(3,iaxis,iion))& ! " + & -data_array(n,tag_forces(5,iaxis,iion))& ! " + & -etot*data_array(n,tag_forces(1,iaxis,iion))) ! " +! Pure total forces (purNT,dloc) + forces_array(n,2)=data_array(n,tag_forces(20,iaxis,iion))& ! HFT + &-data_array(n,tag_forces(18,iaxis,iion))& ! PPT + &+data_array(n,tag_forces(15,iaxis,iion))& ! " + &-(data_array(n,tag_forces(17,iaxis,iion))& ! NT + & +data_array(n,tag_forces(19,iaxis,iion))& ! " + & +data_array(n,tag_forces(13,iaxis,iion))& ! " + & -data_array(n,tag_forces(14,iaxis,iion))& ! " + & -data_array(n,tag_forces(16,iaxis,iion))& ! " + & -etot*data_array(n,tag_forces(12,iaxis,iion))) ! " +! Pure HFT forces (d-loc) + forces_array(n,3)=data_array(n,tag_forces(20,iaxis,iion)) + if(data_array(n,tag_forces(10,iaxis,iion))/=0.d0)then +! Pure HFT forces (p-loc) + forces_array(n,4)=data_array(n,tag_forces(21,iaxis,iion)) +! Pure HFT forces (s-loc) + forces_array(n,5)=data_array(n,tag_forces(22,iaxis,iion)) + endif +! Nodal term (mix) + forces_array(n,6)=& + &-2.d0*(data_array(n,tag_forces(6,iaxis,iion))& ! NT + & +data_array(n,tag_forces(8,iaxis,iion))& ! " + & +data_array(n,tag_forces(2,iaxis,iion))& ! " + & -data_array(n,tag_forces(3,iaxis,iion))& ! " + & -data_array(n,tag_forces(5,iaxis,iion))& ! " + & -etot*data_array(n,tag_forces(1,iaxis,iion))) ! " +! Nodal term (pur) + forces_array(n,7)=& + &-(data_array(n,tag_forces(17,iaxis,iion))& ! NT + & +data_array(n,tag_forces(19,iaxis,iion))& ! " + & +data_array(n,tag_forces(13,iaxis,iion))& ! " + & -data_array(n,tag_forces(14,iaxis,iion))& ! " + & -data_array(n,tag_forces(16,iaxis,iion))& ! " + & -etot*data_array(n,tag_forces(12,iaxis,iion))) ! " +! Pseudopotential Pulay term: Psi^(-1)WPsi'-Psi^(-1)WPsi Psi'/Psi + forces_array(n,8)=-data_array(n,tag_forces(18,iaxis,iion))& + &+data_array(n,tag_forces(15,iaxis,iion)) +! 2. Mixed total forces (d-loc) + forces_array(n,9)=data_array(n,tag_forces(9,iaxis,iion))& ! HFT + & -data_array(n,tag_forces(7,iaxis,iion))& ! PPT + & +data_array(n,tag_forces(4,iaxis,iion))& ! " + & -data_array(n,tag_forces(6,iaxis,iion))& ! NT + & -data_array(n,tag_forces(8,iaxis,iion))& ! " + & -2.d0*data_array(n,tag_forces(2,iaxis,iion))& ! " + & +data_array(n,tag_forces(3,iaxis,iion))& ! " + & +data_array(n,tag_forces(5,iaxis,iion))& ! " + & +2.d0*etot*data_array(n,tag_forces(1,iaxis,iion)) ! " + +! Mixed HFT forces (d-loc) + forces_array(n,10)=data_array(n,tag_forces(9,iaxis,iion)) + enddo ! Nlines + +! Write out forces + if(tag_weight>0.and.use_weights)then +! 1. Pure total forces + call reblock_weighted(Nstudy,forces_array(startline:Nlines,1),& + &data_array(startline:Nlines,tag_weight),& + &block_length,av,std_err,delta_std_err) + write(6,9)'Total Force(purHFT,mixNT,dloc) :',av,std_err + call reblock_weighted(Nstudy,forces_array(startline:Nlines,2),& + &data_array(startline:Nlines,tag_weight),block_length,av,std_err,& + &delta_std_err) + write(6,9)'Total Force(purHFT,purNT,dloc) :',av,std_err + call reblock_weighted(Nstudy,forces_array(startline:Nlines,3),& + &data_array(startline:Nlines,tag_weight),block_length,av,std_err,& + &delta_std_err) + write(6,9)'HFT Force(pur,dloc) :',av,std_err + if(data_array(n,tag_forces(10,iaxis,iion))/=0.d0)then + call reblock_weighted(Nstudy,forces_array(startline:Nlines,4),& + &data_array(startline:Nlines,tag_weight),block_length,av,std_err,& + &delta_std_err) + write(6,9)'HFT Force(pur,ploc) :',av,std_err + call reblock_weighted(Nstudy,forces_array(startline:Nlines,5),& + &data_array(startline:Nlines,tag_weight),block_length,av,std_err,& + &delta_std_err) + write(6,9)'HFT Force(pur,sloc) :',av,std_err + endif + call reblock_weighted(Nstudy,forces_array(startline:Nlines,6),& + &data_array(startline:Nlines,tag_weight),block_length,av,std_err,& + &delta_std_err) + write(6,9)'Nodal Term(mix) :', av,std_err + call reblock_weighted(Nstudy,forces_array(startline:Nlines,7),& + &data_array(startline:Nlines,tag_weight),block_length,av,std_err,& + &delta_std_err) + write(6,9)'Nodal Term(pur) :', av,std_err + call reblock_weighted(Nstudy,forces_array(startline:Nlines,8),& + &data_array(startline:Nlines,tag_weight),block_length,av,std_err,& + &delta_std_err) + write(6,9)'Pseudopot. Pulay Term(pur) :',av,std_err +! Mixed total forces + call reblock_weighted(Nstudy,forces_array(startline:Nlines,9),& + &data_array(startline:Nlines,tag_weight),block_length,av,std_err,& + &delta_std_err) + write(6,9)'Total Force(mix,dloc) :',av,std_err + call reblock_weighted(Nstudy,forces_array(startline:Nlines,10),& + &data_array(startline:Nlines,tag_weight),block_length,av,std_err,& + &delta_std_err) + write(6,9)'HFT Force(mix,dloc) :',av,std_err + write(6,*) + +! Reblock forces and write out into files + if(forces_reblock)then + plotname='forces'//'.totpur.'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:Nlines,1),& + &plotname,data_array(startline:Nlines,tag_weight)) + plotname='forces'//'.HFTpur.'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:Nlines,3),& + &plotname,data_array(startline:Nlines,tag_weight)) + plotname='forces'//'.totmix'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:Nlines,9),& + &plotname,data_array(startline:Nlines,tag_weight)) + plotname='forces'//'.HFT'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:Nlines,10),& + &plotname,data_array(startline:Nlines,tag_weight)) + endif ! forces_reblock + + else ! have weights +! 1. Pure total forces + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,1),& + &block_length,av,std_err,delta_std_err) + write(6,9)'Total Force(purHFT,mixHFT,dloc) :',av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,2),& + &block_length,av,std_err,delta_std_err) + write(6,9)'Total Force(purHFT,purHFT,dloc) :',av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,3),& + &block_length,av,std_err,delta_std_err) + write(6,9)'HFT Force(pur,dloc) :',av,std_err + if(data_array(n,tag_forces(10,iaxis,iion))/=0.d0)then + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,4),& + &block_length,av,std_err,delta_std_err) + write(6,9)'HFT Force(pur,ploc) :',av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,5),& + &block_length,av,std_err,delta_std_err) + write(6,9)'HFT Force(pur,sloc) :',av,std_err + endif + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,6),& + &block_length,av,std_err,delta_std_err) + write(6,9)'Nodal Term(mix) :', av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,7),& + &block_length,av,std_err,delta_std_err) + write(6,9)'Nodal Term(pur) :',av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,8),& + &block_length,av,std_err,delta_std_err) + write(6,9)'Pseudopot. Pulay Term(pur) :',av,std_err +! Mixed total forces + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,9),& + &block_length,av,std_err,delta_std_err) + write(6,9)'Total Force(mix,dloc) :',av,std_err + call reblock_unweighted(Nstudy,forces_array(startline:Nlines,10),& + &block_length,av,std_err,delta_std_err) + write(6,9)'HFT Force(mix,dloc) :',av,std_err + write(6,*) + +! Reblock forces and write out into files + if(forces_reblock)then + plotname='forces'//'.totpur.'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:Nlines,1),& + &plotname) + plotname='forces'//'.HFTpur.'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:Nlines,3),& + &plotname) + plotname='forces'//'.totmix.'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:Nlines,9),& + &plotname) + plotname='forces'//'.HFTmix.'//trim(i2s(iaxis))//trim(i2s(iion))//& + &'.plot' + call reblock_forces_analysis(Nstudy,forces_array(startline:Nlines,10),& + &plotname) + endif + endif ! have weights + + enddo ! naxis + enddo ! nitot_forces + + endif ! DMC + +9 format(" ",a32,2(" ",f20.14)) + + END SUBROUTINE construct_write_forces + + +END MODULE analysis + + +PROGRAM analyse_qmc +!---------------------------! +! Main program starts here. ! +!---------------------------! + USE analysis, ONLY : filename,read_data,check_data,compute_stats + IMPLICIT NONE + LOGICAL vmc,dmc + + write(6,*) + write(6,*)'O---------O' + write(6,*)'| REBLOCK |' + write(6,*)'O---------O' + write(6,*) + +! What files are present? + inquire(file='vmc.hist',exist=vmc) + inquire(file='dmc.hist',exist=dmc) + + if(.not.(vmc.or.dmc))then + write(6,*)'Sorry, there are no vmc.hist or dmc.hist files to analyse.' + stop + endif ! No hist files found. + +! Sort out which file to analyse if more than one possibility exists. + if(dmc)then + filename='dmc.hist' + elseif(vmc)then + filename='vmc.hist' + else + write(6,*)'Bug.' + stop + endif + write(6,*)'Data in '//trim(filename)//' will be analysed.' + write(6,*) + +! Read in data from the file. + call read_data(dmc) + +! Check the data for inconsistencies and get units etc. + call check_data + +! Analyse the data. + call compute_stats + + write(6,*)'Program finished.' + write(6,*) + +END PROGRAM analyse_qmc diff --git a/utils/rename b/utils/rename new file mode 100755 index 0000000..ae8cc33 --- /dev/null +++ b/utils/rename @@ -0,0 +1,14 @@ +#! /bin/bash + +if [ $# != 1 ] +then + echo "1 argument required!!" +else + mv Ov.dat Ov."$1".dat + mv Kin.dat Kin."$1".dat + mv Nuc.dat Nuc."$1".dat + mv ERI.dat ERI."$1".dat + mv F12.dat F12."$1".dat + mv Erf.dat Erf."$1".dat +fi +